SUBROUTINE DPFIT(ICAPSW,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--CARRY OUT A LEAST SQUARES FIT C FOR LINEAR AND NON-LINEAR MODELS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/2 C FIX IN HERE C ORIGINAL VERSION--FEBRUARY 1988. C UPDATED --FEBRUARY 1988. (SIMPLIFY THE CALL TO DPFIT3) C UPDATED --MARCH 1988. (ALLOW B0 IN MULTILINEAR FIT) C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --MAY 1989. ALLOW OMNITAB FIT BEYOND 5 VAR. C UPDATED --MAY 1989. ADDED ISUBRO IN CALL TO DPFIT3 C UPDATED --MAY 1989. AUTO COEF--A11, A12, A13, ... C UPDATED --AUGUST 1989. NUMPAR FIXED FOR POLY FIT C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C ALSO, MOVE SOME DIMENSIONS FROM DPFIT2 C AND DPFIT3 TO DPFIT C UPDATED --JUNE 1991. REPLICATION BUG FOR POLY FIT C UPDATED --SEPT 1991. EXPAND IND. VAR. 5 TO 15 C UPDATED --MARCH 1992. FIX INSTAB. MESSAGE (WEIGHTS) C UPDATED --MARCH 1992. ISUBRO ADDED TO DPFIT2 ARG LIST C UPDATED --MAY 1995. FIX SOME I/O C UPDATED --MAY 1995. ADDITIONAL EQUIVALENCE C UPDATED --APRIL 2002. OPTION TO OMIT CONSTANT TERM C FOR MULTILINEAR FIT C UPDATED --JULY 2003. MODIFY STORAGE FOR LINEAR FIT C SO THAT > MAXCMF DEPENDENT C VARIABLES CAN BE USED (I.E., C ADD VARIABLES AT EXPENSE OF C FEWER ROWS) C UPDATED --NOVEMBER 2003. CAPTURE HTML AND LATEX FORMATS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASFI CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 ICASEQ CHARACTER*4 IKEY CHARACTER*4 IWD CHARACTER*4 IWD1 CHARACTER*4 IWD2 CHARACTER*4 IWD12 CHARACTER*4 IWD22 CHARACTER*4 IHPARN CHARACTER*4 IHPAR2 CHARACTER*4 IPAROC CHARACTER*4 IPARO3 CHARACTER*4 ICH CHARACTER*4 IOP CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 CHARACTER*4 IVARN3 CHARACTER*4 IVARN4 CHARACTER*4 IREPU CHARACTER*4 IRESU CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IREP C CCCCC THE FOLLOWING 5 LINES WERE ADDED MAY 1989 CHARACTER*4 IHOUT CHARACTER*4 IVALID CHARACTER*4 IHOUT1 CHARACTER*4 IHOUT2 CHARACTER*4 IHOUT3 C CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1989 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C CCCCC JULY 2003: MAKE MAXIMUM NUMBER OF PARAMETERS SETTABLE VIA CCCCC SINGLE PARAMETER STATEMENT. C PARAMETER(MAXPAR=300) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHO.INC' C DIMENSION IPAROC(MAXPAR) C CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW2HOL(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW2HOL(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C DIMENSION PARAM(MAXPAR) DIMENSION IPARN(MAXPAR) DIMENSION IPARN2(MAXPAR) C DIMENSION X1(MAXOBV) DIMENSION X2(MAXOBV) DIMENSION X3(MAXOBV) DIMENSION X4(MAXOBV) DIMENSION X5(MAXOBV) CCCCC THE FOLLOWING 10 LINES WERE ADDED SEPTEMBER 1991 CCCCC (NO EQUIVALENCE DONE) SEPTEMBER 1991 DIMENSION X6(MAXOBV) DIMENSION X7(MAXOBV) DIMENSION X8(MAXOBV) DIMENSION X9(MAXOBV) DIMENSION X10(MAXOBV) DIMENSION X11(MAXOBV) DIMENSION X12(MAXOBV) DIMENSION X13(MAXOBV) DIMENSION X14(MAXOBV) DIMENSION X15(MAXOBV) C DIMENSION W(MAXOBV) DIMENSION VSDPRD(MAXOBV) C DIMENSION PRED2(MAXOBV) DIMENSION RES2(MAXOBV) C CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989 CCCCC JULY 2003: MAKE 1D ARRAY TO ALLOW MORE FLEXIBILITY BETWEEN CCCCC ALLOCATION OF ROWS AND COLUMNS. C CCCCC DIMENSION XMAT(MAXOBV,MAXCMF) DIMENSION XMAT(MAXOBV*MAXCMF) DIMENSION PARCOV(MAXPAR+1,MAXPAR+1) C DIMENSION PARAM3(MAXPAR) DIMENSION IPARN3(MAXPAR) DIMENSION IPARN4(MAXPAR) DIMENSION ICON3(MAXPAR) DIMENSION IPARO3(MAXPAR) DIMENSION PARLI3(MAXPAR) DIMENSION IVARN3(MAXPAR) DIMENSION IVARN4(MAXPAR) DIMENSION ICOLV3(MAXPAR) DIMENSION NIV(MAXPAR) C DIMENSION ICH(10) C CCCCC THE FOLLOWING LINE WAS ADDED MAY 1989 DIMENSION IHOUT(10) C CCCCC THE FOLLOWING 2 LINES WERE ADDED MAY 1989 DIMENSION IVARN1(MAXPAR) DIMENSION IVARN2(MAXPAR) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C EQUIVALENCE (W(1),X3D(1)) EQUIVALENCE (PRED2(1),X(1)) EQUIVALENCE (RES2(1),D(1)) EQUIVALENCE (DFILL(1),VSDPRD(1)) C CCCCC FOLLOWING LINES ADDED JUNE, 1990. THE DUMMY ARRAYS ARE ONES THAT CCCCC WERE PREVIOUSLY DIMENSIONED IN DPFIT2 AND DPFIT3. DIMENSIONING MOVED CCCCC HERE TO ALLOW EQUIVALENE TO GARBAGE ARRAY (THEY ARE NAMED CORRECTLY CCCCC IN THE RECIEVING ROUTINES). INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' DIMENSION DUMMY1(MAXOBV) DIMENSION DUMMY2(MAXOBV) DIMENSION DUMMY3(MAXOBV) DIMENSION DUMMY4(MAXOBV) DIMENSION DUMMY5(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),X2(1)) EQUIVALENCE (GARBAG(IGARB3),X3(1)) EQUIVALENCE (GARBAG(IGARB4),X4(1)) EQUIVALENCE (GARBAG(IGARB5),X5(1)) EQUIVALENCE (GARBAG(IGARB6),DUMMY1(1)) EQUIVALENCE (GARBAG(IGARB7),DUMMY2(1)) EQUIVALENCE (GARBAG(IGARB8),DUMMY3(1)) EQUIVALENCE (GARBAG(IGARB9),DUMMY4(1)) EQUIVALENCE (GARBAG(IGAR10),DUMMY5(1)) CCCCC MAY 1995. ADD FOLLOWING 10 LINES EQUIVALENCE (GARBAG(JGAR11),X6(1)) EQUIVALENCE (GARBAG(JGAR12),X7(1)) EQUIVALENCE (GARBAG(JGAR13),X8(1)) EQUIVALENCE (GARBAG(JGAR14),X9(1)) EQUIVALENCE (GARBAG(JGAR15),X10(1)) EQUIVALENCE (GARBAG(JGAR16),X11(1)) EQUIVALENCE (GARBAG(JGAR17),X12(1)) EQUIVALENCE (GARBAG(JGAR18),X13(1)) EQUIVALENCE (GARBAG(JGAR19),X14(1)) EQUIVALENCE (GARBAG(JGAR20),X15(1)) C CCCCC EQUIVALENCE (G2RBAG(IGAR11),XMAT(1,1)) EQUIVALENCE (G2RBAG(IGAR11),XMAT(1)) CCCCC END CHANGE C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPFI' ISUBN2='T ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IPAROC(1)='NONE' C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1991 CCCCC MAXV2=5 MAXV2=15 MINN2=2 C MAXITS=IFITIT CPUEPS=R1MACH(3) C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C NUMPV=(-999) IP=(-999) IV=(-999) C IWIDMO=(-999) C CCCCC CUTOFF=2**(NUMBPW-3) ICUTMX=NUMBPW IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48 IF(IHOST1.EQ.'205 ')ICUTMX=48 CUTOFF=2**(ICUTMX-3) C NUMIND=(-999) C C ************************** C ** TREAT THE FIT CASE ** C ************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IFITAC,IBUGA2,IBUGA3 53 FORMAT('IFITAC,IBUGA2,IBUGA3 = ',A4,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL CKFIT(ICASFI,ILOCFI,IBUGA3,IFOUND,IERROR) IF(ICASFI.EQ.' '.OR.IFOUND.EQ.'NO')GOTO9000 C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ****************************************************** C ** STEP 3-- C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION C ** ROBUST FIT Y = SOME EXPRESSION, C ** DETERMINE IF WE HAVE A VALID FUNCTIONAL EXPRESSION-- C ** IN PARTICULAR, CHECK THAT THE NUMBER OF ARGUMENTS C ** IS AT LEAST 1, C ** AND ALSO CHECK THAT THERE IS EXACTLY 1 EQUAL SIGN C ** AND THAT THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT. C ****************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.1)GOTO2090 WRITE(ICOUT,2001) 2001 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002) 2002 FORMAT(' NUMBER OF ARGUMENTS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2003)NUMARG 2003 FORMAT(' IN FIT COMMAND = 0. NUMARG = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2007)IWIDTH 2007 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH)) 2008 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2090 CONTINUE C DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO2110 2100 CONTINUE ILOCQ=NUMARG+1 GOTO2120 2110 CONTINUE ILOCQ=J1 GOTO2120 2120 CONTINUE C IF(ICASFI.EQ.'FIT')GOTO2125 IF(ICASFI.EQ.'RFIT')GOTO2125 GOTO2190 2125 CONTINUE NUMEQ=0 IMAX=ILOCQ-1 DO2130I=1,IMAX IF(IHARG(I).EQ.'= '.AND.IHARG2(I).EQ.' ')NUMEQ=NUMEQ+1 2130 CONTINUE IF(NUMEQ.EQ.1)GOTO2190 WRITE(ICOUT,2131) 2131 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2132) 2132 FORMAT(' NUMBER OF EQUAL SIGNS DETECTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2133)NUMEQ 2133 FORMAT(' IN MODEL NOT EQUAL 1. NUMEQ = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2134)NUMARG,IMAX 2134 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2135I=1,NUMARG WRITE(ICOUT,2136)I,IHARG(I),IHARG2(I) 2136 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2135 CONTINUE WRITE(ICOUT,2137)IWIDTH 2137 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2138)(IANS(J),J=1,MIN(100,IWIDTH)) 2138 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2190 CONTINUE C IF(ICASFI.EQ.'FIT'.AND.IHARG(2).NE.'=')GOTO2200 IF(ICASFI.EQ.'RFIT'.AND.IHARG(3).NE.'=')GOTO2200 GOTO2290 C 2200 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' WHEN FITTING GENERAL EXPRESSIONS,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203) 2203 FORMAT(' THE SECOND ARGUMENT AFTER THE WORD FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' SHOULD BE (BUT WAS NOT) AN EQUAL SIGN.') CALL DPWRST('XXX','BUG ') IF(ICASFI.EQ.'FIT')THEN WRITE(ICOUT,2205)IHARG(2),IHARG2(2) 2205 FORMAT(' THE ARGUMENT WAS ',A4,A4) CALL DPWRST('XXX','BUG ') ENDIF IF(ICASFI.EQ.'RFIT')THEN WRITE(ICOUT,2205)IHARG(3),IHARG2(3) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,2207)IWIDTH 2207 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2208)(IANS(J),J=1,MIN(100,IWIDTH)) 2208 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2290 CONTINUE C C ****************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** THE WORD AFTER FIT SHOULD BE THE RESPONSE* C ** VARIABLE (= THE DEPENDENT VARIABLE). ** C ** EXTRACT THE RESPONSE VARIABLE AND DETERMINE ** C ** IF IT IS ALREADY IN THE NAME LIST AND IS, IN FACT,* C ** A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ****************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C I2=0 C CCCCC IF(ICASFI.EQ.'FIT')GOTO2319 IF(ICASFI.EQ.'RFIT')GOTO2319 GOTO2349 2319 CONTINUE C IMAX=ILOCQ-1 DO2330I=1,IMAX I2=I IF(IHARG(I).EQ.'FIT')GOTO2349 2330 CONTINUE WRITE(ICOUT,2331) 2331 FORMAT('***** INTERNAL ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2332) 2332 FORMAT(' THE WORD FIT NOT FOUND IN THE ARGUMENT LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3334) 3334 FORMAT(' EVEN THOUGH IT HAD BEEN PREVIOUSLY FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2335)NUMARG,IMAX 2335 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2336I=1,NUMARG WRITE(ICOUT,2337)I,IHARG(I),IHARG2(I) 2337 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2336 CONTINUE WRITE(ICOUT,2338)IWIDTH 2338 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2339)(IANS(J),J=1,IWIDTH) 2339 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2349 CONTINUE ILOCFI=I2 C ILOCF1=ILOCFI+1 IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) DO2350I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I2).AND.IHLEF2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME FOLLOWING THE WORD FIT (WHICH ', 1 'SHOULD BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' THE RESPONSE VARIABLE) EITHER DOES NOT EXIST OR ', 1 'IS A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' PARAMETER (AS OPPOSED TO A VARIABLE) IN THE ', 1 'CURRENT LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' OF AVAILABLE VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHLEFT,IHLEF2 2369 FORMAT(' NAME AFTER THE WORD FIT = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(J),J=1,MIN(100,IWIDTH)) 2378 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2379 CONTINUE ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) 2390 CONTINUE C C ******************************************************* C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C ******************************************************* C ISTEPN='5' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN VARIABLE ', 1A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A LEAST-SQUARES FIT WAS TO HAVE BEEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' PERFORMED) MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS NLEFT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,319)(IANS(I),I=1,MIN(100,IWIDTH)) 319 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 390 CONTINUE C C ************************************************ C ** STEP 5.1-- ** C ** CHECK TO SEE IF HAVE A WEIGHTS VARIABLE. ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ************************************************ C ISTEPN='5.1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCW=-99 ICOLW=-99 NWEIGH=-99 IF(IWEIGH.EQ.'OFF')GOTO2490 DO2450I=1,NUMNAM I2=I IF(IWEIG1.EQ.IHNAME(I2).AND.IWEIG2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2479 2450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2461) 2461 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2463) 2463 FORMAT(' THE WEIGHTS VARIABLE (AS SPECIFIED VIA THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2464) 2464 FORMAT(' WEIGHTS COMMAND) EITHER DOES NOT EXIST, OR IS A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2465) 2465 FORMAT(' )') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2466) 2466 FORMAT(' PARAMETER (AS OPPOSED TO A VARIABLE) IN THE ', 1 'CURRENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2467) 2467 FORMAT(' LIST OF AVAILABLE VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2469)IWEIG1,IWEIG2 2469 FORMAT(' NAME OF SPECIFIED WEIGHTS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2478)(IANS(J),J=1,MIN(100,IWIDTH)) 2478 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2479 CONTINUE ILOCW=I2 ICOLW=IVALUE(ILOCW) NWEIGH=IN(ILOCW) 2490 CONTINUE C C **************************************************************** C ** STEP 6.1-- C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION C ** ROBUST FIT Y = SOME EXPRESSION , C ** EXTRACT THE ENTIRE (LEFT AND RIGHT SIDE) FUNCTIONAL C ** EXPRESSION FROM THE INPUT COMMAND LINE. C ** COPY OUT TO IWIDTH, OR OUT TO 'SUBS' (EXCLUSIVE), C ** OR OUT THE 'EXCE' (EXCLUSIVE) C ** OR OUT THE 'FOR' (EXCLUSIVE). C **************************************************************** C ISTEPN='6.1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'FIT')GOTO4100 IF(ICASFI.EQ.'RFIT')GOTO4100 GOTO4190 4100 CONTINUE IF(NUMARG.EQ.0)GOTO4160 IF(IHARG(1).EQ.'SUBS'.AND.IHARG2(1).EQ.'ET ')GOTO4160 IF(IHARG(1).EQ.'EXCE'.AND.IHARG2(1).EQ.'PT ')GOTO4160 IF(IHARG(1).EQ.'FOR '.AND.IHARG2(1).EQ.' ')GOTO4160 ISTART=-99 ISTOP=-99 DO4110I=1,IWIDTH IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IP7=I+7 C IF(IP2.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.'F'.AND.IANS(IP1).EQ.'I'. 1AND.IANS(IP2).EQ.'T') 1ISTART=IP3 C IF(IP4.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'F'. 1AND.IANS(IP2).EQ.'O'.AND.IANS(IP3).EQ.'R'. 1AND.IANS(IP4).EQ.' ')ISTOP=I C IF(IP7.GT.IWIDTH)GOTO4120 IF(IANS(I).EQ.' '.AND.IANS(IP1).EQ.'S'. 1AND.IANS(IP2).EQ.'U'.AND.IANS(IP3).EQ.'B'. 1AND.IANS(IP4).EQ.'S'.AND.IANS(IP5).EQ.'E'. 1AND.IANS(IP6).EQ.'T'.AND.IANS(IP7).EQ.' ')ISTOP=I C 4110 CONTINUE 4120 CONTINUE IF(ISTART.GE.1)GOTO4129 IBRAN=4120 WRITE(ICOUT,4121)IBRAN 4121 FORMAT('*****INTERNAL ERROR IN DPFIT--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4122) 4122 FORMAT('THE STRING FIT NOT FOUND FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4123) 4123 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4124)(IANS(I),I=1,MIN(100,IWIDTH)) 4124 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 4129 CONTINUE C 4130 CONTINUE IF(ISTOP.EQ.-99)ISTOP=IWIDTH IF(ISTART.LE.ISTOP)GOTO4139 IBRAN=4130 WRITE(ICOUT,4131) 4131 FORMAT('INTERNAL ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4132)IBRAN 4132 FORMAT('AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4133) 4133 FORMAT('ISTART GREATER THAN ISTOP FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4134)ISTART,ISTOP 4134 FORMAT('ISTART, ISTOP = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4135) 4135 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,4136)(IANS(I),I=1,MIN(100,IWIDTH)) 4136 FORMAT(' ',100A1) ENDIF IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4139 CONTINUE C J=0 DO4150I=ISTART,ISTOP J=J+1 MODEL(J)=IANS(I) 4150 CONTINUE NUMCHA=ISTOP-ISTART+1 4160 CONTINUE 4190 CONTINUE C C *************************************************** C ** STEP 6.2-- ** C ** FOR THE CASES WHEN HAVE ... FIT Y X , ** C ** EXTRACT THE INDEPENDENT VARIABLE, ** C ** AND FORM THE 1 CHARACTER PER WORD ** C ** REPRESENTATION OF THE MODEL. ** C *************************************************** C ISTEPN='6.2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'FIT')GOTO4290 IF(ICASFI.EQ.'RFIT')GOTO4290 IF(ICASFI.EQ.'MFIT')GOTO4290 C ILOCRV=ILOCFI+1 ILOCIV=ILOCFI+2 C IDEGRE=0 IF(ICASFI.EQ.'0FIT')IDEGRE=0 IF(ICASFI.EQ.'1FIT')IDEGRE=1 IF(ICASFI.EQ.'2FIT')IDEGRE=2 IF(ICASFI.EQ.'3FIT')IDEGRE=3 IF(ICASFI.EQ.'4FIT')IDEGRE=4 IF(ICASFI.EQ.'5FIT')IDEGRE=5 IF(ICASFI.EQ.'6FIT')IDEGRE=6 IF(ICASFI.EQ.'7FIT')IDEGRE=7 IF(ICASFI.EQ.'8FIT')IDEGRE=8 IF(ICASFI.EQ.'9FIT')IDEGRE=9 IF(ICASFI.EQ.'10FI')IDEGRE=10 K1=IDEGRE+1 C I=0 C IWD=IHARG(ILOCRV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4219 DO4210J=1,IEND I=I+1 MODEL(I)=ICH(J) 4210 CONTINUE 4219 CONTINUE C IWD=IHARG2(ILOCRV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4229 DO4220J=1,IEND I=I+1 MODEL(I)=ICH(J) 4220 CONTINUE 4229 CONTINUE C KMAX=IDEGRE+1 I=I+1 MODEL(I)='=' C KMAX=IDEGRE+1 DO4250K=1,KMAX KM1=K-1 C IF(KM1.LE.0)GOTO4251 I=I+1 MODEL(I)='+' 4251 CONTINUE C I=I+1 MODEL(I)='A' C IF(0.LE.KM1.AND.KM1.LE.10)I=I+1 IF(KM1.EQ.0)MODEL(I)='0' IF(KM1.EQ.1)MODEL(I)='1' IF(KM1.EQ.2)MODEL(I)='2' IF(KM1.EQ.3)MODEL(I)='3' IF(KM1.EQ.4)MODEL(I)='4' IF(KM1.EQ.5)MODEL(I)='5' IF(KM1.EQ.6)MODEL(I)='6' IF(KM1.EQ.7)MODEL(I)='7' IF(KM1.EQ.8)MODEL(I)='8' IF(KM1.EQ.9)MODEL(I)='9' IF(KM1.EQ.10)MODEL(I)='1' IF(KM1.EQ.10)I=I+1 IF(J.EQ.10)MODEL(I)='0' C IF(KM1.LE.0)GOTO4250 C I=I+1 MODEL(I)='*' C IWD=IHARG(ILOCIV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4269 DO4260J=1,IEND I=I+1 MODEL(I)=ICH(J) 4260 CONTINUE 4269 CONTINUE C IWD=IHARG2(ILOCIV) CALL DPXH1H(IWD,ICH,IEND,IBUGA3) IF(IEND.LE.0)GOTO4279 DO4270J=1,IEND I=I+1 MODEL(I)=ICH(J) 4270 CONTINUE 4279 CONTINUE C IF(KM1.LE.1)GOTO4250 C I=I+1 MODEL(I)='*' I=I+1 MODEL(I)='*' C IF(0.LE.KM1.AND.KM1.LE.10)I=I+1 IF(KM1.EQ.0)MODEL(I)='0' IF(KM1.EQ.1)MODEL(I)='1' IF(KM1.EQ.2)MODEL(I)='2' IF(KM1.EQ.3)MODEL(I)='3' IF(KM1.EQ.4)MODEL(I)='4' IF(KM1.EQ.5)MODEL(I)='5' IF(KM1.EQ.6)MODEL(I)='6' IF(KM1.EQ.7)MODEL(I)='7' IF(KM1.EQ.8)MODEL(I)='8' IF(KM1.EQ.9)MODEL(I)='9' IF(KM1.EQ.10)MODEL(I)='1' IF(KM1.EQ.10)I=I+1 IF(J.EQ.10)MODEL(I)='0' C 4250 CONTINUE 4290 CONTINUE IWIDMO=I NUMCHA=IWIDMO C C ********************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** FOR SOME VARIATIONS OF THE FIT COMMAND, ** C ** EXTRACT THE UNDERLYING FUNCTION ** C ** FROM FUNCTION DEFINITIONS. ** C ********************************************** C C ISTEPN='6.4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'FIT')GOTO5160 IF(ICASFI.EQ.'RFIT')GOTO5160 GOTO5189 C 5160 CONTINUE DO5170I=1,NUMCHA I2=I IF(MODEL(I).EQ.'=')GOTO5175 5170 CONTINUE IBRAN=5170 WRITE(ICOUT,5171)IBRAN 5171 FORMAT('*****INTERNAL ERROR IN DPFIT--', 1'IMPOSSIBLE CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5172) 5172 FORMAT('NO EQUAL SIGN FOUND FOR MODEL EXTRACTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5173) 5173 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,5174)(IANS(I),I=1,MIN(100,IWIDTH)) 5174 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 5175 CONTINUE ILOCEQ=I2 C IWD1='= ' IWD12=' ' IF(ICASEQ.EQ.'FULL')IWD2=' ' IF(ICASEQ.EQ.'FULL')IWD22=' ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD2='SUBS' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'SUBS')IWD22='ET ' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD2='EXCE' IF(ICASEQ.EQ.'SUBS'.AND.IKEY.EQ.'EXCE')IWD22='PT ' IF(ICASEQ.EQ.'FOR')IWD2='FOR ' IF(ICASEQ.EQ.'FOR')IWD22=' ' C IF(ICASFI.EQ.'FIT'.OR.ICASFI.EQ.'RFIT') 1CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(ICASFI.NE.'FIT'.AND.ICASFI.NE.'RFIT') 1CALL DPEXST(MODEL,IWIDMO,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3379 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3371) 3371 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3372) 3372 FORMAT(' INVALID COMMAND FORM FOR FITTING. GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3374) 3374 FORMAT(' FIT ... = ... ', 1'SUBSET ... ... ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3375) 3375 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,3376)(IANS(I),I=1,IWIDTH) 3376 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 3379 CONTINUE C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C J=ILOCEQ DO5180I=1,N3 J=J+1 MODEL(J)=IFUNC3(I) 5180 CONTINUE NUMCHA=J C 5189 CONTINUE C C ****************************************************** C ** STEP 7-- ** C ** MAKE A NON-CALCULATING PASS AT THE MODEL ** C ** SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. C ****************************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=1 CCCCC CALL COMPI2(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, CCCCC1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED, CCCCC1IBUGCO,IBUGEV,IERROR) IF(ICASFI.EQ.'FIT')GOTO6400 IF(ICASFI.EQ.'RFIT')GOTO6400 IF(ICASFI.EQ.'MFIT')GOTO6410 GOTO6420 C 6400 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 1IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,AJUNK, 1IBUGCO,IBUGEV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO6490 C 6410 CONTINUE CCCCC THE FOLLOWING SECTION (DOWN TO 6411 CONTINUE) WAS REWRITTEN MAY 1989 CCCCC IPARN(1)='A0' CCCCC IPARN(2)='A1' CCCCC IPARN(3)='A2' CCCCC IPARN(4)='A3' CCCCC IPARN(5)='A4' CCCCC IPARN(6)='A5' CCCCC IPARN(7)='A6' CCCCC IPARN(8)='A7' CCCCC IPARN(9)='A8' CCCCC IPARN(10)='A9' CCCCC IPARN(11)='A10' CCCCC DO6411I5=1,11 CCCCC IPARN2(I5)=' ' C6411 CONTINUE C CCCCC APRIL 2002. IF SET FIT CONSTANT OFF ENTERED, THEN DO NOT CCCCC FIT A CONSTANT TERM. UPDATE CODE BELOW ACCORDINGLY. C JMIN=2 JMAX=ILOCQ-1 MAXIND=MAXCMF-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1IVARN1,IVARN2,NUMIND,IBUGA2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8000 C IF(IFITAC.EQ.'OFF')THEN NUMPAR=NUMIND ISTRT=2 ISTOP=NUMPAR+1 ELSE NUMPAR=NUMIND+1 ISTRT=1 ISTOP=NUMPAR ENDIF C CCCCC DO6411I5=1,NUMPAR ICOUNT=0 DO6411I5=ISTRT,ISTOP ICOUNT=ICOUNT+1 I5M1=I5-1 IH=' ' IH2=' ' CALL DPCOIH(I5M1,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR) IHOUT1=IHOUT(1) IHOUT2=IHOUT(2) IHOUT3=IHOUT(3) IH(1:1)='A' IF(NOUT.GE.1)IH(2:2)=IHOUT1(1:1) IF(NOUT.GE.2)IH(3:3)=IHOUT2(1:1) IF(NOUT.GE.3)IH(4:4)=IHOUT3(1:1) IPARN(ICOUNT)=IH IPARN2(ICOUNT)=IH2 6411 CONTINUE C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT MAY 1989 CCCCC NUMIND=ILOCQ-2 CCCCC THE FOLLOWING LINE WAS FIXED MARCH 1989 CCCCC NUMPV=NUMIND NUMPV=NUMPAR ILOCQM=ILOCQ-1 CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989 CCCCC DO6412I5=2,ILOCQM DO6412I5=1,NUMIND NUMPV=NUMPV+1 CCCCC THE FOLLOWING LINE WAS FIXED MARCH 1989 CCCCC J5=NUMIND+(I5-1) CCCCC J5=NUMIND+1+(I5-1) J5=NUMPAR+I5 IPARN(J5)=IVARN1(I5) IPARN2(J5)=IVARN2(I5) 6412 CONTINUE GOTO6490 C 6420 CONTINUE CCCCC THE FOLLOWING SECTION (DOWN TO 6421 CONTINUE) WAS REWRITTEN MAY 1989 CCCCC IPARN(1)='A0' CCCCC IPARN(2)='A1' CCCCC IPARN(3)='A2' CCCCC IPARN(4)='A3' CCCCC IPARN(5)='A4' CCCCC IPARN(6)='A5' CCCCC IPARN(7)='A6' CCCCC IPARN(8)='A7' CCCCC IPARN(9)='A8' CCCCC IPARN(10)='A9' CCCCC IPARN(11)='A10' CCCCC DO6421I5=1,11 CCCCC IPARN2(I5)=' ' C6421 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1989 NUMPAR=IDEGRE+1 DO6421I5=1,NUMPAR I5M1=I5-1 IH=' ' IH2=' ' CALL DPCOIH(I5M1,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR) IHOUT1=IHOUT(1) IHOUT2=IHOUT(2) IHOUT3=IHOUT(3) IH(1:1)='A' IF(NOUT.GE.1)IH(2:2)=IHOUT1(1:1) IF(NOUT.GE.2)IH(3:3)=IHOUT2(1:1) IF(NOUT.GE.3)IH(4:4)=IHOUT3(1:1) IPARN(I5)=IH IPARN2(I5)=IH2 6421 CONTINUE C IDEGRE=0 IF(ICASFI.EQ.'0FIT')IDEGRE=0 IF(ICASFI.EQ.'1FIT')IDEGRE=1 IF(ICASFI.EQ.'2FIT')IDEGRE=2 IF(ICASFI.EQ.'3FIT')IDEGRE=3 IF(ICASFI.EQ.'4FIT')IDEGRE=4 IF(ICASFI.EQ.'5FIT')IDEGRE=5 IF(ICASFI.EQ.'6FIT')IDEGRE=6 IF(ICASFI.EQ.'7FIT')IDEGRE=7 IF(ICASFI.EQ.'8FIT')IDEGRE=8 IF(ICASFI.EQ.'9FIT')IDEGRE=9 IF(ICASFI.EQ.'10FI')IDEGRE=10 NUMPV=IDEGRE+2 IPARN(NUMPV)=IHARG(2) IPARN2(NUMPV)=IHARG2(2) GOTO6490 C 6490 CONTINUE C C ******************************************** C ** STEP 8-- ** C ** CHECK TO MAKE SURE THAT THE COMBINED ** C ** NUMBER OF PARAMETERS AND VARIABLES ** C ** IN THE MODEL IS AT LEAST 1. ** C ******************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPV.GE.1)GOTO4400 WRITE(ICOUT,4401) 4401 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4402) 4402 FORMAT(' COMBINED NUMBER OF PARAMETERS AND VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4403)NUMPV 4403 FORMAT(' DETECTED IN THE MODEL IS 0. NUMPV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4407)NUMCHA 4407 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMCHA.GE.1)THEN WRITE(ICOUT,4408)(MODEL(J),J=1,MIN(100,NUMCHA)) 4408 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 4400 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** CHECK THAT ALL VARIABLES ** C ** IN THE MODEL ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.). C ** CHECK THAT ALL PARAMETERS ** C ** IN THE MODEL ARE ALREADY PRESENT ** C ** IN THE AVAILABLE NAME LIST IHNAME(.) AND IHNAM2(.). C ** ALL NAMES IN THE MODEL THAT ARE NOT ** C ** IN THE NAME LIST AT ALL WILL BE ADDED ** C ** TO THE LIST, DEFINED AS PARAMETERS, ** C ** AND GIVEN A VALUE OF 1.0. ** C ** THIS ALLOWS US TO MAKE AN INITIAL FIT ** C ** WITHOUT HAVING TO DEFINE STARTING VALUES AT ALL ** C ** (THEY WILL BE AUTOMATICALLY SET TO 1.0). ALSO, ** C ** FORM A NEW VECTOR WHICH HAS ONLY PARAMETER NAMES** C ** AND ANOTHER VECTOR WHICH HAS ONLY VARIABLE NAMES.* C ****************************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IP=0 IV=0 DO4165J=1,NUMPV IHPARN=IPARN(J) IHPAR2=IPARN2(J) DO4166I=1,NUMNAM I2=I IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO4180 IF(IHPARN.EQ.IHNAME(I).AND.IHPAR2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO4170 4166 CONTINUE IP=IP+1 IPARN3(IP)=IPARN(J) IPARN4(IP)=IPARN2(J) PARAM3(IP)=1.0 C IF(NUMNAM.LT.MAXNAM)GOTO7769 WRITE(ICOUT,7751) 7751 FORMAT('***** ERROR IN DPEXAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7752) 7752 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER) NAMES ', 1 'MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7754)MAXNAM 7754 FORMAT(' BE AT MOST ',I8,'. SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7755) 7755 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES WAS JUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7757) 7757 FORMAT(' EXCEEDED. SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7758) 7758 FORMAT(' TO DETERMINE THE IMPORTANT (VERSUS UNIMPORTANT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7760) 7760 FORMAT(' VARIABLES AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7761) 7761 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7762) 7762 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,7763)(IANS(I),I=1,MIN(100,IWIDTH)) 7763 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 7769 CONTINUE C I2=NUMNAM+1 IHNAME(I2)=IPARN(J) IHNAM2(I2)=IPARN2(J) IUSE(I2)='P' IVALUE(I2)=1 VALUE(I2)=1.0 IN(I2)=1 NUMNAM=I2 IF(ICASFI.EQ.'MFIT')GOTO4259 IF(ICASFI.EQ.'0FIT')GOTO4259 IF(ICASFI.EQ.'1FIT')GOTO4259 IF(ICASFI.EQ.'2FIT')GOTO4259 IF(ICASFI.EQ.'3FIT')GOTO4259 IF(ICASFI.EQ.'4FIT')GOTO4259 IF(ICASFI.EQ.'5FIT')GOTO4259 IF(ICASFI.EQ.'6FIT')GOTO4259 IF(ICASFI.EQ.'7FIT')GOTO4259 IF(ICASFI.EQ.'8FIT')GOTO4259 IF(ICASFI.EQ.'9FIT')GOTO4259 IF(ICASFI.EQ.'10FI')GOTO4259 IF(IFEEDB.EQ.'OFF')GOTO4259 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' NOTE--A NAME USED IN AN EXPRESSION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IPARN(J),IPARN2(J) 4253 FORMAT(' HAS NOT YET BEEN DEFINED. NAME = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255) 4255 FORMAT(' THIS NAME HAS BEEN ADDED TO THE LIST, SPECIFIED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257) 4257 FORMAT(' AS A PARAMETER, AND GIVEN THE VALUE 1.0 .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258)(MODEL(I),I=1,MIN(100,NUMCHA)) 4258 FORMAT(' FUNCTION EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') 4259 CONTINUE GOTO4165 4170 CONTINUE IP=IP+1 IPARN3(IP)=IPARN(J) IPARN4(IP)=IPARN2(J) PARAM3(IP)=VALUE(I2) GOTO4165 4180 CONTINUE IV=IV+1 CCCCC LOCX(IV)=J IVARN3(IV)=IPARN(J) IVARN4(IV)=IPARN2(J) ICOLV3(IV)=IVALUE(I2) NIV(IV)=IN(I2) GOTO4165 4165 CONTINUE NUMPAR=IP NUMVAR=IV C C ******************************************* C ** STEP 10-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF INDEPENDENT VARIABLES (1 TO 5). ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE INDEPENDENT VARIABLES. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE RESPONSE VARIABLE? ** C ******************************************* C ISTEPN='10' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989 IF(ICASFI.NE.'FIT')GOTO520 C IF(NUMVAR.GE.1.AND.NUMVAR.LE.MAXV2)GOTO520 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A LEAST SQUARES FIT, THE NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' INDEPENDENT VARIABLES MUST BE AT LEAST 1 AND AT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555)MAXV2 555 FORMAT(' MOST ',I8,'. SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMVAR 557 FORMAT(' THE SPECIFIED NUMBER OF INDEPENDENT VARIABLES ', 1 'WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,559)(IANS(I),I=1,MIN(100,IWIDTH)) 559 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4507)NUMCHA 4507 FORMAT(' NUMBER OF CHARACTERS IN MODEL = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4508)(MODEL(J),J=1,MIN(100,NUMCHA)) 4508 FORMAT(' MODEL--',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4504) 4504 FORMAT(' VARIABLES EXTRACTED FROM MODEL--') CALL DPWRST('XXX','BUG ') DO4505J=1,NUMVAR WRITE(ICOUT,4506)J,IVARN3(J),IVARN4(J),ICOLV3(J) 4506 FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 4505 CONTINUE IERROR='YES' GOTO9000 C 520 CONTINUE DO540J=1,NUMVAR IF(NIV(J).NE.NLEFT)GOTO560 540 CONTINUE GOTO590 C 560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562) 562 FORMAT(' FOR A LEAST SQUARES FIT, THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,564) 564 FORMAT(' IN EACH INDEPENDENT VARIABLE SHOULD BE THE SAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,565) 565 FORMAT(' AS THE NUMBER OF ELEMENTS IN THE DEPENDENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,567) 567 FORMAT(' VARIABLE (RESPONSE); SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT(' DEPENDENT VARIABLE (RESPONSE)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572)IHLEFT,IHLEF2,NLEFT 572 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' INDEPENDENT VARIABLES --') CALL DPWRST('XXX','BUG ') DO580J=1,NUMVAR WRITE(ICOUT,578)IVARN3(J),IVARN4(J),NIV(J) 578 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 580 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,588)(IANS(I),I=1,MIN(100,IWIDTH)) 588 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 590 CONTINUE C C ****************************************************** C ** STEP 11-- C ** DUMP THE COMMON VECTOR V(.) OUT ONTO MASS STORAGE C ** SO AS TO PRESERVE THEIR CONTENTS FOR LATER USE C ** (AFTER DPFIT2). THE ABOVE DUMP TO MASS C ** STORAGE IS UNNECESSARY AND IS NOT DONE FOR C ** THE SPECIAL CASE WHEN THE NUMBER OF PARAMETERS IS C ** 0 (A NO-FIT CASE WHEREBY WE ARE REALLY INTERESTED C ** IN GENERATING PREDICTED VALUES AND RESIDUALS C ** FOR A GIVEN FULLY-SPECIFIED MODEL). C ****************************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOP='WRIT' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C C ******************************************************* C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN COPY ** C ** OVER THE RESPONSE VECTOR TO BE USED IN THE MODEL ** C ** INTO THE VECTOR Y; AND ** C ** COPY OVER THE WEIGHTS INTO THE VECTOR W; ** C ** COPY OVER THE VECTORS THAT WERE USED IN THE MODEL** C ** INTO THE VECTORS X1, X2, X3,X4, AND X5. ** C ** (MAX NUMBER OF ALLOWABLE VECTORS = 5.) ** C ******************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT')WRITE(ICOUT,601)N,NUMVAR 601 FORMAT('N,NUMVAR = ',2I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT')CALL DPWRST('XXX','BUG ') C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE K=ICOLL J=0 DO4500I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4500 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)Y(J)=V(IJ) IF(K.EQ.MAXCP1)Y(J)=PRED(I) IF(K.EQ.MAXCP2)Y(J)=RES(I) IF(K.EQ.MAXCP3)Y(J)=YPLOT(I) IF(K.EQ.MAXCP4)Y(J)=XPLOT(I) IF(K.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(K.EQ.MAXCP6)Y(J)=TAGPLO(I) 4500 CONTINUE C K=ICOLW J=0 DO380I=1,NLEFT W(I)=1.0 CCCCC THE FOLLOWING LINE WAS MOVED MARCH 1992 CCCCC IF(IWEIGH.EQ.'OFF')GOTO380 IF(ISUB(I).EQ.0)GOTO380 J=J+1 CCCCC THE FOLLOWING LINE WAS ADDED MARCH 1992 IF(IWEIGH.EQ.'OFF')GOTO380 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)W(J)=V(IJ) IF(K.EQ.MAXCP1)W(J)=PRED(I) IF(K.EQ.MAXCP2)W(J)=RES(I) IF(K.EQ.MAXCP3)W(J)=YPLOT(I) IF(K.EQ.MAXCP4)W(J)=XPLOT(I) IF(K.EQ.MAXCP5)W(J)=X2PLOT(I) IF(K.EQ.MAXCP6)W(J)=TAGPLO(I) 380 CONTINUE C CCCCC THE FOLLOWING SECTION (TO 389 CONTINUE) WAS ADDED MAY 1989 IF(ICASFI.EQ.'FIT')GOTO389 IF(ICASFI.EQ.'RFIT')GOTO389 IF(ICASFI.EQ.'MFIT')GOTO382 C K=ICOLV3(1) J=0 DO381I=1,NLEFT IF(ISUB(I).EQ.0)GOTO381 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XMAT(J)=V(IJ) IF(K.EQ.MAXCP1)XMAT(J)=PRED(I) IF(K.EQ.MAXCP2)XMAT(J)=RES(I) IF(K.EQ.MAXCP3)XMAT(J)=YPLOT(I) IF(K.EQ.MAXCP4)XMAT(J)=XPLOT(I) IF(K.EQ.MAXCP5)XMAT(J)=X2PLOT(I) IF(K.EQ.MAXCP6)XMAT(J)=TAGPLO(I) 381 CONTINUE GOTO4590 C CCCCC APRIL 2002. IF A SET FIT CONSTANT OFF COMMAND ENTERED, CCCCC THEN NO CONSTANT TERM. C 382 CONTINUE J=0 IF(IFITAC.EQ.'ON')THEN DO383I=1,NLEFT IF(ISUB(I).EQ.0)GOTO383 J=J+1 XMAT(J)=1.0 383 CONTINUE ENDIF C DO385L=1,NUMVAR IF(IFITAC.EQ.'ON')THEN LP1=L+1 ELSE LP1=L ENDIF K=ICOLV3(L) J=0 DO386I=1,NLEFT IF(ISUB(I).EQ.0)GOTO386 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XMAT((LP1-1)*NLEFT + J)=V(IJ) IF(K.EQ.MAXCP1)XMAT((LP1-1)*NLEFT + J)=PRED(I) IF(K.EQ.MAXCP2)XMAT((LP1-1)*NLEFT + J)=RES(I) IF(K.EQ.MAXCP3)XMAT((LP1-1)*NLEFT + J)=YPLOT(I) IF(K.EQ.MAXCP4)XMAT((LP1-1)*NLEFT + J)=XPLOT(I) IF(K.EQ.MAXCP5)XMAT((LP1-1)*NLEFT + J)=X2PLOT(I) IF(K.EQ.MAXCP6)XMAT((LP1-1)*NLEFT + J)=TAGPLO(I) 386 CONTINUE 385 CONTINUE GOTO4590 389 CONTINUE C CCCCC THE FOLLOWING SECTION WAS EXPANDED FROM DEFINING SEPTEMBER 1991 CCCCC X1 TO X5 TO X1 TO X15 SEPTEMBER 1991 CCCCC (BUT ALSO CONSIDERABLY SHORTENED SEPTEMBER 1991 CCCCC DUE TO USE OF SUBROUTINE). SEPTEMBER 1991 C K=ICOLV3(1) CALL DPCOVA(K,NLEFT,X1) IF(NUMVAR.LE.1)GOTO4590 C K=ICOLV3(2) CALL DPCOVA(K,NLEFT,X2) IF(NUMVAR.LE.2)GOTO4590 C K=ICOLV3(3) CALL DPCOVA(K,NLEFT,X3) IF(NUMVAR.LE.3)GOTO4590 C K=ICOLV3(4) CALL DPCOVA(K,NLEFT,X4) IF(NUMVAR.LE.4)GOTO4590 C K=ICOLV3(5) CALL DPCOVA(K,NLEFT,X5) IF(NUMVAR.LE.5)GOTO4590 C K=ICOLV3(6) CALL DPCOVA(K,NLEFT,X6) IF(NUMVAR.LE.6)GOTO4590 C K=ICOLV3(7) CALL DPCOVA(K,NLEFT,X7) IF(NUMVAR.LE.7)GOTO4590 C K=ICOLV3(8) CALL DPCOVA(K,NLEFT,X8) IF(NUMVAR.LE.8)GOTO4590 C K=ICOLV3(9) CALL DPCOVA(K,NLEFT,X9) IF(NUMVAR.LE.9)GOTO4590 C K=ICOLV3(10) CALL DPCOVA(K,NLEFT,X10) IF(NUMVAR.LE.10)GOTO4590 C K=ICOLV3(11) CALL DPCOVA(K,NLEFT,X11) IF(NUMVAR.LE.11)GOTO4590 C K=ICOLV3(12) CALL DPCOVA(K,NLEFT,X12) IF(NUMVAR.LE.12)GOTO4590 C K=ICOLV3(13) CALL DPCOVA(K,NLEFT,X13) IF(NUMVAR.LE.13)GOTO4590 C K=ICOLV3(14) CALL DPCOVA(K,NLEFT,X14) IF(NUMVAR.LE.14)GOTO4590 C K=ICOLV3(15) CALL DPCOVA(K,NLEFT,X15) IF(NUMVAR.LE.15)GOTO4590 C 4590 CONTINUE NS=J C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1991 JJF IF(ICASFI.EQ.'FIT')GOTO4599 IF(ICASFI.EQ.'RFIT')GOTO4599 IF(ICASFI.EQ.'MFIT')GOTO4595 IF(ICASFI.EQ.'0FIT')GOTO4593 DO4591I=1,NS X1(I)=XMAT(I) 4591 CONTINUE GOTO4599 4593 CONTINUE DO4594I=1,NS X1(I)=I 4594 CONTINUE GOTO4599 4595 CONTINUE CCCCC APRIL 2002: HANDLE THE FIT CONSTANT OFF CASE IJUNK=0 IF(IFITAC.EQ.'OFF')IJUNK=1 LMAX=NUMVAR IF(LMAX.GT.5)LMAX=5 DO4596L=1,LMAX DO4597I=1,NS IF(L.EQ.1)X1(I)=XMAT(I + (2-IJUNK-1)*NLEFT) IF(L.EQ.2)X2(I)=XMAT(I + (3-IJUNK-1)*NLEFT) IF(L.EQ.3)X3(I)=XMAT(I + (4-IJUNK-1)*NLEFT) IF(L.EQ.4)X4(I)=XMAT(I + (5-IJUNK-1)*NLEFT) IF(L.EQ.5)X5(I)=XMAT(I + (6-IJUNK-1)*NLEFT) 4597 CONTINUE 4596 CONTINUE IF(IBUGA3.EQ.'ON')WRITE(ICOUT,4598)X1(1),X2(1),X1(2),X2(2) 4598 FORMAT('X1(1),X2(1),X1(2),X2(2) = ',4E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 4599 CONTINUE C C ****************************************************** C ** STEP 13-- C ** PREPARE FOR ENTRANCE INTO DPFIT2/DPFIT3-- C ** SET THE ICON3 VECTOR C ** (WHICH INDICATES WHICH PARAMETERS ARE TO BE HELD C ** CONSTANT EQUAL TO 0 THROUGHOUT. C ** DEFINE CONSTRAINTS AND LIMITS. C ****************************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO4195I=1,NUMPAR ICON3(I)=0 4195 CONTINUE C IF(NUMCON.EQ.0)GOTO4890 DO4700I=1,NUMPAR DO4800J=1,NUMCON J2=J IF(IPARN3(I).EQ.IPARNC(J).AND.IPARN4(I).EQ.IPANC2(J))GOTO4810 4800 CONTINUE IPARO3(I)='NONE' GOTO4700 4810 CONTINUE IPARO3(I)=IPAROC(J2) PARLI3(I)=PARLIM(J2) 4700 CONTINUE 4890 CONTINUE C C ****************************************************** C ** STEP 14-- ** C ** CARRY OUT THE ACTUAL FIT ** C ** VIA CALLING ** C ** DPFIT2 (FOR GENERAL MODELS), OR ** C ** DPFIT3 (FOR POLYNOMIAL AND MULTILINEAR MODELS) ** C ****************************************************** C ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPFIT, AS ABOUT TO CALL DPFIT2/DPFIT3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6082)NUMCHA,NLEFT,MAXN,NS,NUMPV,NUMPAR,NUMVAR 6082 FORMAT('NUMCHA,NLEFT,MAXN,NS,NUMPV,NUMPAR,NUMVAR = ',7I8) CALL DPWRST('XXX','BUG ') DO6083I=1,NS WRITE(ICOUT,6084)I,Y(I),X1(I),X2(I),X3(I),XMAT(I), 1 XMAT(I+NLEFT),W(I) 6084 FORMAT('I,Y(I),X1(I),X2(I),X3(I),XMAT(I,1),XMAT(I,2),W(I) = ', 1I6,2X,7F10.5) CALL DPWRST('XXX','BUG ') 6083 CONTINUE WRITE(ICOUT,6085)(MODEL(I),I=1,MIN(120,NUMCHA)) 6085 FORMAT('MODEL(.)--',120A1) CALL DPWRST('XXX','BUG ') DO6086J=1,NUMPAR WRITE(ICOUT,6087)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J) 6087 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ', 1I8,2X,A4,A4,E15.7,A4) CALL DPWRST('XXX','BUG ') 6086 CONTINUE DO6088J=1,NUMVAR WRITE(ICOUT,6089)J,IVARN3(J),IVARN4(J),ICOLV3(J) 6089 FORMAT('I,IVARN3(I),IVARN4(I),ICOLV3(I) = ',I8,2X,A4,A4,2X,I8) CALL DPWRST('XXX','BUG ') 6088 CONTINUE WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV,NUMIND 6091 FORMAT('IBUGA3,IBUGCO,IBUGEV,NUMIND = ',A4,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C IF(ICASFI.EQ.'FIT')GOTO6520 GOTO6530 C 6520 CONTINUE CCCCC JUNE, 1990. ADD "DUMMY1,...,DUMMY5" ARGUMENTS CCCCC SEPTEMBER, 1991. ADD "X6 TO X15" ARGUMENTS CALL DPFIT2(Y,X1,X2,X3,X4,X5, 1X6,X7,X8,X9,X10,X11,X12,X13,X14,X15, 1NUMVAR,IVARN3,IVARN4,W,NS, 1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3, 1PARLI3,V,MAXITS,FITSD,FITPOW,CPUEPS, 1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, 1DUMMY1,DUMMY2,DUMMY3,DUMMY4,DUMMY5, 1ICAPSW,ICAPTY, CCCCC THE FOLLOWING LINE AUGMENTED WITH ISUBRO MARCH 1992 CCCCC1IBUGA3,IBUGCO,IBUGEV,IERROR) 1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8000 GOTO6590 C 6530 CONTINUE CCCCC JUNE 2002: CHECK TO SEE IF ALPHA PARAMETER DEFINED. C ALPHA=0.95 IHP='ALPH' IHP2='A ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')THEN ALPHA=0.95 ELSE ALPHA=VALUE(ILOCP) ENDIF IF(ALPHA.LE.0.0)THEN ALPHA=0.95 ELSEIF(ALPHA.GE.1.0.AND.ALPHA.LT.100.0)THEN ALPHA=ALPHA/100.0 ELSEIF(ALPHA.GE.100.0)THEN ALPHA=0.95 ENDIF C CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989 CCCCC CALL DPFIT3(Y,X1,X2,X3,X4,X5,NUMVAR,IVARN3,IVARN4,W,NS, CCCCC JUNE, 1990. ADD "DUMMY1,...,DUMMY5" ARGUMENTS CALL DPFIT3(Y,X1,X2,X3,X4,X5,XMAT,NLEFT,PARCOV,MAXPAR, 1NUMVAR,IVARN3,IVARN4,W,NS, 1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3, 1PARLI3,VSDPRD,V,FITSD,FITPOW, 1ICASFI, 1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, 1DUMMY1,DUMMY2,DUMMY3,DUMMY4,DUMMY5, CCCCC APRIL 2002. ADD FOLLOWING LINE 1IFITAC,ALPHA, CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989 CCCCC FOLLOWING LINE JUNE 2002 1RSQUAR,ADJRSQ,APRESS, 1ICAPSW,ICAPTY, CCCCC1IBUGA3,IBUGCO,IBUGEV,IERROR) 1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO8000 GOTO6590 C 6590 CONTINUE C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOLPR=MAXCP1 ICOLRE=MAXCP2 IREPU='ON' IRESU='ON' CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT, 1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,ILOCN,IBUGA3,IERROR) C CCCCC JUNE 2002. ADD FOLLOWING PARAMETERS FOR MULTI-LINEAR FIT IF(ICASFI.EQ.'MFIT')THEN IH='RSQU' IH2='ARE ' VALUE0=RSQUAR CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGA3,IERROR) C IH='ADJR' IH2='SQUA' VALUE0=ADJRSQ CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGA3,IERROR) C IH='PRES' IH2='SP ' VALUE0=APRESS CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1 IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1 IANS,IWIDTH,IBUGA3,IERROR) ENDIF C IF(ICASFI.EQ.'FIT')GOTO7900 IF(ICASFI.EQ.'RFIT')GOTO7900 C CCCCC THE FOLLOWING SECTION (DOWN TO 7640 CONTINUE) WAS REWRITTEN MAY 1989 IF(ICASFI.EQ.'MFIT')K1=NUMPAR L=0 DO7600J=1,K1 JM1=J-1 L=L+1 IH=' ' IH2=' ' CALL DPCOIH(JM1,IHOUT,NOUT,IVALID,IBUGA3,ISUBRO,IERROR) IHOUT1=IHOUT(1) IHOUT2=IHOUT(2) IHOUT3=IHOUT(3) IH(1:1)='A' IF(NOUT.GE.1)IH(2:2)=IHOUT1(1:1) IF(NOUT.GE.2)IH(3:3)=IHOUT2(1:1) IF(NOUT.GE.3)IH(4:4)=IHOUT3(1:1) C 7640 CONTINUE DO7650I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO7680 7650 CONTINUE IF(NUMNAM.LT.MAXNAM)GOTO7670 WRITE(ICOUT,7651) 7651 FORMAT('***** ERROR IN DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7652) 7652 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7653)MAXNAM 7653 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7654) 7654 FORMAT(' SUCH WAS NOT THE CASE HERE--THE MXIMUM ALLOWABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7656) 7656 FORMAT(' NUMBER OF NAMES WAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7657) 7657 FORMAT(' SUGGESTED ACTION--ENTER STAT TO DETERMINE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7659) 7659 FORMAT(' THE IMPORTANT (VERSUS UNIMPORTANT) VARIABLES AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7660) 7660 FORMAT(' PARAMETERS, AND THEN REUSE SOME OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7662) 7662 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,7663)(IANS(I),I=1,MIN(100,IWIDTH)) 7663 FORMAT(' ',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 7670 CONTINUE NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' VALUE(ILOC)=PARAM3(L) CCCCC IVALUE(ILOC)=VALUE(ILOC)+0.5 JUNE 10, 1987 VAL=VALUE(ILOC) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOC)=IVAL GOTO7600 C 7680 CONTINUE VALUE(I2)=PARAM3(L) CCCCC IVALUE(ILOC)=VALUE(ILOC)+0.5 JUNE 9, 1987 CCCCC IVALUE(I2)=VALUE(I2)+0.5 JUNE 10, 1987 VAL=VALUE(I2) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(I2)=IVAL GOTO7600 C 7600 CONTINUE 7900 CONTINUE C C ****************************************************** C ** STEP 16-- C ** READ BACK IN FROM MASS STORAGE C ** THE CONTENTS OF THE V(.) VECTOR. THE ABOVE C ** RETRIEVAL FROM MASS STORAGE IS UNNECESSARY AND IS C ** FOR THE SPECIAL CASE WHEN THE NUMBER OF PARAMETERS C ** IS 0 (A NO-FIT CASE WHEREBY WE ARE REALLY C ** INTERESTED IN GENERATING PREDICTED VALUES C ** AND RESIDUALS FOR A GIVEN FULLY-SPECIFIED MODEL). C ****************************************************** C 8000 CONTINUE C ISTEPN='16' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO8109 WRITE(ICOUT,8101) 8101 FORMAT('WE ARE IN DPFIT AND ARE ABOUT TO READ V BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8102)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) 8102 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) = ', 15I6,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8103) 8103 FORMAT('NOTE THAT IF NUMBER OF PARAMETERS = 0, THEN ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8104) 8104 FORMAT('NO DUMP TO/RETRIEVAL FROM MASS STORAGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8105) 8105 FORMAT('IS DONE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8106)NUMPAR 8106 FORMAT('NUMPAR = ',I8) CALL DPWRST('XXX','BUG ') 8109 CONTINUE C IOP='READ' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO8129 WRITE(ICOUT,8121) 8121 FORMAT('WE ARE IN DPFIT AND HAVE JUST READ ', 1'V(.) BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8122)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) 8122 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) = ', 15I6,3E15.7) CALL DPWRST('XXX','BUG ') 8129 CONTINUE C C ************************************************* C ** STEP 17-- ** C ** COPY THE FINAL ESTIMATES FROM THE FIT ** C ** BACK INTO THE PARAMETERS. ** C ** THESE FINAL ESTIMATES WILL THUS OVERWRITE ** C ** THE STARTING VALUES THAT WERE ** C ** ORIGINALLY ASSIGNED TO THE PARAMETERS. ** C ************************************************* C 6000 CONTINUE C ISTEPN='17' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PFIT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPAR.LE.0)GOTO6190 DO6100J=1,NUMPAR IH=IPARN3(J) IH2=IPARN4(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 VALUE(ILOCP)=PARAM3(J) CCCCC IVALUE(ILOCP)=VALUE(ILOCP)+0.5 JUNE 10, 1987 VAL=VALUE(ILOCP) IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5 IF(VAL.GT.CUTOFF)IVAL=CUTOFF IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF) IVALUE(ILOCP)=IVAL 6100 CONTINUE 6190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'PFIT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGCO,IBUGEV,IBUGQ 9013 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS,ICASFI 9015 FORMAT('NS,ICASFI = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMNAM 9016 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9017I=1,NUMNAM WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 9018 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9017 CONTINUE WRITE(ICOUT,9021)NUMIND,NUMPV,NUMVAR 9021 FORMAT('NUMIND,NUMPV,NUMVAR = ',3I8) CALL DPWRST('XXX','BUG ') IF(NUMPV.LE.0)GOTO9029 DO9022I=1,NUMPV WRITE(ICOUT,9023)I,IPARN(I),IPARN2(I) 9023 FORMAT('I,IPARN(I),IPARN2(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)IP 9031 FORMAT('IP = ',I8) CALL DPWRST('XXX','BUG ') IF(IP.LE.0)GOTO9039 DO9032I=1,IP WRITE(ICOUT,9033)I,IPARN3(I),IPARN4(I) 9033 FORMAT('I,IPARN3(I),IPARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9039 CONTINUE WRITE(ICOUT,9041)IV 9041 FORMAT('IV = ',I8) CALL DPWRST('XXX','BUG ') IF(IV.LE.0)GOTO9049 DO9042I=1,IV WRITE(ICOUT,9043)I,IVARN3(I),IVARN4(I) 9043 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9049 CONTINUE WRITE(ICOUT,9051)MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) 9051 FORMAT('MAXN2,NLEFT,NS,V(1),PRED(1),RES(1) = ',3I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)ICOLW,NWEIGH,IWEIGH 9053 FORMAT('ICOLW,NWEIGH,IWEIGH = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH)) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9063)IWIDMO 9063 FORMAT('IWIDMO = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDMO.GE.1)THEN WRITE(ICOUT,9064)(MODEL(I),I=1,MIN(IWIDMO,100)) 9064 FORMAT('(MODEL(I),I=1,IWIDMO) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPFIT2(Y,X1,X2,X3,X4,X5, 1X6,X7,X8,X9,X10,X11,X12,X13,X14,X15, 1NUMVAR,IVARN3,IVARN4,W,N, 1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3, 1PARLI3,V,MAXITS,FITSD,FITPOW,CPUEPS, 1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD, 1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF, 1DUM1,DUM2,Y2,WSQRT,G, 1ICAPSW,ICAPTY, CCCCC THE FOLLOWING LINE AUGMENTED WITH ISUBRO MARCH 1992 CCCCC1IBUGA3,IBUGCO,IBUGEV,IERROR) 1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR) CCCCC JUNE 1990. ADD DUM1 - G ARGUMENTS (DIMENSIONED IN DPFIT) CCCCC SEPT. 1991. ARGS X6 TO X15 ABOVE ARE NEW. C C LEVENBERG, MARQUARDT, MORRISON ALGORITHM IMPLEMENTED FOLLOWING C SUGGESTION OF GOLUB (SEE OSBORNE 'SOME ASPECTS OF NONLINEAR LEAST C SQUARES CALCULATION' EDITOR F.A. LOOTSMA ACADEMIC PRESS). MAIN C FEATURE OF THIS ROUTINE IS AN IMPROVED TEST FOR ACCEPTING C PREDICTED CORRECTION AND ADJUSTING LEVENBERG PARAMETER ALAMBA C C VARIABLES C C PARAM3(1) VECTOR OF INDEPENDENT VARIABLES C INPUT. CONTAINS ESTIMATE OF SOLUTION C OUTPUT. CONTAINS SOLUTION VECTOR OR LAST ATTEMPT C C V(1) STORAGE OF GRAD F BY COLUMNS C I.E., THE DERIVATIVES EVALUATED AT EACH OF THE N DATA POINTS C OF THE N RESIDUALS RES2(I) WITH RESPECT TO C THE FIRST PARAMETER FOLLOWED BY ALL THE DERIVATIVES C WITH RESPECT TO THE SECOND PARAMETER, ETC. C C RES2(1) STORAGE FOR F VECTOR OF TERMS IN SUM OF SQUARES C OUTPUT. VECTOR OF TERMS (USALLY RESIDUALS) IN SUM C OF SQUARES C C SUMSQ OUTPUT. CONTAINS SUM OF SQUARES C C N INPUT. NO. OF TERMS IN SUM OF SQUARES = NUMBER OF OBSERVATIONS. C C NP INPUT. NO. OF PARAMETERS INCLUDING ANY TO BE HELD CONSTANT C C TOL INPUT. TOLERANCE ON CALCULATION OF SUM OF SQUARES C C EXPND OUTPUT. FACTOR BY WHICH ALAMBA INCREASED IF TEST ON SUM OF C SQUARES FAILS, SUGGESTED VALUE 1.5 C C COMPR INPUT. FACTOR BY WHICH ALAMBA COMPREASED IF TEST ON SUM OF C SQUARES SUCCEEDS ON FIRST ATTEMPT, SUGGESTED VALUE 0.5 C C ITS INPUT. MAX NUMBER OF ITERATIONS C OUTPUT. ACTUAL NUMBER OF ITERATIONS C C IER INPUT.=-1+(100*NCONST) NO PRINTING C =0+(100*NCONST) PRINTING AFTER CONVERGENCE ONLY C =1+(100*NCONST) PRINT DIAGNOSTIC INFORMATION C =2+(100*NCONST) AS ABOVE PLUS GRADIENT CHECK C WHERE NCONST = NO. OF PARAMETERS TO BE HELD CONSTANT C OUTPUT.=1 SUCCESSUL TERMINATION C =2 MAX ITS EXCEEDED C =3 ALAMBA EXCEEDS 1.D6 C =4 ALL GRADIENTS ZERO FOR ONE OR MORE PARAMETERS C =5 NO. OF PARAMETERS LESS THAN ONE C C C(1) OUTPUT. CONTAINS APPROXIMATE C STANDARD ERRORS OF PARAMETER ESTIMATES C C G(1) OUTPUT. CONTAINS A VECTOR OF UNCORRELATED RESIDUALS C C WS(1) WORKING SPACE, MUST BE ALLOTTED AT LEAST C NPR*(NPR+5) + NCONST IN CALLING PROGRAM, C WHERE NCONST IS THE NUMBER OF PARAMETERS TO BE HELD C CONSTANT AND NPR = NP - NCONST. C C ICON3(1) INPUT. ICON3(1)=1 IF THE I-TH PARAMETER IS TO BE HELD C CONSTANT C =0 OTHERWISE C C C USER SUPPLIED SUBROUTINE F REQUIRED TO SET VALUES OF SUMSQ, C F,A DECLARATION MUST BE C SUBROUTINE F (X,N,PARAM3,NUMPAR,F,A,SUMSQ,IFL) C IF IFL=1 SETS ALL VALUES C IF IFL=2 SETS SUMSQ ONLY MUST NOT ALTER A,F C C N.B. THE VALUE OF ILF IS SUPPLIED BY DPFIT2 AND MUST NOT BE CHANGED C C EPS IS A MACHINE-DEPENDENT CONSTANT. C C NOTE--MAX NUMBER OF OBSERVATIONS N IS 1000 (NOT CHECKED FOR) C NOTE--MAX NUMBER OF PARAMETERS K IS 30 (NOT CHECKED FOR) C NOTE--DIMENSION OF G IS N (MAX IS 1000) C NOTE--DIMENSION OF C IS K (MAX IS 30) C NOTE--DIMENSION OF A IS N X K (BUT N X K MAX IS 10000) C C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 26, 1977. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --OCTOBER 1978. C UPDATED --FEBRUARY 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --MARCH 1981. C UPDATED --JULY 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --AUGUST 1987. WEIGHTED FIT C UPDATED --JANUARY 1988. FIX WEIGHTED FIT PRED & RES C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --JUNE 1990. MOVE SOME DIMENSIONS TO DPFIT C UPDATED --JULY 1990. FIX OVERFLOW C UPDATED --SEPT 1991. EXPAND IND. VAR. 5 TO 15 C UPDATED --MARCH 1992. FIX FORMAT MESSAGE C UPDATED --MARCH 1992. WRITE COEF SDCOEF TCDF TO FILE C UPDATED --MARCH 1992. ISUBRO ADDED TO INPUT ARG LIST C UPDATED --FEBRUARY 1994. ACTIVATE FITSD TEST C UPDATED --MAY 1994. FIX (= SPLIT) FORMAT 1122 C UPDATED --MAY 1994. CORRECT AN OVERFLOW DIVISION C UPDATED --MAY 1995. FIX SOME I/O C UPDATED --APRIL 1996. IPRINT SWITCH C UPDATED --JULY 1997. PRINT SUMMARY INFORMATION IF C MAXIMUM ITERATIONS REACHED C UPDATED --FEBRUARY 1998. CALL DPFLSH (FOR GUI) C UPDATED --APRIL 2001. PRINT OUT VAR-COV MATRIX C UPDATED --NOVEMBER 2002. CAPTURE HTML, LATEX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*1 IBASLC C CHARACTER*4 IVARN3 CHARACTER*4 IVARN4 CHARACTER*4 IPARN3 CHARACTER*4 IPARN4 CHARACTER*4 IANGLU CHARACTER*4 IPARO3 CHARACTER*4 ITYPEH CHARACTER*4 IW2HOL CHARACTER*4 IW22HO CHARACTER*4 IREP CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CCCCC THE FOLLOWING LINE WAS ADDED MARCH 1992 CHARACTER*4 ISUBRO CHARACTER*4 IERROR CHARACTER*4 IFOUND C CHARACTER*4 IPARN5 CHARACTER*4 IPARN6 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 MODEL CHARACTER*4 IOP C CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED MARCH 1992 CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*4 ISUBN0 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C C--------------------------------------------------------------------- C DOUBLE PRECISION SUM,SSS,SSINIT,SSR,WW,SSN,SUMSQ DOUBLE PRECISION S DOUBLE PRECISION DS1,DS2,DTOL DOUBLE PRECISION DRAT1,DRAT2 DOUBLE PRECISION DEPS,DTOL2,DRAT C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C CCCCC THE FOLLOWING INCLUDE STATEMENT WAS ADDED MARCH 1992 INCLUDE 'DPCOF2.INC' C DIMENSION Y(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION X3(*) DIMENSION X4(*) DIMENSION X5(*) CCCCC THE FOLLOWING 10 LINES WERE ADDED SEPTEMBER 1991 DIMENSION X6(*) DIMENSION X7(*) DIMENSION X8(*) DIMENSION X9(*) DIMENSION X10(*) DIMENSION X11(*) DIMENSION X12(*) DIMENSION X13(*) DIMENSION X14(*) DIMENSION X15(*) C DIMENSION PRED2(*) DIMENSION RES2(*) C DIMENSION W(*) C DIMENSION V(*) C DIMENSION MODEL(*) C DIMENSION IVARN3(*) DIMENSION IVARN4(*) DIMENSION PARAM3(*) DIMENSION IPARN3(*) DIMENSION IPARN4(*) DIMENSION ICON3(*) DIMENSION IPARO3(*) DIMENSION PARLI3(*) C DIMENSION ITYPEH(*) DIMENSION IW2HOL(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IPARN5(30) DIMENSION IPARN6(30) DIMENSION PARAM5(30) C CCCCC JUNE, 1990. DIMENSIONS MOVED TO DPFIT CCCCC DIMENSION DUM1(MAXOBV) CCCCC DIMENSION DUM2(MAXOBV) CCCCC DIMENSION Y2(MAXOBV) CCCCC DIMENSION WSQRT(MAXOBV) C CCCCC DIMENSION G(MAXOBV) DIMENSION DUM1(*) DIMENSION DUM2(*) DIMENSION Y2(*) DIMENSION WSQRT(*) C DIMENSION G(*) CCCCC END CHANGE DIMENSION WS(1100) CCCCC DIMENSION Y0(MAXOBV) C DIMENSION DUM(30) DIMENSION C(10) DIMENSION PARAM7(30) DIMENSION PARAM9(30) DIMENSION VARCOV(30,30) DIMENSION CORR(30,30) C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPFI' ISUBN2='T2 ' C IERROR='NO' C CCCCC THE FOLLOWING LINE WAS ADDED TO FIX OVERFLOW JULY 1990 CPUMA2=CPUMAX/1000.0 C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFIT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NUMVAR,NUMPAR,NUMCHA 52 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV 53 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X1(I),W(I) 56 FORMAT('I,Y(I),X1(I),W(I) = ',I5,3F20.10) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO61J=1,NUMVAR WRITE(ICOUT,62)J,IVARN3(J),IVARN4(J) 62 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE DO66J=1,NUMPAR WRITE(ICOUT,67)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J) 67 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ', 1 I8,2X,A4,A4,E15.7,I8) CALL DPWRST('XXX','BUG ') 66 CONTINUE CCCCC MAY 1995. FIX SOME I/O CCCCC WRITE(ICOUT,71)(MODEL(J),J=1,NUMCHA) NTEMP=NUMCHA IF(NTEMP.GT.100)NTEMP=100 WRITE(ICOUT,71)(MODEL(J),J=1,NTEMP) 71 FORMAT('FUNCTIONAL EXPRESSION--',100A1) CALL DPWRST('XXX','BUG ') ENDIF C CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992 C ************************************************** C ** STEP 0.5-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C ISTEPN='0.5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='FIT2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='FIT2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='FIT2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 1-- ** C ** DETERMINE THE PARAMETER NAMES IN THE MODEL ** C ** AND THE NUMBER NUMPAR OF PARAMETERS. ** C ************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IPASS=2 C IF(NUMPAR.GT.0)THEN DO7100I=1,NUMPAR IPARN5(I)=IPARN3(I) IPARN6(I)=IPARN4(I) PARAM5(I)=PARAM3(I) 7100 CONTINUE ENDIF C IF(NUMVAR.GT.0)THEN DO7300I=1,NUMVAR IPARN5(NUMPAR+I)=IVARN3(I) IPARN6(NUMPAR+I)=IVARN4(I) 7300 CONTINUE ENDIF C NUMPV=NUMPAR+NUMVAR C C ****************************************************** C ** STEP 2-- ** C ** DEFINE VARIOUS CONSTANTS. ** C ** DEFINE EPS = MACHINE EPSILON. ** C ** DEFINE TOL = CUTOFF TOLERANCE FOR SUCCESSIVE ** C ** ESTIMATES. ** C ** DEFINE MAXITS = MAX NUMBER OF ITERATIONS. ** C ** DEFINE EXPND = EXPANSION FACTOR ** C ** DEFINE COMPR = COMPRESSION FACTOR ** C ** DEFINE NCONST = NUMBER OF PARAMETERS HELD ** C ** CONSTANT. ** C ** DEFINE NP = NUMBER OF NON-CONSTNAT PARAMETERS. ** C ** DEFINE DF = DEGREES OF FREEDOM. ** C ** DEFINE SOME WORKING STORAGE START POINTS IN WS. ** C ****************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IREP='NO' REPSD=0.0 REPDF=0.0 IREPDF=REPDF+0.5 RESSD=0.0 RESDF=0.0 ALFCDF=(-999.99) IF(NUMPAR.GT.0)THEN EPS = 1.E-8 DEPS=EPS TOL=0.00001 DTOL=TOL ALAMBA=0.01 EXPND=1.5 COMPR=0.5 NPST=NUMPAR NCONST=0 DO501I=1,NUMPAR IF(ICON3(I).EQ.1)NCONST=NCONST+1 501 CONTINUE NP=NUMPAR-NCONST IF(NP.LE.0) THEN WRITE(ICOUT,117) NP 117 FORMAT(10X,'NUMBER OF PARAMETERS TO BE VARIED = ',I8, * ' (LESS THAN ONE)') CALL DPWRST('XXX','BUG ') IER = 5 IERROR='YES' GOTO9000 ENDIF DF=N-NP RESDF=DF IRESDF=DF+0.5 IC=0 IER=2 IDA=NP*NP IDU=IDA+NP ID =IDU+NP IDX=ID +NP IY =IDX+NP ENDIF C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 5001 FORMAT('') 5002 FORMAT('LEAST SQUARES NON-LINEAR FIT') 5004 FORMAT('FULLY SPECIFIED MODEL') 5005 FORMAT('

') WRITE(ICOUT,5001) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(NUMPAR.GE.1)THEN WRITE(ICOUT,5002) CALL DPWRST('XXX','WRIT') ELSEIF(NUMPAR.LE.0)THEN WRITE(ICOUT,5004) CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,5005) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START TABLE C 5011 FORMAT('') WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 8024 FORMAT(5X,'No Replication Case: & ',2X,A1,A1) 8025 FORMAT(5X,'Replication Case: & ',2X,A1,A1) 8026 FORMAT(5X,'Replication Standard Deviation: & ',G15.7,2X,A1,A1) 8027 FORMAT(5X,'Replication Degrees of Freedom: & ',I8,2X,A1,A1) 8028 FORMAT(5X,'Number of Distinct Subsets: & ',I8,2X,A1,A1) IF(IREP.EQ.'NO')THEN WRITE(ICOUT,8024)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8025)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)REPSD,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IREPDF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)NUMSET,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,8049)IBASLC CALL DPWRST('XXX','WRIT') C C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE C 8091 FORMAT(A1,'end{center}') 8093 FORMAT(A1,'end{table}') WRITE(ICOUT,8091)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8093)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN IF(IREP.EQ.'NO')THEN ELSE ENDIF ELSE IF(IREP.EQ.'NO')THEN WRITE(ICOUT,4811) 4811 FORMAT(' NO REPLICATION CASE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,4911) 4911 FORMAT(' REPLICATION CASE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4922)REPSD 4922 FORMAT(' REPLICATION STANDARD DEVIATION = ',D20.10) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4923)IREPDF 4923 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4924)NUMSET 4924 FORMAT(' NUMBER OF DISTINCT SUBSETS = ',2X,I9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF ENDIF ENDIF C C ******************************************************* C ** STEP 2.6-- ** C ** TREAT THE SPECIAL CASE WHERE NO PARAMETERS ** C ** EXIST IN THE MODEL-- ** C ** THAT IS, WE ARE REALLY INTERESTED ** C ** IN GENERATING PREDICTED VALUES AND RESIDUALS ** C ** FROM A FULLY-SPECIFIED MODEL. ** C ** (THIS IS USEFUL FOR MANUALLY ARRIVING AT ** C ** REASONABLE STARTING VALUES FOR A MORE ** C ** COMPLICATED FIT; ** C ** AND ALSO FOR TESTING THE GOODNESS OF AN ** C ** ALREADY-DERIVED ** C ** FIT FOR ONE DOMAIN OVER A SECOND DOMAIN.) ** C ******************************************************* C ISTEPN='2.6' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMPAR.LE.0)THEN DO3000I=1,N IF(NUMVAR.LE.0)GOTO3090 PARAM5(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO3090 PARAM5(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO3090 PARAM5(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO3090 PARAM5(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO3090 PARAM5(NUMPAR+5)=X5(I) IF(NUMVAR.LE.5)GOTO3090 PARAM5(NUMPAR+6)=X6(I) IF(NUMVAR.LE.6)GOTO3090 PARAM5(NUMPAR+7)=X7(I) IF(NUMVAR.LE.7)GOTO3090 PARAM5(NUMPAR+8)=X8(I) IF(NUMVAR.LE.8)GOTO3090 PARAM5(NUMPAR+9)=X9(I) IF(NUMVAR.LE.9)GOTO3090 PARAM5(NUMPAR+10)=X10(I) IF(NUMVAR.LE.10)GOTO3090 PARAM5(NUMPAR+11)=X11(I) IF(NUMVAR.LE.11)GOTO3090 PARAM5(NUMPAR+12)=X12(I) IF(NUMVAR.LE.12)GOTO3090 PARAM5(NUMPAR+13)=X13(I) IF(NUMVAR.LE.13)GOTO3090 PARAM5(NUMPAR+14)=X14(I) IF(NUMVAR.LE.14)GOTO3090 PARAM5(NUMPAR+15)=X15(I) C 3090 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1 IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2(I), 1 IBUGCO,IBUGEV,IERROR) PRED2(I)=PRED2(I)*WSQRT(I) IF(IERROR.EQ.'YES')GOTO9000 3000 CONTINUE C DO3100I=1,N RES2(I)=Y2(I)-PRED2(I) 3100 CONTINUE C SUM=0.0 DO3200I=1,N SUM=SUM+RES2(I)**2 3200 CONTINUE RESSS=SUM C IRESDF=N RESDF=N RESMS=0.0 IF(RESDF.GT.0.0)RESMS=RESSS/RESDF RESSD=0.0 IF(RESMS.GT.0.0)RESSD=SQRT(RESMS) GOTO5000 ENDIF C C ****************************************************** C ** STEP 3-- ** C ** USING THE GIVEN STARTING VALUES FOR THE ** C ** PARAMETERS, ** C ** COMPUTE PREDICTED VALUES AND EXACT DERIVATIVES; ** C ** THEN CHECK THE CORRECTNESS OF THE DERIVATIVES ** C ** FORMULAE ** C ** BY APPROXIMATING THE DERIVATIVES WITH DIFFERENCES* C ** AND COMPARING THE EXACT DERIVATIVES WITH THE ** C ** DIFFERENCES. ** C ****************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,425) 425 FORMAT(' GRADIENTS FROM DIFFERENCES') CALL DPWRST('XXX','BUG ') ENDIF C DO1201J=1,NUMPAR PARAM5(J)=PARAM3(J) 1201 CONTINUE DO1200I=1,N IF(NUMVAR.LE.0)GOTO1205 PARAM5(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO1205 PARAM5(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO1205 PARAM5(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO1205 PARAM5(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO1205 PARAM5(NUMPAR+5)=X5(I) IF(NUMVAR.LE.5)GOTO1205 PARAM5(NUMPAR+6)=X6(I) IF(NUMVAR.LE.6)GOTO1205 PARAM5(NUMPAR+7)=X7(I) IF(NUMVAR.LE.7)GOTO1205 PARAM5(NUMPAR+8)=X8(I) IF(NUMVAR.LE.8)GOTO1205 PARAM5(NUMPAR+9)=X9(I) IF(NUMVAR.LE.9)GOTO1205 PARAM5(NUMPAR+10)=X10(I) IF(NUMVAR.LE.10)GOTO1205 PARAM5(NUMPAR+11)=X11(I) IF(NUMVAR.LE.11)GOTO1205 PARAM5(NUMPAR+12)=X12(I) IF(NUMVAR.LE.12)GOTO1205 PARAM5(NUMPAR+13)=X13(I) IF(NUMVAR.LE.13)GOTO1205 PARAM5(NUMPAR+14)=X14(I) IF(NUMVAR.LE.14)GOTO1205 PARAM5(NUMPAR+15)=X15(I) C 1205 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1 IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,DUM1(I), 1 IBUGCO,IBUGEV,IERROR) DUM1(I)=DUM1(I)*WSQRT(I) IF(IERROR.EQ.'YES')GOTO9000 1200 CONTINUE C SUM=0.0 DO1140I=1,N G(I)=Y2(I)-DUM1(I) SUM=SUM+G(I)**2 1140 CONTINUE SSN=SUM C DO1210J=1,NUMPAR PARAM7(J)=PARAM3(J) 1210 CONTINUE C DO1220J=1,NP IF(ICON3(J).EQ.1)GOTO1220 IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,119)J 119 FORMAT('PARAMETER NUMBER ',I8) CALL DPWRST('XXX','BUG ') ENDIF PARAM7(J)=PARAM3(J) IF(PARAM7(J).EQ.0.0)H=0.001 IF(PARAM7(J).NE.0.0)H=PARAM3(J)*0.01 PARAM7(J)=PARAM3(J)+H DO1230I=1,N IF(NUMVAR.LE.0)GOTO1235 PARAM7(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO1235 PARAM7(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO1235 PARAM7(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO1235 PARAM7(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO1235 PARAM7(NUMPAR+5)=X5(I) IF(NUMVAR.LE.5)GOTO1235 PARAM7(NUMPAR+6)=X6(I) IF(NUMVAR.LE.6)GOTO1235 PARAM7(NUMPAR+7)=X7(I) IF(NUMVAR.LE.7)GOTO1235 PARAM7(NUMPAR+8)=X8(I) IF(NUMVAR.LE.8)GOTO1235 PARAM7(NUMPAR+9)=X9(I) IF(NUMVAR.LE.9)GOTO1235 PARAM7(NUMPAR+10)=X10(I) IF(NUMVAR.LE.10)GOTO1235 PARAM7(NUMPAR+11)=X11(I) IF(NUMVAR.LE.11)GOTO1235 PARAM7(NUMPAR+12)=X12(I) IF(NUMVAR.LE.12)GOTO1235 PARAM7(NUMPAR+13)=X13(I) IF(NUMVAR.LE.13)GOTO1235 PARAM7(NUMPAR+14)=X14(I) IF(NUMVAR.LE.14)GOTO1235 PARAM7(NUMPAR+15)=X15(I) C 1235 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM7,IPARN5,IPARN6,NUMPV, 1 IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2(I), 1 IBUGCO,IBUGEV,IERROR) PRED2(I)=PRED2(I)*WSQRT(I) IF(IERROR.EQ.'YES')GOTO9000 K=I+(J-1)*N V(K)=(PRED2(I)-DUM1(I))/H V(K)=-V(K) 1230 CONTINUE C SUM=0.0 DO1250I=1,N RES2(I)=Y2(I)-PRED2(I) SUM=SUM+RES2(I)**2 1250 CONTINUE S=SUM C DO 1260 I=1,N RES2(I)=(RES2(I)-G(I))/H 1260 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN WRITE(ICOUT,120)(RES2(I),I=1,N) 120 FORMAT(8G16.7) CALL DPWRST('XXX','BUG ') ENDIF PARAM7(J)=PARAM3(J) 1220 CONTINUE C C C C ************************************************ C ** STEP 4-- ** C ** START THE ITERATIVE CYCLE. ** C ** ITS = THE ITERATION NUMBER. ** C ** NITS = THE NUMBER OF ITERATIONS. ** C ************************************************ C 50 CONTINUE ISTEPN='4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ITS=0 40 CONTINUE ITS=ITS+1 NITS=0 C C ***************************************************** C ** STEP 5-- ** C ** FILL THE VECTOR V(.) WITH EVALUATED DERIVATIVES** C ** BASED ON THE STARTING VALUES FOR THE PARAMETERS.* C ** ALL THE DERIVATIVES WITH RESPECT TO PARAMETER 1** C ** GO IN THE FIRST N LOCATIONS. ** C ** ALL THE DERIVATIVES WITH RESPECT TO PARAMETER 2** C ** GO IN THE NEXT N LOCATIONS. ** C ** ALL THE DERIVATIVES WITH RESPECT TO PARAMETER 3** C ** GO IN THE FOLLOWING N LOCATIONS, ETC. ** C ** ALSO COMPUTE A SUM OF SQUARED DEVIATIONS ** C ** BASED ON THE CURRENT VALUES FOR THE PARAMETERS ** C ** (THIS WILL BE USED FOR COMPARATIVE PURPOSES ** C ** WITHIN THE ITERATION). ** C ***************************************************** C ISTEPN='5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1301J=1,NUMPAR PARAM5(J)=PARAM3(J) 1301 CONTINUE DO1300I=1,N IF(NUMVAR.LE.0)GOTO1305 PARAM5(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO1305 PARAM5(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO1305 PARAM5(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO1305 PARAM5(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO1305 PARAM5(NUMPAR+5)=X5(I) IF(NUMVAR.LE.5)GOTO1305 PARAM5(NUMPAR+6)=X6(I) IF(NUMVAR.LE.6)GOTO1305 PARAM5(NUMPAR+7)=X7(I) IF(NUMVAR.LE.7)GOTO1305 PARAM5(NUMPAR+8)=X8(I) IF(NUMVAR.LE.8)GOTO1305 PARAM5(NUMPAR+9)=X9(I) IF(NUMVAR.LE.9)GOTO1305 PARAM5(NUMPAR+10)=X10(I) IF(NUMVAR.LE.10)GOTO1305 PARAM5(NUMPAR+11)=X11(I) IF(NUMVAR.LE.11)GOTO1305 PARAM5(NUMPAR+12)=X12(I) IF(NUMVAR.LE.12)GOTO1305 PARAM5(NUMPAR+13)=X13(I) IF(NUMVAR.LE.13)GOTO1305 PARAM5(NUMPAR+14)=X14(I) IF(NUMVAR.LE.14)GOTO1305 PARAM5(NUMPAR+15)=X15(I) C 1305 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV, 1 IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2(I), 1 IBUGCO,IBUGEV,IERROR) PRED2(I)=PRED2(I)*WSQRT(I) IF(IERROR.EQ.'YES')GOTO9000 1300 CONTINUE C DO1310J=1,NUMPAR PARAM7(J)=PARAM3(J) 1310 CONTINUE DO1320J=1,NUMPAR IF(PARAM3(J).EQ.0.0)H=0.001 IF(PARAM3(J).NE.0.0)H=PARAM3(J)*0.01 PARAM7(J)=PARAM3(J)+H DO1330I=1,N IF(NUMVAR.LE.0)GOTO1335 PARAM7(NUMPAR+1)=X1(I) IF(NUMVAR.LE.1)GOTO1335 PARAM7(NUMPAR+2)=X2(I) IF(NUMVAR.LE.2)GOTO1335 PARAM7(NUMPAR+3)=X3(I) IF(NUMVAR.LE.3)GOTO1335 PARAM7(NUMPAR+4)=X4(I) IF(NUMVAR.LE.4)GOTO1335 PARAM7(NUMPAR+5)=X5(I) IF(NUMVAR.LE.5)GOTO1335 PARAM7(NUMPAR+6)=X6(I) IF(NUMVAR.LE.6)GOTO1335 PARAM7(NUMPAR+7)=X7(I) IF(NUMVAR.LE.7)GOTO1335 PARAM7(NUMPAR+8)=X8(I) IF(NUMVAR.LE.8)GOTO1335 PARAM7(NUMPAR+9)=X9(I) IF(NUMVAR.LE.9)GOTO1335 PARAM7(NUMPAR+10)=X10(I) IF(NUMVAR.LE.10)GOTO1335 PARAM7(NUMPAR+11)=X11(I) IF(NUMVAR.LE.11)GOTO1335 PARAM7(NUMPAR+12)=X12(I) IF(NUMVAR.LE.12)GOTO1335 PARAM7(NUMPAR+13)=X13(I) IF(NUMVAR.LE.13)GOTO1335 PARAM7(NUMPAR+14)=X14(I) IF(NUMVAR.LE.14)GOTO1335 PARAM7(NUMPAR+15)=X15(I) C 1335 CONTINUE CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM7,IPARN5,IPARN6,NUMPV, 1 IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,Y1, 1 IBUGCO,IBUGEV,IERROR) Y1=Y1*WSQRT(I) IF(IERROR.EQ.'YES')GOTO9000 K=I+(J-1)*N V(K)=(Y1-PRED2(I))/H V(K)=-V(K) IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN WRITE(ICOUT,1333)J,I,PARAM3(J),PARAM7(J),H, 1 Y1,PRED2(I),V(K) 1333 FORMAT(I2,I4,3F10.5,3D14.7) CALL DPWRST('XXX','BUG ') ENDIF 1330 CONTINUE PARAM7(J)=PARAM3(J) 1320 CONTINUE C SUM=0.0 DO1340I=1,N RES2(I)=Y2(I)-PRED2(I) SUM=SUM+RES2(I)**2 1340 CONTINUE SSINIT=SUM SSINMS=0.0 IF(DF.GT.0.0)SSINMS=SSINIT/DF SDINIT=0.0 IF(SSINMS.GT.0.0)SDINIT=SQRT(SSINMS) IF(NCONST.EQ.0) GO TO 38 J = 0 DO 58 I=1,NPST K = ICON3(I) J = J + K IF(J.EQ.0.OR.K.EQ.1) GO TO 58 II = (I-1)*N KK = (I-J-1)*N DO 54 K=1,N V(KK+K) = V(II+K) 54 CONTINUE 58 CONTINUE 38 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2401) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2402) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2403) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2404)ITS CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2405)(PARAM3(J),J=1,NUMPAR) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2406)SDINIT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2411) CALL DPWRST('XXX','BUG ') IMAX=N JMAX=NUMPAR WRITE(ICOUT,2412)IMAX,JMAX CALL DPWRST('XXX','BUG ') 2401 FORMAT('---------- AFTER STEP 5 OF DPFIT2 ----------') 2402 FORMAT('(THAT IS, AFTER FILLING V(.) WITH DERIVATIVES') 2403 FORMAT('BASED ON CURRENT VALUES OF PARAMETERS)') 2404 FORMAT('ITERATION = ',I5) 2405 FORMAT('CURRENT PARAMETERS = ',8F13.6) 2406 FORMAT('CURRENT RESIDUAL STANDARD DEVIATION = ',F20.10) 2411 FORMAT('THE "MATRIX" V(.) AND THE VECTOR RES--') 2412 FORMAT(I5,' ROWS BY ',I5,' COLUMNS (PLUS AN EXTRA ', 1 'COLUMN FOR RES)') DO2420I=1,IMAX L=0 DO2430J=1,JMAX L=L+1 K=(J-1)*IMAX+I DUM(L)=V(K) 2430 CONTINUE LMAX=L WRITE(ICOUT,2431)(DUM(L),L=1,LMAX),RES2(I) 2431 FORMAT(10F13.7) CALL DPWRST('XXX','BUG ') 2420 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2441) CALL DPWRST('XXX','BUG ') IMAX=NUMPAR JMAX=NUMPAR+4 WRITE(ICOUT,2442)IMAX,JMAX 2441 FORMAT('THE MATRIX WS--') CALL DPWRST('XXX','BUG ') 2442 FORMAT(I5,' ROWS BY ',I5,' COLUMNS') DO2450I=1,IMAX L=0 DO2460J=1,JMAX L=L+1 K=(J-1)*IMAX+I DUM(L)=WS(K) 2460 CONTINUE LMAX=L WRITE(ICOUT,2461)(DUM(L),L=1,LMAX) 2461 FORMAT(10F13.7) CALL DPWRST('XXX','BUG ') 2450 CONTINUE ENDIF C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN 5111 FORMAT('') WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C C STEP 2: START TABLE AND DEFINE A CAPTION C 5211 FORMAT('') 5299 FORMAT('

') WRITE(ICOUT,5291) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5293) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5299) CALL DPWRST('XXX','WRIT') ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE C 8291 FORMAT(A1,'end{center}') 8293 FORMAT(A1,'end{table}') WRITE(ICOUT,8249)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8291)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8293)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN ENDIF ENDIF C C ********************************************* C ** STEP 13-- ** C ** PRINT OUT GOODNESS OF FIT INFORMATION ** C ********************************************* C 5000 CONTINUE C IF(IREP.EQ.'YES')THEN IFITDF=IRESDF-IREPDF FITDF=IFITDF FITSS=RESSS-REPSS FITMS=100000.0 IF(FITDF.GT.0.0)FITMS=FITSS/FITDF FSTAT=100000.0 IF(REPMS.GT.0.0)FSTAT=FITMS/REPMS CALL FCDF(FSTAT,IFITDF,IREPDF,CDF) CDF2=100.0*CDF ALFCDF=CDF ENDIF C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C C STEP 2: START TABLE AND DEFINE A CAPTION C 5311 FORMAT('') 5399 FORMAT('
')
        WRITE(ICOUT,5391)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5393)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5399)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C  STEP 1: START TABLE ENVIRONMENT
C
 8303 FORMAT(A1,'begin{table}')
 8309 FORMAT(A1,'begin{center}')
 8313 FORMAT(A1,'end{center}')
C
        WRITE(ICOUT,8303)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8309)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8320 FORMAT(5X,A1,'begin{tabular} {lr}')
 8321 FORMAT(5X,'Residual Standard Deviation: & ',G15.7,2X,A1,A1)
 8322 FORMAT(5X,'Residual Degrees of Freedom: & ',I8,2X,A1,A1)
 8323 FORMAT(5X,'Replication Standard Deviation: & ',G15.7,2X,A1,A1)
 8324 FORMAT(5X,'Replication Degrees of Freedom: & ',I8,2X,A1,A1)
 8325 FORMAT(5X,'The lack of fit F test cannot be performed & ',
     1       2X,A1,A1)
 8326 FORMAT(5X,'because we have zero degrees of freedom in the & ',
     1       2X,A1,A1)
 8327 FORMAT(5X,'numerator of the F ratio.  This happens when the &',
     1       2X,A1,A1)
 8328 FORMAT(5X,'number of parameters fitted is identical to the & ',
     1       2X,A1,A1)
 8329 FORMAT(5X,'number of distinct subsets. & ',
     1       2X,A1,A1)
 8330 FORMAT(5X,'Lack of Fit F Ratio: & ',G12.4,2X,A1,A1)
 8331 FORMAT(5X,'The ',F8.4,A1,'% point of the F distribution with & ',
     1       2X,A1,A1)
 8332 FORMAT(5X,I6,' and ',I6,' degrees of freedom & ',2X,A1,A1)
 8349 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8320)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8321)RESSD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8322)IRESDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(IREP.EQ.'YES')THEN
          WRITE(ICOUT,8323)REPSD,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8324)IREPDF,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
          IF(IFITDF.LT.1)THEN
            WRITE(ICOUT,8325)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8326)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8327)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8328)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8329)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
          ELSE
            WRITE(ICOUT,8330)FSTAT,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8331)CDF2,IBASLC,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8332)IFITDF,IREPDF,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
          ENDIF
        ENDIF
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8391 FORMAT(A1,'end{center}')
 8393 FORMAT(A1,'end{table}')
 8399 FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8349)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8391)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8393)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8399)IBASLC
        CALL DPWRST('XXX','WRIT')
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
      ELSE
        IF(NUMPAR.GE.1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,4225)RESSD
 4225   FORMAT('      RESIDUAL    STANDARD DEVIATION = ',G20.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4226)IRESDF
 4226   FORMAT('      RESIDUAL    DEGREES OF FREEDOM = ',2X,I9)
        CALL DPWRST('XXX','WRIT')
C
        IF(IREP.EQ.'YES')THEN
          IFITDF=IRESDF-IREPDF
          WRITE(ICOUT,4231)REPSD
 4231     FORMAT('      REPLICATION STANDARD DEVIATION = ',F20.10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4233)IREPDF
 4233     FORMAT('      REPLICATION DEGREES OF FREEDOM = ',2X,I9)
          CALL DPWRST('XXX','WRIT')
          IF(IFITDF.LT.1)THEN
            WRITE(ICOUT,4236)
 4236       FORMAT('      LACK OF FIT F TEST CANNOT BE DONE BECAUSE')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4237)
 4237       FORMAT('      HAVE ONLY 0 DEGREES OF FREEDOM IN ',
     1             'NUMERATOR OF F RATIO.')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4238)
 4238       FORMAT('      THIS HAPPENS WHEN NUMBER OF PARAMETERS ',
     1             'FITTED')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4239)
 4239       FORMAT('      IS IDENTICAL TO NUMBER OF DISTINCT ',
     1             'SUBSETS.')
            CALL DPWRST('XXX','WRIT')
          ENDIF
C
          WRITE(ICOUT,4240)FSTAT,CDF2
          CALL DPWRST('XXX','WRIT')
 4240     FORMAT('      LACK OF FIT F RATIO = ',F12.4,' = THE ',
     1           F8.4,'% POINT OF THE')
          WRITE(ICOUT,4245)IFITDF,IREPDF
 4245     FORMAT('      F DISTRIBUTION WITH ',I6,' AND ',I6,
     1           ' DEGREES OF FREEDOM')
          CALL DPWRST('XXX','WRIT')
        ENDIF
      ENDIF
      ENDIF
CCCCC JULY 1997.  MAX ITERATIONS FIX
      IF(ITS.GE.MAXITS) GO TO 910
      IF(NUMPAR.LE.0)GOTO9000
C
C               ********************************************
C               **  PRINT OUT CORRELATIONS OF REGRESSION  **
C               **  COEFFICIENT ESTIMATES                 **
C               **  (IF CALLED FOR)                       **
C               ********************************************
C
      IF(NP.GE.N) GO TO 910
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN
         WRITE(ICOUT,108)
108      FORMAT(20X,'CORRELATIONS OF PARAMETER ESTIMATES')
         CALL DPWRST('XXX','BUG ')
      ENDIF
      L=0
      KJ = 0
      DO 95 I=1,NP
89      CONTINUE
        II = I + KJ
        K = ICON3(II)
        KJ = KJ + K
        IF(K.EQ.1) GO TO 89
        IF(C(I).NE.0.0) GO TO 83
        C(I) = EPS
        GO TO 95
83      CONTINUE
        DO 94 J=1,I
          L=L+1
          WS(IY+J)=WS(L)/(C(I)*C(J))
          VARCOV(I,J)=WS(L)
          VARCOV(J,I)=WS(L)
          CORR(I,J)=WS(L)/(C(I)*C(J))
          CORR(J,I)=WS(L)/(C(I)*C(J))
  94    CONTINUE
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'FIT2')THEN
          WRITE(ICOUT,209) II,(WS(IY+J),J=1,I)
  209     FORMAT(I6,(10F12.5))
          CALL DPWRST('XXX','BUG ')
        ENDIF
95    CONTINUE
      IF(X0.GT.0.0)X0=SQRT(X0)
      IF(X0.LE.0.0)X0=0.0
      CALL DPWRST('XXX','BUG ')
      DO1501J=1,NUMPAR
        PARAM5(J)=PARAM3(J)
 1501 CONTINUE
      DO1500I=1,N
CCCCC   CALL F(X(I),PARAM3,NUMPAR,PRED2(I))
        IF(NUMVAR.LE.0)GOTO1505
        PARAM5(NUMPAR+1)=X1(I)
        IF(NUMVAR.LE.1)GOTO1505
        PARAM5(NUMPAR+2)=X2(I)
        IF(NUMVAR.LE.2)GOTO1505
        PARAM5(NUMPAR+3)=X3(I)
        IF(NUMVAR.LE.3)GOTO1505
        PARAM5(NUMPAR+4)=X4(I)
        IF(NUMVAR.LE.4)GOTO1505
        PARAM5(NUMPAR+5)=X5(I)
CCCCC   THE FOLLOWING 20 LINES WERE ADDED SEPTEMBER 1991
        IF(NUMVAR.LE.5)GOTO1505
        PARAM5(NUMPAR+6)=X6(I)
        IF(NUMVAR.LE.6)GOTO1505
        PARAM5(NUMPAR+7)=X7(I)
        IF(NUMVAR.LE.7)GOTO1505
        PARAM5(NUMPAR+8)=X8(I)
        IF(NUMVAR.LE.8)GOTO1505
        PARAM5(NUMPAR+9)=X9(I)
        IF(NUMVAR.LE.9)GOTO1505
        PARAM5(NUMPAR+10)=X10(I)
        IF(NUMVAR.LE.10)GOTO1505
        PARAM5(NUMPAR+11)=X11(I)
        IF(NUMVAR.LE.11)GOTO1505
        PARAM5(NUMPAR+12)=X12(I)
        IF(NUMVAR.LE.12)GOTO1505
        PARAM5(NUMPAR+13)=X13(I)
        IF(NUMVAR.LE.13)GOTO1505
        PARAM5(NUMPAR+14)=X14(I)
        IF(NUMVAR.LE.14)GOTO1505
        PARAM5(NUMPAR+15)=X15(I)
C
 1505   CONTINUE
        CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM5,IPARN5,IPARN6,NUMPV,
     1  IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,PRED2(I),
     1  IBUGCO,IBUGEV,IERROR)
        PRED2(I)=PRED2(I)*WSQRT(I)
        IF(IERROR.EQ.'YES')GOTO9000
 1500 CONTINUE
      DO1510J=1,NUMPAR
        PARAM7(J)=PARAM3(J)
 1510 CONTINUE
      DO1520J=1,NUMPAR
        IF(PARAM3(J).EQ.0.0)H=0.001
        IF(PARAM3(J).NE.0.0)H=PARAM3(J)*0.01
        PARAM7(J)=PARAM3(J)+H
        DO1530I=1,N
CCCCC     CALL F(X(I),PARAM7,NUMPAR,Y1)
          IF(NUMVAR.LE.0)GOTO1535
          PARAM7(NUMPAR+1)=X1(I)
          IF(NUMVAR.LE.1)GOTO1535
          PARAM7(NUMPAR+2)=X2(I)
          IF(NUMVAR.LE.2)GOTO1535
          PARAM7(NUMPAR+3)=X3(I)
          IF(NUMVAR.LE.3)GOTO1535
          PARAM7(NUMPAR+4)=X4(I)
          IF(NUMVAR.LE.4)GOTO1535
          PARAM7(NUMPAR+5)=X5(I)
CCCCC     THE FOLLOWING 20 LINES WERE ADDED SEPTEMBER 1991
          IF(NUMVAR.LE.5)GOTO1535
          PARAM7(NUMPAR+6)=X6(I)
          IF(NUMVAR.LE.6)GOTO1535
          PARAM7(NUMPAR+7)=X7(I)
          IF(NUMVAR.LE.7)GOTO1535
          PARAM7(NUMPAR+8)=X8(I)
          IF(NUMVAR.LE.8)GOTO1535
          PARAM7(NUMPAR+9)=X9(I)
          IF(NUMVAR.LE.9)GOTO1535
          PARAM7(NUMPAR+10)=X10(I)
          IF(NUMVAR.LE.10)GOTO1535
          PARAM7(NUMPAR+11)=X11(I)
          IF(NUMVAR.LE.11)GOTO1535
          PARAM7(NUMPAR+12)=X12(I)
          IF(NUMVAR.LE.12)GOTO1535
          PARAM7(NUMPAR+13)=X13(I)
          IF(NUMVAR.LE.13)GOTO1535
          PARAM7(NUMPAR+14)=X14(I)
          IF(NUMVAR.LE.14)GOTO1535
          PARAM7(NUMPAR+15)=X15(I)
C
 1535     CONTINUE
          CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM7,IPARN5,IPARN6,NUMPV,
     1    IANGLU,ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,Y1,
     1    IBUGCO,IBUGEV,IERROR)
          Y1=Y1*WSQRT(I)
          IF(IERROR.EQ.'YES')GOTO9000
          K=I+(J-1)*N
          V(K)=(Y1-PRED2(I))/H
          V(K)=-V(K)
 1530   CONTINUE
        PARAM7(J)=PARAM3(J)
 1520 CONTINUE
C
      SUM=0.0
      DO1540I=1,N
        RES2(I)=Y2(I)-PRED2(I)
        SUM=SUM+RES2(I)**2
 1540 CONTINUE
      SUMSQ=SUM
C
C**** FORM UNWEIGHTED (RAW) PREDICTED VALUES AND RESIDUALS
C
      DO1550I=1,N
        IF(WSQRT(I).LE.0.0)GOTO1550
        RES2(I)=Y2(I)-PRED2(I)
        RES2(I)=RES2(I)/WSQRT(I)
        PRED2(I)=Y(I)-RES2(I)
 1550 CONTINUE
C
C**** RELOCATE VAR-COV. MATRIX AND STANDARD ERRORS IF NCONST.NE.0.
C
CCCCC THE FOLLOWING LINE WAS CHANGED MARCH 1992
CC900 IF(NCONST.EQ.0) GOTO9000
  900 IF(NCONST.EQ.0) GOTO919
      L = NP*(NP+1)/2
      L2 = NP
      I = NPST
904   K = ICON3(I)
      IF(K.EQ.1) GO TO 903
      C(I) = C(L2)
      L2 = L2 - 1
      J = I
901   K = I*(I-1)/2 + J
      WS(K) = WS(L)
      L = L - 1
902   J = J - 1
      IF(J.LE.0) GO TO 903
      K = ICON3(J)
CCCCC IF(K) 902,901
      IF(K.LT.0)GOTO902
      IF(K.EQ.0)GOTO901
903   I = I - 1
      IF(I.GT.0) GO TO 904
910   NP = NPST
CCCCC THE FOLLOWING LINE WAS ADDED MARCH 1992
  919 CONTINUE
C
CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992
C               **************************************************
C               **  STEP 81--                                   **
C               **  WRITE INFO OUT TO FILES--                   **
C               **     1) DPST1F.DAT--COEF SDCOEF TCDF          **
C               **     2) DPST2F.DAT--PRED AND SDPRED           **
C               **     3) DPST3F.DAT--PARAMETER VAR-COV MATRIX  **
C               **************************************************
C
 8600 CONTINUE
C
      ISTEPN='86'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO8610I=1,NUMPAR
        WRITE(IOUNI1,8611)PARAM3(I),C(I),IPARN3(I),IPARN4(I)
 8611   FORMAT(E15.7,E15.7,10X,A4,A4)
 8610 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO8619
      WRITE(ICOUT,8612)
 8612 FORMAT(6X,'COEF AND SD(COEF) WRITTEN TO FILE DPST1F.DAT')
      CALL DPWRST('XXX','BUG ')
 8619 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO8629
      DO8623I=1,NP
      WRITE(IOUNI2,8625) (CORR(I,J),J=1,NP)
      WRITE(IOUNI3,8625) (VARCOV(I,J),J=1,NP)
 8623 CONTINUE
 8625 FORMAT(30(E15.7,1X))
      WRITE(ICOUT,8628)
 8628 FORMAT(6X,'PARAMETER CORRELATION MATRIX WRITTEN TO ',
     1       'FILE DPST2F.DAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8627)
 8627 FORMAT(6X,'PARAMETER VARIANCE-COVARIANCE MATRIX WRITTEN TO ',
     1       'FILE DPST3F.DAT')
      CALL DPWRST('XXX','BUG ')
 8629 CONTINUE
C
CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992
C               **************************************
C               **  STEP 82--                       **
C               **  CLOSE       THE STORAGE FILES.  **
C               **************************************
C
 8700 CONTINUE
C
      ISTEPN='82'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IENDF1='OFF'
      IREWI1='ON'
      CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
     1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR)
      IF(IERRF1.EQ.'YES')GOTO9000
C
      IENDF2='OFF'
      IREWI2='ON'
      CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
     1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR)
      IF(IERRF2.EQ.'YES')GOTO9000
C
      IENDF3='OFF'
      IREWI3='ON'
      CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3,
     1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR)
      IF(IERRF2.EQ.'YES')GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPFIT2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IERROR
 9012 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N,NUMVAR,NUMPAR,NUMCHA
 9013 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NUMPAR
      WRITE(ICOUT,9016)I,IPARN3(I),IPARN4(I),PARAM3(I)
 9016 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I) = ',I8,2X,A4,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9017)IBUGA3,IBUGCO,IBUGEV
 9017 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      DO9020I=1,N
      WRITE(ICOUT,9021)I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I)
 9021 FORMAT('I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) = ',
     1I8,6E13.7)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
      DO9025I=1,N
      WRITE(ICOUT,9026)I,Y(I),Y2(I),W(I),WSQRT(I)
 9026 FORMAT('I,Y(I),Y2(I),W(I),WSQRT(I) = ',
     1I8,4E13.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPFIT3(Y,X1,X2,X3,X4,X5,X,NLEFT,PARCOV,MAXPAR,
     1NUMVAR,IVARN3,IVARN4,W,N,
     1MODEL,NUMCHA,PARAM3,IPARN3,IPARN4,NUMPAR,ICON3,IANGLU,IPARO3,
     1PARLI3,V,SCR,FITSD,FITPOW,
     1ICASFI,
     1ITYPEH,IW2HOL,IW22HO,W2HOLD,NWHOLD,
     1IREP,REPSD,REPDF,RESSD,RESDF,PRED2,RES2,ALFCDF,
     1DUM1,DUM2,G,Z,VSDPRE,
CCCCC APRIL 2002.  ADD FOLLOWING LINE
     1IFITAC,ALPHA,
CCCCC ABOVE LINE ADDED JUNE 1990 (DIMENSIONING DONE IN DPFIT)
CCCCC FOLLOWING LINE JUNE 2002
     1RSQUAR,ADJRSQ,APRESS,
     1ICAPSW,ICAPTY,
CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989
CCCCC1IBUGA3,IBUGCO,IBUGEV,IERROR)
     1IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR)
C
C     NOTE--MAX NUMBER OF OBSERVATIONS N IS 1000 (NOT CHECKED FOR)
C     NOTE--MAX NUMBER OF PARAMETERS K IS 30 (NOT CHECKED FOR)
C     NOTE--DIMENSION OF G IS N (MAX IS 1000)
C     NOTE--DIMENSION OF C IS K (MAX IS 30)
C     NOTE--DIMENSION OF A IS N X K (BUT N X K MAX IS 10000)
C
C     MORE DIMENSION INFO (FROM LSQRT)--
C           B     VECTOR OF COEFFICIENTS (M+1 BY 1).
C           Z     VECTOR OF RESIDUALS (N BY 1).
C           T     VECTOR OF STANDARD DEVIATIONS OF COEFFICIENTS (M+1 BY 1).
C           V     VECTOR OF STANDARD DEVIATIONS OF PREDICTED VALUES
C                    (N BY 1).
C           S     VECTOR OF SQUARED FOURIER COEFFICIENTS (M+3 BY 1).  THE
C                    FIRST M ELEMENTS OF THIS ARRAY ARE SUMS OF SQUARES
C                    WHICH CAN BE USED IN AN ANALYSIS OF VARIANCE.  THE
C                    LAST TWO ELEMENTS OF S ARE NOT COMPUTED IN THIS SUB-
C                    ROUTINE BUT ARE RESERVED FOR QUANTITIES TO BE COMPUTED
C                    IN THE CALLING PROGRAM.
C           E     RESIDUAL SUM OF SQUARES.
C           D     AVERAGE NUMBER OF DIGITS IN AGREEMENT BETWEEN INITIAL
C                    SOLUTION AND THE FIRST ITERATION (IN SUBROUTINE SLVE).
C           SD    RESIDUAL STANDARD DEVIATION.
C           NDF   NO. OF DEGREES OF FREEDOM.
C           SCR   A SCRATCH VECTOR USED FOR INTERNAL CALCULATIONS
C           ID    ID = 0  EVERYTHING IS OK.
C                 ID = 1  AUGMENTED MATRIX IS SINGULAR.
C                 ID = 2  ITERATION PROCEDURE FAILED TO CONVERGE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C     UPDATED         --FEBRUARY  1988.   (MAKE LINE NUMBERS ORDERLY)
C     UPDATED         --MARCH     1988.  (INCLUDE B0 IN MULTILINEAR FIT)
C     UPDATED         --MARCH     1988.  LOFCDF
C     UPDATED         --MARCH     1988.  ERROR ARG. TO CALL TO LSQRT + BRANC
C     UPDATED         --SEPTEMBER 1988.  ERROR BRANCH AFTER CALL TO DPREPS IF EM
C     UPDATED         --SEPTEMBER 1988.  CONSTANT FIT
C     UPDATED         --NOVEMBER  1988.  PROPER TITLE FOR MULTILINEAR
C     UPDATED         --MAY       1989.  MATRIX X ADDED TO INPUT ARG LIST
C     UPDATED         --MAY       1989.  ISUBRO ADDED TO INPUT ARG LIST
C     UPDATED         --NOVEMBER  1989.  S(.) DOUB. PREC. TO SING. PREC.
C     UPDATED         --NOVEMBER  1989.  OMITTED UNNEEDED DOUB. PREC.
C     UPDATED         --JUNE      1990.  SOME DIMENSIONS MOVED TO DPFIT
C     UPDATED         --MARCH     1992.  WRITE COEF SDCOEF TCDF TO FILE
C     UPDATED         --JULY      1993.  WRITE DIAGONAL OF HAT MATRIX,
C                                        PARAMETER COVARIANCE MATRIX TO
C                                        FILE.
C     UPDATED         --SEPTEMBER 1993.  ADD ISUBRO ARG TO LSQRT
C     UPDATED         --JANUARY   1994. WRITE SDPRED & LIMITS TO FILE
C     UPDATED         --FEBRUARY  1994. MERGE JIM AND ALAN UPDATES
C                                       ADD DPST4F.DAT
C     UPDATED         --FEBRUARY  1994. DPWRST: 'BUG ' => 'WRIT'
C     UPDATED         --JUNE      1994. BUG IN DPST4F.DAT OUTPUT FOR
C                                       POLYNOMIAL MODELS.
C     UPDATED         --MAY       1995. FIX SOME I/O
C     UPDATED         --SEPTEMBER 1995. ADD BLANK LINE FOR OUTPUT
C     UPDATED         --JANUARY   1996. FIX BOMB WITH CONSTANT FIT
C     UPDATED         --APRIL     1996. IPRINT SWITCH
C     UPDATED         --APRIL     2002. SUPPORT FOR NO CONSTANT TERM
C     UPDATED         --APRIL     2002. PRINT ERROR MESSAGE IF
C                                       SINGULARITY DETECTED
C     UPDATED         --JUNE      2002. AUGMENT DPST2F.DAT OUTPUT
C     UPDATED         --JUNE      2002. AUGMENT DPST3F.DAT OUTPUT
C     UPDATED         --JUNE      2002. WRITE ANOVA TABLE TO
C                                       DPST5F.DAT
C     UPDATED         --JULY      2003. MODIFY DIMENSIONING OF X TO
C                                       ALLOW MORE FLEXIBILITY BETWEEN
C                                       NUMBER OF ROWS AND COLUMNS.
C     UPDATED         --OCTOBER   2003. SUPPORT HTML, LATEX OUTPUT
C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IVARN3
      CHARACTER*4 IVARN4
      CHARACTER*4 IPARN3
      CHARACTER*4 IPARN4
      CHARACTER*4 IANGLU
      CHARACTER*4 IPARO3
      CHARACTER*4 ICASFI
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW2HOL
      CHARACTER*4 IW22HO
      CHARACTER*4 IREP
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IPARN5
      CHARACTER*4 IPARN6
C
      CHARACTER*4 IHOLD3
      CHARACTER*4 IHOLD4
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 MODEL
CCCCC CHARACTER*4 IOP
      CHARACTER*4 IFITAC
C
      CHARACTER*4 ICAPSW
      CHARACTER*4 ICAPTY
      CHARACTER*1 IBASLC
C
CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED MARCH 1992
      CHARACTER*80 IFILE1
      CHARACTER*12 ISTAT1
      CHARACTER*12 IFORM1
      CHARACTER*12 IACCE1
      CHARACTER*12 IPROT1
      CHARACTER*12 ICURS1
      CHARACTER*4 IERRF1
      CHARACTER*4 IENDF1
      CHARACTER*4 IREWI1
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*80 IFILE2
      CHARACTER*12 ISTAT2
      CHARACTER*12 IFORM2
      CHARACTER*12 IACCE2
      CHARACTER*12 IPROT2
      CHARACTER*12 ICURS2
      CHARACTER*4 IERRF2
      CHARACTER*4 IENDF2
      CHARACTER*4 IREWI2
CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1993
      CHARACTER*80 IFILE3
      CHARACTER*12 ISTAT3
      CHARACTER*12 IFORM3
      CHARACTER*12 IACCE3
      CHARACTER*12 IPROT3
      CHARACTER*12 ICURS3
      CHARACTER*4 IERRF3
      CHARACTER*4 IENDF3
      CHARACTER*4 IREWI3
CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994
      CHARACTER*80 IFILE4
      CHARACTER*12 ISTAT4
      CHARACTER*12 IFORM4
      CHARACTER*12 IACCE4
      CHARACTER*12 IPROT4
      CHARACTER*12 ICURS4
      CHARACTER*4 IERRF4
      CHARACTER*4 IENDF4
      CHARACTER*4 IREWI4
CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002
      CHARACTER*80 IFILE5
      CHARACTER*12 ISTAT5
      CHARACTER*12 IFORM5
      CHARACTER*12 IACCE5
      CHARACTER*12 IPROT5
      CHARACTER*12 ICURS5
      CHARACTER*4 IERRF5
      CHARACTER*4 IENDF5
      CHARACTER*4 IREWI5
C
C---------------------------------------------------------------------
C
CCCCC THE FOLLOWING LINE WAS COMMENTED OUT    NOVEMBER 1989
CCCCC BECAUSE THE VARIABLES WERE NEVER USED
CCCCC DOUBLE PRECISION SUM,SSS,SSINIT,SSR,WW,SSN,SUMSQ
C
CCCCC THE FOLLOWING LINE WAS COMMENTED OUT NOVEMBER 1989
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC DOUBLE PRECISION S
C
CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT    NOVEMBER 1989
CCCCC BECAUSE THE VARIABLES WERE NEVER USED
CCCCC DOUBLE PRECISION DS1,DS2
CCCCC DOUBLE PRECISION DRAT1,DRAT2
CCCCC DOUBLE PRECISION DRAT
C
      DOUBLE PRECISION DSUM1
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
CCCCC THE FOLLOWING INCLUDE STATEMENT WAS ADDED MARCH 1992
      INCLUDE 'DPCOF2.INC'
      DIMENSION Y(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION X3(*)
      DIMENSION X4(*)
      DIMENSION X5(*)
C
      DIMENSION PRED2(*)
      DIMENSION RES2(*)
C
      DIMENSION W(*)
C
      DIMENSION V(*)
C
      DIMENSION MODEL(*)
C
      DIMENSION IVARN3(*)
      DIMENSION IVARN4(*)
      DIMENSION PARAM3(*)
      DIMENSION IPARN3(*)
      DIMENSION IPARN4(*)
      DIMENSION ICON3(*)
      DIMENSION IPARO3(*)
      DIMENSION PARLI3(*)
C
      DIMENSION ITYPEH(*)
      DIMENSION IW2HOL(*)
      DIMENSION IW22HO(*)
      DIMENSION W2HOLD(*)
C
      DIMENSION IPARN5(80)
      DIMENSION IPARN6(80)
      DIMENSION PARAM5(80)
C
CCCCC JUNE, 1990.  SOME DIMENSIONS MOVED TO DPFIT (FOR STORAGE CONSIDERATIONS)
CCCCC DIMENSION DUM1(MAXOBV)
CCCCC DIMENSION DUM2(MAXOBV)
C
CCCCC DIMENSION G(MAXOBV)
C
      DIMENSION DUM1(*)
      DIMENSION DUM2(*)
C
      DIMENSION G(*)
CCCCC DIMENSION WS(1100)
CCCCC DIMENSION Y0(MAXOBV)
C
CCCCC DIMENSION DUM(80)
CCCCC DIMENSION C(10)  MARCH 1988
      DIMENSION C(80)
CCCCC DIMENSION PARAM7(80)
CCCCC DIMENSION PARAM9(80)
CCCCC JULY 1993.  ADD FOLLOWING LINE
CCCCC DIMENSION PARCOVM(MAXCMF+1,MAXCMF+1)
      DIMENSION PARCOV(MAXPAR+1,MAXPAR+1)
C
CCCCC DIMENSION X(NR,M)
CCCCC DIMENSION X(MAXOBV,MAXCMF)
      DIMENSION X(NLEFT,*)
CCCCC DIMENSION B(M)
      DIMENSION B(100)
CCCCC DIMENSION Z(N)
CCCCC DIMENSION Z(1000)  MARCH 1988
CCCCC DIMENSION Z(MAXOBV)
      DIMENSION Z(*)
CCCCC DIMENSION T(M+1)
      DIMENSION T(101)
CCCCC DIMENSION V(N)
CCCCC DIMENSION VSDPRE(1000)  MARCH 1988
CCCCC DIMENSION VSDPRE(MAXOBV)
      DIMENSION VSDPRE(*)
CCCCC END OF JUNE 1990 CHANGES
CCCCC DIMENSION S(M+2)
      DIMENSION S(102)
CCCCC DIMENSION SCR(10000)
CCCCC DIMENSION SCR(MAXOBW)
      DIMENSION SCR(*)
C ****  THE ABOVE DIMENSION IS PROBABLY WRONG FOR LARGE DATA SETS    JULY 1987
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPFI'
      ISUBN2='T3  '
C
      IERROR='NO'
C
CCCCC IF(IBUGA3.EQ.'OFF')GOTO90  MAY 1989
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'FIT3')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPFIT3--')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,52)N,NUMVAR,NUMPAR,NUMCHA
   52 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV
   53 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,54)ICASFI
   54 FORMAT('ICASFI = ',A4)
      CALL DPWRST('XXX','WRIT')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I,1),X(I,2),X(I,3),X(I,5),W(I)
   56 FORMAT('I,Y(I),X(I,1),X(I,2),X(I,3),X(I,4),W(I) = ',I5,6E13.6)
      CALL DPWRST('XXX','WRIT')
   55 CONTINUE
      DO61J=1,NUMVAR
      WRITE(ICOUT,62)J,IVARN3(J),IVARN4(J)
   62 FORMAT('I,IVARN3(I),IVARN4(I) = ',I8,2X,A4,A4)
      CALL DPWRST('XXX','WRIT')
   61 CONTINUE
      DO66J=1,NUMPAR
      WRITE(ICOUT,67)J,IPARN3(J),IPARN4(J),PARAM3(J),ICON3(J)
   67 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I),ICON3(I) = ',
     1I8,2X,A4,A4,E15.7,I8)
      CALL DPWRST('XXX','WRIT')
   66 CONTINUE
      WRITE(ICOUT,71)(MODEL(J),J=1,MAX(100,NUMCHA))
   71 FORMAT('FUNCTIONAL EXPRESSION--',100A1)
      CALL DPWRST('XXX','WRIT')
   90 CONTINUE
C
CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992
C               **************************************************
C               **  STEP 0.5--                                  **
C               **   OPEN THE STORAGE FILES                     **
C               **************************************************
C
      ISTEPN='0.5'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IOUNI1=IST1NU
      IFILE1=IST1NA
      ISTAT1=IST1ST
      IFORM1=IST1FO
      IACCE1=IST1AC
      IPROT1=IST1PR
      ICURS1=IST1CS
      ISUBN0='FIT3'
      IERRF1='NO'
C
      IREWI1='ON'
      CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
     1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR)
      IF(IERRF1.EQ.'YES')GOTO9000
C
      IOUNI2=IST2NU
      IFILE2=IST2NA
      ISTAT2=IST2ST
      IFORM2=IST2FO
      IACCE2=IST2AC
      IPROT2=IST2PR
      ICURS2=IST2CS
      ISUBN0='FIT3'
      IERRF2='NO'
C
      IREWI2='ON'
      CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
     1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR)
      IF(IERRF2.EQ.'YES')GOTO9000
C
CCCCC JULY 1993.  OPEN FILE 3 FOR THE VARIANCE-COVARIANCE MATRIX OF
CCCCC THE PARAMETERS.
      IOUNI3=IST3NU
      IFILE3=IST3NA
      ISTAT3=IST3ST
      IFORM3=IST3FO
      IACCE3=IST3AC
      IPROT3=IST3PR
      ICURS3=IST3CS
      ISUBN0='FIT3'
      IERRF3='NO'
C
      IREWI3='ON'
      CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3,
     1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR)
      IF(IERRF3.EQ.'YES')GOTO9000
C
CCCCC FEBRUARY 1994.  OPEN FILE 4 FOR THE VARIANCE-COVARIANCE MATRIX OF
CCCCC THE PARAMETERS.
      IOUNI4=IST4NU
      IFILE4=IST4NA
      ISTAT4=IST4ST
      IFORM4=IST4FO
      IACCE4=IST4AC
      IPROT4=IST4PR
      ICURS4=IST4CS
      ISUBN0='FIT3'
      IERRF4='NO'
C
      IREWI4='ON'
      CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
     1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR)
      IF(IERRF4.EQ.'YES')GOTO9000
C
CCCCC JUNE 2002.  OPEN FILE 5 FOR THE ANOVA TABLE.
      IOUNI5=IST5NU
      IFILE5=IST5NA
      ISTAT5=IST5ST
      IFORM5=IST5FO
      IACCE5=IST5AC
      IPROT5=IST5PR
      ICURS5=IST5CS
      ISUBN0='FIT3'
      IERRF5='NO'
C
      IREWI5='ON'
      CALL DPOPFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5,
     1IREWI5,ISUBN0,IERRF5,IBUGA3,ISUBRO,IERROR)
      IF(IERRF5.EQ.'YES')GOTO9000
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  DETERMINE THE PARAMETER NAMES IN THE MODEL  **
C               **  AND THE NUMBER NUMPAR OF PARAMETERS.        **
C               **************************************************
C
      ISTEPN='11'
CCCCC IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)   MAY 1989
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMPAR.LE.0)GOTO1119
      DO1110I=1,NUMPAR
      IPARN5(I)=IPARN3(I)
      IPARN6(I)=IPARN4(I)
      PARAM5(I)=PARAM3(I)
 1110 CONTINUE
 1119 CONTINUE
C
      IF(NUMVAR.LE.0)GOTO1129
      DO1120I=1,NUMVAR
      IPARN5(NUMPAR+I)=IVARN3(I)
      IPARN6(NUMPAR+I)=IVARN4(I)
 1120 CONTINUE
 1129 CONTINUE
C
      NUMPV=NUMPAR+NUMVAR
C
C               ***************************************************************
C               **  STEP 12--                                                **
C               **  DEFINE VARIOUS CONSTANTS.                                **
C               **  DEFINE NCONST = NUMBER OF PARAMETERS HELD CONSTANT.      **
C               **  DEFINE NP = NUMBER OF NON-CONSTNAT PARAMETERS.           **
C               **  DEFINE DF = DEGREES OF FREEDOM.                          **
C               **  DEFINE SOME WORKING STORAGE START POINTS IN WS.          **
C               ***************************************************************
C
      ISTEPN='12'
CCCCC IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)   MAY 1989
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IREP='NO'
      REPSD=0.0
      REPDF=0.0
      IREPDF=REPDF+0.5
      RESSD=0.0
      RESDF=0.0
      ALFCDF=(-999.99)
C
      IF(NUMPAR.LE.0)GOTO1239
      NPST=NUMPAR
      NCONST=0
C
      DO1210I=1,NUMPAR
      IF(ICON3(I).EQ.1)NCONST=NCONST+1
 1210 CONTINUE
      NP=NUMPAR-NCONST
C
      IF(NP.GT.0) GO TO 1229
      WRITE(ICOUT,1221) NP
 1221 FORMAT(10X,'NO. OF PARAMETERS TO BE VARIED = ',I8,
     * '(LESS THAN ONE)')
      CALL DPWRST('XXX','WRIT')
      IER = 5
      IERROR='YES'
      GOTO9000
 1229 CONTINUE
C
      DF=N-NP
      RESDF=DF
      IRESDF=DF+0.5
C
      IC=0
      IER=2
      IDA=NP*NP
      IDU=IDA+NP
      ID =IDU+NP
      IDX=ID +NP
      IY =IDX+NP
 1239 CONTINUE
C
C     THE FOLLOWING SECITON WAS MODIFIED TO ADD MULTILINEAR   11/88
C     ADD HTML, LATEX OUTPUT  10/2003
C
      IDEGRE=NUMPAR-1
C
      IF(IPRINT.EQ.'ON')THEN
C
 5001 FORMAT('
') 5002 FORMAT('LEAST SQUARES POLYNOMOIAL FIT') 5003 FORMAT('LEAST SQUARES MULTILINEAR FIT') 5004 FORMAT('FULLY SPECIFIED MODEL') 5005 FORMAT('

') IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN WRITE(ICOUT,5001) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(NUMPAR.GE.1.AND.ICASFI.NE.'MFIT')THEN WRITE(ICOUT,5002) CALL DPWRST('XXX','WRIT') ELSEIF(NUMPAR.GE.1.AND.ICASFI.EQ.'MFIT')THEN WRITE(ICOUT,5003) CALL DPWRST('XXX','WRIT') ELSEIF(NUMPAR.LE.0)THEN WRITE(ICOUT,5004) CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,5005) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START TABLE C 5011 FORMAT('') WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN 8024 FORMAT(5X,'No Replication Case: & ',2X,A1,A1) 8025 FORMAT(5X,'Replication Case: & ',2X,A1,A1) 8026 FORMAT(5X,'Replication Standard Deviation: & ',G15.7,2X,A1,A1) 8027 FORMAT(5X,'Replication Degrees of Freedom: & ',I8,2X,A1,A1) 8028 FORMAT(5X,'Number of Distinct Subsets: & ',I8,2X,A1,A1) IF(IREP.EQ.'NO')THEN WRITE(ICOUT,8024)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8025)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)REPSD,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IREPDF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)NUMSET,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,8049)IBASLC CALL DPWRST('XXX','WRIT') C C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE C 8091 FORMAT(A1,'end{center}') 8093 FORMAT(A1,'end{table}') WRITE(ICOUT,8091)IBASLC CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,8093)IBASLC CCCCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN IF(IREP.EQ.'NO')THEN CONTINUE ELSE CONTINUE ENDIF ELSE IF(IREP.EQ.'NO')THEN WRITE(ICOUT,2111) 2111 FORMAT(' NO REPLICATION CASE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,2121) 2121 FORMAT(' REPLICATION CASE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2122)REPSD 2122 FORMAT(' REPLICATION STANDARD DEVIATION = ',G20.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2123)IREPDF 2123 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2124)NUMSET 2124 FORMAT(' NUMBER OF DISTINCT SUBSETS = ',2X,I9) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF ENDIF ENDIF C C ******************************************************* C ** STEP 31-- ** C ** CARRY OUT THE LEAST SQUARES FIT ** C ** NOTE--IT = 1 IMPLIES POLYNOMIAL ** C ** IT = 2 IMPLIES MULTILINEAR ** C ** NOTE--M = DEGREE (IF POLYNOMIAL) ** C ** M = NUMBER OF PARAMETERS (IF MULTILINEAR) ** C ******************************************************* C ISTEPN='31' CCCCC IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASFI.EQ.'MFIT')GOTO3120 GOTO3110 C 3110 CONTINUE IT=1 M=NUMPAR-1 CCCCC NR=MAXOBV NR=NLEFT CCCCC THE FOLLOWING 3 LINES WERE COMMENTED OUT MAY 1989 CCCCC DO3111I=1,N CCCCC X(I,1)=X1(I) C3111 CONTINUE GOTO3170 C 3120 CONTINUE IT=2 M=NUMPAR CCCCC NR=MAXOBV NR=NLEFT CCCCC THE FOLLOWING 12 LINES WERE COMMENTED OUT MAY 1989 CCCCC DO3121J=1,NUMPAR CCCCC DO3122I=1,N CCCCC IF(J.EQ.1)X(I,1)=1.0 CCCCC IF(J.EQ.2)X(I,2)=X1(I) CCCCC IF(J.EQ.3)X(I,3)=X2(I) CCCCC IF(J.EQ.4)X(I,4)=X3(I) CCCCC IF(J.EQ.5)X(I,5)=X4(I) CCCCC IF(J.EQ.6)X(I,6)=X5(I) CCCCC IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3123)I,J,X(I,J) C3123 FORMAT('I,J,X(I,J) = ',I8,I8,E15.7) CCCCC IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','WRIT') C3122 CONTINUE C3121 CONTINUE GOTO3170 C 3170 CONTINUE C C THE FOLLOWING CHUNK OF CODE WAS ADDED SEPTEMBER 1988 C TO HANDLE THE CONSTANT FIT (Y = CONSTANT + ERROR) CASE. C IF(IT.EQ.1.AND.M.EQ.0)GOTO3171 GOTO3179 3171 CONTINUE SUMWY=0.0 SUMW=0.0 DO3172I=1,N SUMWY=SUMWY+W(I)*Y(I) SUMW=SUMW+W(I) 3172 CONTINUE AMEAN=SUMWY/SUMW B(1)=AMEAN DO3173I=1,N Z(I)=Y(I)-AMEAN 3173 CONTINUE NDF=N-1 ANDF=NDF AN=N SUMWY=0.0 DO3174I=1,N SUMWY=SUMWY+W(I)*Z(I)**2 3174 CONTINUE SD=0.0 IF(NDF.GT.0)SD=SUMWY/ANDF IF(SD.LE.0.0)SD=0.0 IF(SD.GT.0.0)SD=SQRT(SD) T(1)=SD/SQRT(AN) GOTO3190 3179 CONTINUE C CCCCC APRIL 2002. CHECK FOR CERTAIN KINDS OF SINGULARITIES IN CCCCC MULTI-LINEAR FITS: CCCCC 1) ANY COLUMNS ARE CONSTANTS. CCCCC 2) ANY COLUMNS ARE EQUAL. IF(ICASFI.EQ.'MFIT')THEN IF(IFITAC.EQ.'ON')THEN ISTRT=2 ISTOP=NUMPAR ELSE ISTRT=1 ISTOP=NUMPAR ENDIF DO3176J=ISTRT,ISTOP AHOLD=X(1,J) DO3178I=1,N IF(AHOLD.NE.X(I,J))GOTO3176 3178 CONTINUE WRITE(ICOUT,3181) 3181 FORMAT('***** FROM DPFIT3, MULTI-LINEAR FIT CASE--') CALL DPWRST('XXX','WRIT') INDX=J IF(IFITAC.EQ.'ON')INDX=J-1 WRITE(ICOUT,3183)IVARN3(INDX),IVARN4(INDX),AHOLD 3183 FORMAT(' VARIABLE ',A4,A4,' HAS ALL VALUES = ',E15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3185) 3185 FORMAT(' THIS RESULTS IN A SINGULAR MATRIX. NO FIT ', 1 'PERFORMED.') CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 3176 CONTINUE C DO13176J=ISTRT,ISTOP DO13179K=ISTRT,ISTOP IF(J.EQ.K)GOTO13179 DO13181I=1,N IF(X(I,J).NE.X(I,K))GOTO13179 13181 CONTINUE WRITE(ICOUT,13182) 13182 FORMAT('***** FROM DPFIT3, MULTI-LINEAR FIT CASE--') CALL DPWRST('XXX','WRIT') INDX=J INDX2=K IF(IFITAC.EQ.'ON')THEN INDX=J-1 INDX2=K-1 ENDIF WRITE(ICOUT,13183)IVARN3(INDX),IVARN4(INDX),IVARN3(INDX2), 1 IVARN4(INDX2) 13183 FORMAT(' VARIABLE ',A4,A4,' HAS ALL VALUES = TO ', 1 'VARIABLE ',A4,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,13185) 13185 FORMAT(' THIS RESULTS IN A SINGULAR MATRIX. NO FIT ', 1 'PERFORMED.') CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 13179 CONTINUE 13176 CONTINUE C ENDIF C CALL LSQRTX(Y,W,N,X,NR,M,IT, 1B,Z,T,VSDPRE,S,E,D,SD,NDF,SCR,ID, CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEBMER 1993 CCCCC1IBUGA3,IERROR) 1IBUGA3,ISUBRO,IERROR) CCCCC THE ERROR ARGUMENT ABOVE AND THE BRANCH BELOW WERE ADDED MARCH 1988. IF(IERROR.EQ.'YES')GOTO9000 C 3190 CONTINUE CCCCC IF(IBUGA3.EQ.'ON') MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1WRITE(ICOUT,3191)N,M,NUMPAR 3191 FORMAT('N,M,NUMPAR = ',3I8) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL DPWRST('XXX','WRIT') C C ******************************************************* C ** STEP 32-- ** C ** IF NEEDED, COMPUTE PREDICTED VALUES ** C ** AND RESIDUALS. ** C ** COPY OVER PARAMETERS, ETC. ** C ******************************************************* C ISTEPN='32' CCCCC IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC JUNE 2002. ADD SOME COMPUTATIONS USED FOR THE ANOVA TABLE C IWRITE='OFF' CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) C DSUM1=0.0D0 DO3210I=1,N RES2(I)=Z(I) PRED2(I)=Y(I)-RES2(I) DSUM1=DSUM1 + DBLE(PRED2(I) - YMEAN)**2 CCCCC IF(IBUGA3.EQ.'ON') MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1WRITE(ICOUT,3211)I,Y(I),PRED2(I),RES2(I) 3211 FORMAT('I,Y(I),PRED2(I),RES2(I) = ',I8,3E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL DPWRST('XXX','WRIT') 3210 CONTINUE C SSR=REAL(DSUM1) C DO3220I=1,NUMPAR PARAM3(I)=B(I) C(I)=T(I) CCCCC IF(IBUGA3.EQ.'ON') MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1WRITE(ICOUT,3221)I,PARAM3(I),C(I) 3221 FORMAT('I,PARAM3(I),C(I) = ',I8,2E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL DPWRST('XXX','WRIT') 3220 CONTINUE C RESSD=SD RESDF=NDF RESMS=RESSD*RESSD RESSS=RESMS*RESDF CCCCC IF(IBUGA3.EQ.'ON') MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1WRITE(ICOUT,3231)RESSD,RESDF,RESMS,RESSS 3231 FORMAT('RESSD,RESDF,RESMS,RESSS = ',4E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL DPWRST('XXX','WRIT') C C ******************************************************* C ** STEP 41-- ** C ** PRINT OUT PARAMETER ESTIMATES ** C ** AND THEIR STANDARD DEVIATIONS. ** C ** ALSO PRINT OUT THE RESIDUAL STANDARD DEVIATION. ** C ******************************************************* C ISTEPN='41' CCCCC IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) MAY 1989 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C C STEP 2: START TABLE AND DEFINE A CAPTION C 5111 FORMAT('') 5199 FORMAT('

') WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5199) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C C STEP 1: START TABLE ENVIRONMENT, WRITE A HEADER C 8103 FORMAT(A1,'begin{table}') 8109 FORMAT(A1,'begin{center}') 8113 FORMAT(A1,'end{center}') 8120 FORMAT(5X,A1,'begin{tabular} {rrrrrr}') 8121 FORMAT(5X,A1,'begin{tabular} {rrrrr}') 8122 FORMAT(5X,A1,'multicolumn{4}{c}{',A1, 1 'bf Parameter Estimates} & ', 1 '{',A1,'bf Standard Deviation} & {',A1,'bf T Value}', 1 2X,A1,A1) 8123 FORMAT(5X,A1,'multicolumn{3}{c}{',A1, 1 'bf Parameter Estimates} & ', 1 '{',A1,'bf Standard Deviation} & {',A1,'bf T Value}', 1 2X,A1,A1) 8124 FORMAT(5X,A1,'multicolumn{4}{c}{ } & {',A1, 1 'bf Approximate} & ',2X,A1,A1) 8134 FORMAT(5X,A1,'multicolumn{3}{c}{ } & {',A1, 1 'bf Approximate} & ',2X,A1,A1) 8125 FORMAT(5X,I8,' & ',A4,A4,' & ',A4,A4,' & ',G15.7,' & ', 1 G15.7,' & ',G10.4,2X,A1,A1) 8126 FORMAT(5X,I8,' & ',A4,A4,' & ',A4,A4,' & ',G15.7,' & ', 1 G15.7,' & & ',2X,A1,A1) 8127 FORMAT(5X,I8,' & ',A4,A4,' & ',G15.7,' & ', 1 G15.7,' & ',G10.4,2X,A1,A1) 8128 FORMAT(5X,I8,' & ',A4,A4,' & ',G15.7,' & ', 1 G15.7,' & & ',2X,A1,A1) 8140 FORMAT(5X,A1,'hline') 8149 FORMAT(A1,'end{tabular}') C CCCCCC WRITE(ICOUT,8103)IBASLC CCCCCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8109)IBASLC CALL DPWRST('XXX','WRIT') IF(ICASFI.EQ.'MFIT')THEN WRITE(ICOUT,8120)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8124)IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8121)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8134)IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8123)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,8140)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C DO24120I=1,NUMPAR IF(IFITAC.EQ.'OFF')THEN IM1=I IHOLD3=IVARN3(IM1) IHOLD4=IVARN4(IM1) ELSE IF(I.LE.1)IHOLD3=' ' IF(I.LE.1)IHOLD4=' ' IM1=I-1 IF(I.GE.2)IHOLD3=IVARN3(IM1) IF(I.GE.2)IHOLD4=IVARN4(IM1) ENDIF TVALUE=(-999.9) IF(C(I).GT.0.0)TVALUE=PARAM3(I)/C(I) IF(ICASFI.EQ.'MFIT'.AND.C(I).GT.0.0)THEN WRITE(ICOUT,8125)I,IPARN3(I),IPARN4(I), 1 IHOLD3,IHOLD4,PARAM3(I),C(I),TVALUE, 1 IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.EQ.'MFIT'.AND.C(I).EQ.0.0)THEN WRITE(ICOUT,8126)I,IPARN3(I),IPARN4(I), 1 IHOLD3,IHOLD4,PARAM3(I),C(I), 1 IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.NE.'MFIT'.AND.C(I).GT.0.0)THEN WRITE(ICOUT,8127)I,IPARN3(I),IPARN4(I),PARAM3(I),C(I), 1 TVALUE,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.NE.'MFIT'.AND.C(I).EQ.0.0)THEN WRITE(ICOUT,8128)I,IPARN3(I),IPARN4(I),PARAM3(I),C(I), 1 IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF 24120 CONTINUE WRITE(ICOUT,8149)IBASLC CALL DPWRST('XXX','WRIT') C C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE C 8191 FORMAT(A1,'end{center}') 8193 FORMAT(A1,'end{table}') WRITE(ICOUT,8191)IBASLC CALL DPWRST('XXX','WRIT') CCCCCC WRITE(ICOUT,8193)IBASLC CCCCCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4111) 4111 FORMAT(1H ,7X,' PARAMETER ESTIMATES ', 1 '(APPROX. ST. DEV.) T VALUE') CALL DPWRST('XXX','WRIT') C DO4120I=1,NUMPAR IF(IFITAC.EQ.'OFF')THEN IM1=I IHOLD3=IVARN3(IM1) IHOLD4=IVARN4(IM1) ELSE IF(I.LE.1)IHOLD3=' ' IF(I.LE.1)IHOLD4=' ' IM1=I-1 IF(I.GE.2)IHOLD3=IVARN3(IM1) IF(I.GE.2)IHOLD4=IVARN4(IM1) ENDIF TVALUE=(-999.9) IF(C(I).GT.0.0)TVALUE=PARAM3(I)/C(I) IF(ICASFI.EQ.'MFIT'.AND.C(I).GT.0.0)THEN WRITE(ICOUT,4121)I,IPARN3(I),IPARN4(I), 1 IHOLD3,IHOLD4,PARAM3(I),C(I),TVALUE CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.EQ.'MFIT'.AND.C(I).EQ.0.0)THEN WRITE(ICOUT,4121)I,IPARN3(I),IPARN4(I), 1 IHOLD3,IHOLD4,PARAM3(I),C(I) CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.NE.'MFIT'.AND.C(I).GT.0.0)THEN WRITE(ICOUT,4122)I,IPARN3(I),IPARN4(I),PARAM3(I),C(I),TVALUE CALL DPWRST('XXX','WRIT') ELSEIF(ICASFI.NE.'MFIT'.AND.C(I).EQ.0.0)THEN WRITE(ICOUT,4122)I,IPARN3(I),IPARN4(I),PARAM3(I),C(I) CALL DPWRST('XXX','WRIT') ENDIF 4120 CONTINUE ENDIF ENDIF 4121 FORMAT(I8,2X,A4,A4,1X,A4,A4,G15.6,' (',G10.4,') ',3X,G10.4) 4122 FORMAT(I8,2X,A4,A4,1X,4X,4X,G15.6,' (',G10.4,') ',3X,G10.4) C C ********************************************* C ** STEP 42-- ** C ** PRINT OUT GOODNESS OF FIT INFORMATION ** C ********************************************* C IF(IREP.EQ.'YES')THEN IFITDF=IRESDF-IREPDF FITDF=IFITDF FITSS=RESSS-REPSS FITMS=100000.0 IF(FITDF.GT.0.0)FITMS=FITSS/FITDF FSTAT=100000.0 IF(REPMS.GT.0.0)FSTAT=FITMS/REPMS CALL FCDF(FSTAT,IFITDF,IREPDF,CDF) CDF2=100.0*CDF ALFCDF=CDF ENDIF C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C C STEP 2: START TABLE AND DEFINE A CAPTION C 5211 FORMAT('') 5299 FORMAT('
')
        WRITE(ICOUT,5291)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5293)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5299)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C  STEP 1: START TABLE ENVIRONMENT
C
 8203 FORMAT(A1,'begin{table}')
 8209 FORMAT(A1,'begin{center}')
 8213 FORMAT(A1,'end{center}')
C
CCCCC   WRITE(ICOUT,8203)IBASLC
CCCCC   CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8209)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8220 FORMAT(5X,A1,'begin{tabular} {lr}')
 8221 FORMAT(5X,'Residual Standard Deviation: & ',G15.7,2X,A1,A1)
 8222 FORMAT(5X,'Residual Degrees of Freedom: & ',I8,2X,A1,A1)
 8223 FORMAT(5X,'Replication Standard Deviation: & ',G15.7,2X,A1,A1)
 8224 FORMAT(5X,'Replication Degrees of Freedom: & ',I8,2X,A1,A1)
 8225 FORMAT(5X,'The lack of fit F test cannot be performed & ',
     1       2X,A1,A1)
 8226 FORMAT(5X,'because we have zero degrees of freedom in the & ',
     1       2X,A1,A1)
 8227 FORMAT(5X,'numerator of the F ratio.  This happens when the &',
     1       2X,A1,A1)
 8228 FORMAT(5X,'number of parameters fitted is identical to the & ',
     1       2X,A1,A1)
 8229 FORMAT(5X,'number of distinct subsets. & ',
     1       2X,A1,A1)
 8230 FORMAT(5X,'Lack of Fit F Ratio: & ',G12.4,2X,A1,A1)
 8231 FORMAT(5X,'The ',F8.4,A1,'% point of the F distribution with & ',
     1       2X,A1,A1)
 8232 FORMAT(5X,I6,' and ',I6,' degrees of freedom & ',2X,A1,A1)
 8249 FORMAT(A1,'end{tabular}')
        WRITE(ICOUT,8220)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8221)RESSD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8222)IRESDF,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(IREP.EQ.'YES')THEN
          WRITE(ICOUT,8223)REPSD,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,8224)IREPDF,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
          IF(IFITDF.LT.1)THEN
            WRITE(ICOUT,8225)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8226)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8227)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8228)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8229)IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
          ELSE
            WRITE(ICOUT,8230)FSTAT,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8231)CDF2,IBASLC,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,8232)IFITDF,IREPDF,IBASLC,IBASLC
            CALL DPWRST('XXX','WRIT')
          ENDIF
        ENDIF
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8291 FORMAT(A1,'end{center}')
 8293 FORMAT(A1,'end{table}')
 8299 FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8249)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8291)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8293)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8299)IBASLC
        CALL DPWRST('XXX','WRIT')
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
      ELSE
        IF(NUMPAR.GE.1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,4411)RESSD
 4411   FORMAT('      RESIDUAL    STANDARD DEVIATION = ',G20.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4412)IRESDF
 4412   FORMAT('      RESIDUAL    DEGREES OF FREEDOM = ',2X,I9)
        CALL DPWRST('XXX','WRIT')
C
        IF(IREP.EQ.'YES')THEN
          WRITE(ICOUT,4421)REPSD
 4421     FORMAT('      REPLICATION STANDARD DEVIATION = ',F20.10)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4422)IREPDF
 4422     FORMAT('      REPLICATION DEGREES OF FREEDOM = ',2X,I9)
          CALL DPWRST('XXX','WRIT')
          IF(IFITDF.LT.1)THEN
            WRITE(ICOUT,4423)
 4423       FORMAT('      LACK OF FIT F TEST CANNOT BE DONE BECAUSE')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4424)
 4424       FORMAT('      HAVE ONLY 0 DEGREES OF FREEDOM IN ',
     1             'NUMERATOR OF F RATIO.')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4425)
 4425       FORMAT('      THIS HAPPENS WHEN NUMBER OF PARAMETERS ')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,4426)
 4426       FORMAT('      FITTED IS IDENTICAL TO NUMBER OF DISTINCT ',
     1             'SUBSETS.')
            CALL DPWRST('XXX','WRIT')
          ENDIF
C
          WRITE(ICOUT,4431)FSTAT,CDF2
 4431     FORMAT('      LACK OF FIT F RATIO = ',F12.4,' = THE ',
     1           F8.4,'% POINT OF THE')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4432)IFITDF,IREPDF
 4432     FORMAT('      F DISTRIBUTION WITH ',I6,' AND ',I6,
     1           ' DEGREES OF FREEDOM')
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
      ENDIF
      ENDIF
C
CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992
C               ************************************************
C               **  STEP 81--                                 **
C               **  WRITE INFO OUT TO FILES--                 **
C               **     1) DPST1F.DAT--COEF SDCOEF TCDF        **
C               **        JUNE 2002: ADD JOINT BONFERRNI      **
C               **        CONFIDENCE INTERVAL FOR PARAMETERS  **
C               **     2) DPST2F.DAT--SDPRED, CONFIDENCE      **
C               **        INTERVAL FOR PREDICTED VALUES       **
C               **     3) DPST3F.DAT--REGRESSION DIAGNOSTICS  **
C               **     4) DPST4F.DAT--CORR MATRIX             **
C               **     5) DPST5F.DAT--ADD ANOVA TABLE (AND    **
C               **        R-SQUARE, ADJUSTED R-SQUARE, MALLOWS**
C               **        CP, PRESS P STATISTICS              **
C               **        ADDED JUNE 2002                     **
C               ************************************************
C
 8600 CONTINUE
C
      ISTEPN='86'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC JUNE 2002.  ADD T-VALUE AND JOINT BONFERONI CONFIDENCE
CCCCC LIMITS TO OUTPUT
C
      AJUNK=1.0 - ALPHA
      AJUNK2=1.0 - (AJUNK/(2.0*REAL(NUMPAR)))
      NP=N-NUMPAR
      TBONF=0.0
      IF(NP.GE.1.AND.(AJUNK2.GE.0.0.AND.AJUNK2.LE.1.0))
     1CALL TPPF(AJUNK2,REAL(NP),TBONF)
      DO8610I=1,NUMPAR
        TVALUE=(-999.9)
        IF(C(I).GT.0.0)TVALUE=PARAM3(I)/C(I)
        TBONL=PARAM3(I) - TBONF*C(I)
        TBONU=PARAM3(I) + TBONF*C(I)
        WRITE(IOUNI1,8611)PARAM3(I),C(I),TVALUE,TBONL,TBONU,
     1                    IPARN3(I),IPARN4(I)
 8610 CONTINUE
 8611 FORMAT(5E15.7,2X,A4,A4)
C
CCCCC THE FOLLOWING 2 LINES WERE ADDED     SEPTEMBER 1995
CCCCC APRIL 1996.  SUPPRESS PRINTING IF IPRINT OFF
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8612)
 8612   FORMAT(6X,'COEF, SD(COEF), T-VALUE, LOWER BONFERRONI, ',
     1         'UPPER BONFERRONI')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8613)
 8613   FORMAT(6X,'                  WRITTEN OUT TO FILE DPST1F.DAT')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ACTIVATED     JANUARY 1994
CCCCC JUNE 2002: ADD SUPPORT FOR JOINT BONFERRONI AND JOINT
CCCCC HOTELLING CONFIDENCE INTERVALS.
      T975=0.0
      T995=0.0
      IF(IRESDF.GE.1)CALL TPPF(.975,REAL(IRESDF),T975)
      IF(IRESDF.GE.1)CALL TPPF(.995,REAL(IRESDF),T995)
C
      TBONF=0.0
      THOT=0.0
      AJUNK=1.0 - ALPHA
      AJUNK2=1.0 - (AJUNK/(2.0*REAL(N)))
      NP=N-NUMPAR
      IF(NP.GE.1.AND.(AJUNK2.GE.0.0.AND.AJUNK2.LE.1.0))
     1CALL TPPF(AJUNK2,REAL(NP),TBONF)
      IF(NP.GE.1.AND.NUMPAR.GE.1.AND.(ALPHA.GE.0.0.AND.ALPHA.LE.1.0))
     1CALL FPPF(ALPHA,NUMPAR,NP,THOT)
      THOT=REAL(NUMPAR)*THOT
      IF(THOT.GT.0.0)THOT=SQRT(THOT)
C
      DO8620I=1,N
      PR=PRED2(I)
      SDPR=VSDPRE(I)
      ALOW2=PR-T975*SDPR
      AUPP2=PR+T975*SDPR
      ALOW3=PR-T995*SDPR
      AUPP3=PR+T995*SDPR
      ALOW4=PR-TBONF*SDPR
      AUPP4=PR+TBONF*SDPR
      ALOW5=PR-THOT*SDPR
      AUPP5=PR+THOT*SDPR
      WRITE(IOUNI2,8621)SDPR,ALOW2,AUPP2,ALOW3,AUPP3,ALOW4,AUPP4,
     1                  ALOW5,AUPP5
 8621 FORMAT(9E15.7)
 8620 CONTINUE
CCCCC APRIL 1996.  SUPPRESS PRINTING IF IPRINT OFF
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,8622)
 8622   FORMAT(6X,'SD(PRED),95LOWER,95UPPER,99LOWER,99UPPER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8624)
 8624   FORMAT(6X, 'LOWER BONFERRONI,UPPER BONFERRONI,LOWER HOTELLING',
     1         ',UPPER HOTELLING')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8623)
 8623   FORMAT(6X,'                  WRITTEN OUT TO FILE DPST2F.DAT')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCC  JULY 1993.  UNCOMMENT FOLLOWING BLOCK. COPUTE AND PRINT:
CCCCC 1) DIAGONALS OF HAT MATRIX (HII = VAR(PRED VALUE)/RESIDUAL VAR)
CCCCC 2) VARIANCE OF RESIDUALS   (VAR(RES) = MSE*(1-HII))
CCCCC 3) STANDARDIZED RESIDUALS  (STRES = RES/SQRT(MSE))
CCCCC 4) INTERNALLY STUDENTIZED RESIDUALS  ( = RES/SD(RES))
CCCCC 5) DELETED RESIDUALS       ( = RES/(1-HII))
CCCCC 6) EXTERNALLY STUDENTIZED RESIDUALS (=RES*SQRT((N-P-1)/(SSE*
CCCCC                                       (1-HII)-RES**2))
CCCCC 7) COOK'S DISTANCE         (COOK=(RES**2/(P*MSE))*HII/(1-HII)**2
CCCCC 8) DFFITS                  (DFFITS=EXTSRES*SQRT(HII(1-HII))
CCCCC                              WHERE EXTSRES=EXTERNAL STUDENT RES
CCCCC IF HAVE PERFECT FIT, RESSD IS ZERO.  DON'T PRINT DIAGNOSTIC
CCCCC STATISTICS IN THIS CASE.
      IF(RESSD.EQ.0.0)THEN
        WRITE(IOUNI3,8631)
 8631   FORMAT(1X,'PERFECT FIT, NO DIAGNOSTICS GENERATED.')
        GOTO8659
      ENDIF
C
      AJUNK=RESSD**2
      DSUM1=0.0D0
      DO8635I=1,N
        AJUNK2=VSDPRE(I)**2
        CALL SPDIV(AJUNK2,AJUNK,IND,Z(I))
        IF(W(I).EQ.0.0)Z(I)=0.0
 8635 CONTINUE
      WRITE(IOUNI3,8639)
 8639 FORMAT(1X,
     1'DIAGONAL OF HAT ',
     2'RESIDUAL VAR    ',
     3'STANDARD RES    ',
     4'INT. STUD. RES  ',
     5'DELETED RES     ',
     6'EXT. STUD. RES  ',
     7'COOKS DISTANCE  ',
     8'DFFITS          ')
      DO8640I=1,N
      AJUNK3=RESMS*(1.0-Z(I))
      IF(AJUNK3.LE.0.0)AJUNK3=0.0
      IF(SQRT(RESMS).GT.0.0)THEN
        AJUNK4=RES2(I)/SQRT(RESMS)
      ELSE
        AJUNK4=0.0
      ENDIF
      IF(AJUNK3.GT.0.0)THEN
        AJUNK5=RES2(I)/SQRT(AJUNK3)
      ELSE
        AJUNK5=0.0
      ENDIF
      IF(Z(I).NE.1.0)THEN
        AJUNK6=RES2(I)/(1.0-Z(I))
        DSUM1=DSUM1 + DBLE(AJUNK6)**2
      ELSE
        AJUNK6=CPUMAX
      ENDIF
      ACONST=(RESDF-1.0)
CCCCC SEPTEMBER 1993.  FIX TYPO IN FOLLOWING LINE
CCCCC IF(RESS*(1.0-Z(I))-RES2(I)**2.NE.0.0)THEN
      IF(RESSS*(1.0-Z(I))-RES2(I)**2.NE.0.0)THEN
        AJUNK2=ACONST/(RESSS*(1.0-Z(I))-RES2(I)**2)
      ELSE
        AJUNK2=0.0
      ENDIF
      AJUNK7=0.0
      IF(AJUNK2.GE.0.0)AJUNK7=RES2(I)*SQRT(AJUNK2)
CCCCC THE FOLLOWING LINE WAS FIXED        JANUARY 1996
CCCCC TO FIX BOMB WITH   CONSTANT FIT     JANUARY 1996
CCCCC AJUNK=RES2(I)**2/(REAL(M)*RESMS)
CCCCC USE NUMPAR INSTEAD OF M.
      AJUNK=0.0
CCCCC IF(M.GT.0)AJUNK=RES2(I)**2/(REAL(M)*RESMS)
      IF(NUMPAR.GT.0)AJUNK=RES2(I)**2/(REAL(NUMPAR)*RESMS)
      AJUNK2=0.0
      IF(Z(I)-1.0.NE.0.0)AJUNK2=Z(I)/((1.0-Z(I))**2)
      AJUNK8=AJUNK*AJUNK2
      AJUNK2=0.0
      IF(Z(I)-1.0.NE.0.0)AJUNK2=SQRT(Z(I)/(1.0-Z(I)))
      AJUNK9=AJUNK7*AJUNK2
      WRITE(IOUNI3,8641)Z(I),AJUNK3,AJUNK4,AJUNK5,AJUNK6,
     1AJUNK7,AJUNK8,AJUNK9
 8641 FORMAT(8(E15.7,1X))
 8640 CONTINUE
C
      APRESS=REAL(DSUM1)
C
CCCCC APRIL 1996.  SUPPRESS PRINTING IF IPRINT OFF
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,8652)
 8652   FORMAT(6X,
     1         'REGRESSION DIAGNOSTICS WRITTEN OUT TO FILE DPST3F.DAT')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC JULY 1993.  WRITE OUT VARIANCE-COVARIANCE PARAMETER OF
CCCCC PARAMETERS.  NOTE THAT IT IS STORED IN SCRATCH SCR, STARTING
CCCCC AT ELEMENT 1 AND (M+1)*(M+2)/2 ELEMENTS LONG
CCCCC ACTUALLY, THIS IS THE (X-TRANSPOSE X) INVERSE MATRIX, MULTIPLY
CCCCC BY MSE TO GET VARIANCE-COVARIANCE MATRIX.
CCCCC JUNE 1994.  BUG: FOR POLYNOMIAL, M=NUMPAR-1, SO ADD 1 BACK IN
 8659 CONTINUE
      NTEMP=M
      IF(ICASFI.NE.'MFIT')NTEMP=M+1
      ICOUNT=0
      DO8660I=1,NTEMP
        DO8662J=I,NTEMP
          ICOUNT=ICOUNT+1
          PARCOV(I,J)=SCR(ICOUNT)
          PARCOV(J,I)=PARCOV(I,J)
 8662   CONTINUE
 8660 CONTINUE
      DO8670J=1,NTEMP
      DO8672I=1,NTEMP
      AJUNK=RESMS*PARCOV(I,J)
      WRITE(IOUNI4,8679)AJUNK,PARCOV(I,J)
 8679 FORMAT(E15.7,1X,E15.7)
 8672 CONTINUE
      WRITE(IOUNI4,8678)
 8678 FORMAT(1X)
 8670 CONTINUE
C
CCCCC APRIL 1996.  SUPPRESS PRINTING IF IPRINT OFF
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,8682)
 8682   FORMAT(6X,'PARAMETER VARIANCE-COVARIANCE MATRIX AND')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8683)
 8683   FORMAT(6X,'INVERSE OF X-TRANSPOSE X MATRIX')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8684)
 8684   FORMAT(6X,'                  WRITTEN OUT TO FILE DPST4F.DAT')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC WRITE REGRESSION ANOVA TABLE TO DPST5F.DAT
C
      RESSD=SD
      RESDF=NDF
      RESMS=RESSD*RESSD
      RESSS=RESMS*RESDF
C
      IREGDF=NUMPAR-1
      AMSR=SSR/REAL(IREGDF)
C
      ITOTDF=INT(RESDF) + IREGDF
      SSTO=SSR + RESSS
C
      RSQUAR=1.0 - RESSS/SSTO
      ADJRSQ=1.0 - (REAL(N-1)/REAL(N-NUMPAR))*RESSS/SSTO
C
      FSTAT=100000.0
      IF(RESMS.GT.0.0)FSTAT=AMSR/RESMS
      NP=N-NUMPAR
      CALL FCDF(FSTAT,IREGDF,NP,CDF)
C
      WRITE(IOUNI5,8710)
 8710 FORMAT('------------------------------------------------------',
     1       '-----------------------')
      WRITE(IOUNI5,8712)
 8712 FORMAT('SOURCE               DF    SUM OF SQUARES    ',
     1       ' MEAN SQUARE              F')
      WRITE(IOUNI5,8710)
C
      WRITE(IOUNI5,8714)IREGDF,SSR,AMSR,FSTAT
 8714 FORMAT('REGRESSION     ',I8,3X,E15.7,3X,E15.7,3X,E15.7)
      WRITE(IOUNI5,8716)INT(RESDF),RESSS,RESMS
 8716 FORMAT('RESIDUAL       ',I8,3X,E15.7,3X,E15.7)
      WRITE(IOUNI5,8718)ITOTDF,SSTO
 8718 FORMAT('TOTAL          ',I8,3X,E15.7)
C
      WRITE(IOUNI5,8710)
      WRITE(IOUNI5,999)
      WRITE(IOUNI5,999)
      WRITE(IOUNI5,8722)RSQUAR
 8722 FORMAT('R-SQUARE           = ',F10.7)
      WRITE(IOUNI5,8724)ADJRSQ
 8724 FORMAT('ADJUSTED R-SQUARE  = ',F10.7)
      WRITE(IOUNI5,8726)APRESS
 8726 FORMAT('PRESS-P STATISTIC  = ',G15.7)
C
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,8782)
 8782   FORMAT(6X,'REGRESSION ANOVA TABLE WRITTEN OUT TO FILE ',
     1         'DPST5F.DAT')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1992
C               **************************************
C               **  STEP 88--                       **
C               **  CLOSE       THE STORAGE FILES.  **
C               **************************************
C
 8800 CONTINUE
C
      ISTEPN='87'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IENDF1='OFF'
      IREWI1='ON'
      CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1,
     1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR)
      IF(IERRF1.EQ.'YES')GOTO9000
C
      IENDF2='OFF'
      IREWI2='ON'
      CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
     1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR)
      IF(IERRF2.EQ.'YES')GOTO9000
CCCCC JULY 1993.  ADD FOLLOWING SECTION
      IENDF3='OFF'
      IREWI3='ON'
      CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3,
     1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR)
      IF(IERRF3.EQ.'YES')GOTO9000
CCCCC FEBRUARY 1994.  ADD FOLLOWING SECTION
      IENDF4='OFF'
      IREWI4='ON'
      CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
     1IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR)
      IF(IERRF4.EQ.'YES')GOTO9000
CCCCC JUNE 2002.  ADD FOLLOWING SECTION
      IENDF5='OFF'
      IREWI5='ON'
      CALL DPCLFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5,
     1IENDF5,IREWI5,ISUBN0,IERRF5,IBUGA3,ISUBRO,IERROR)
      IF(IERRF5.EQ.'YES')GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
CCCCC IF(IBUGA3.EQ.'OFF')GOTO9090   MAY 1989
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'FIT3')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPFIT3--')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9012)IERROR
 9012 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9013)N,NUMVAR,NUMPAR,NUMCHA
 9013 FORMAT('N,NUMVAR,NUMPAR,NUMCHA = ',4I8)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9014)ICASFI,IT
 9014 FORMAT('ICASFI,IT = ',A4,I8)
      CALL DPWRST('XXX','WRIT')
      DO9015I=1,NUMPAR
      WRITE(ICOUT,9016)I,IPARN3(I),IPARN4(I),PARAM3(I)
 9016 FORMAT('I,IPARN3(I),IPARN4(I),PARAM3(I) = ',I8,2X,A4,A4,E15.7)
      CALL DPWRST('XXX','WRIT')
 9015 CONTINUE
      WRITE(ICOUT,9017)IBUGA3,IBUGCO,IBUGEV
 9017 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','WRIT')
      DO9020I=1,N
      WRITE(ICOUT,9021)I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I)
 9021 FORMAT('I,Y(I),X1(I),X2(I),W(I),PRED2(I),RES2(I) = ',
     1I8,6E13.6)
      CALL DPWRST('XXX','WRIT')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
CCCCC-----LSQRT--------------------------------------
      SUBROUTINE LSQRTX (Y,W,N,X,NR,M,IT,
     1B,Z,T,V,S,E,D,SD,NDF,SCR,ID,
CCCCC1IBUGA3,IERROR)
     1IBUGA3,ISUBRO,IERROR)
CCCCC THE ABOVE LINE WAS AUGMENTED     SEPTEMBER 1993
C
C     PURPOSE--PERFORM LEAST SQUARES FIT
C              OF MULTILINEAR MODEL OR POLYNOMIAL MODEL
C              USING A MODIFIED GRAM-SCHMIDT ALGORITHM
C              WITH ITERATIVE REFINEMENT OF THE SOLUTION.
C
C     INPUT ARGUMENTS--
C           Y     VECTOR OF OBSERVATIONS (N BY 1).
C           W     VECTOR OF WEIGHTS (N BY 1).
C           N     NUMBER OF OBSERVATIONS.
C           X     MATRIX OF INDEPENDENT VARIABLES WHICH ARE TO BE FITTED.
C           NR    MAXIMUM NUMBER OF ROWS IN X.
C           M     NUMBER OF UNKNOWN COEFFICIENTS OR DEGREE OF POLYNOMIAL
C                    (M LESS THAN OR EQUAL TO N).
C           IT    PARAMETER WHICH SPECIFIES WHETHER OR NOT A POLYNOMIAL TYPE
C                    FIT IS TO BE PERFORMED.
C                      IT = 1 INDICATES POLYNOMIAL FIT.
C                      IT = 2 INDICATES MULTILINEAR FIT.
C
C
C                 IF IT = 1, THE FUNCTION TO BE FITTED IS A POLYNOMIAL
C                    HAVING THE FORM
C
C                    Y(I) = B(1) + B(2)*Z(I) + B(3)*Z(I)**2 + ...
C                                + B(M)*Z(I)**(M-1) + ERROR, I=1,2,...,N.
C
C                 IF IT = 2, THE FUNCTION TO BE FITTED HAS THE FORM
C
C                    Y(I) = B(1)*X1(I) + B(2)*X2(I) + ... + B(M)*XM(I) +
C                                                     ERROR, I=1,2,...,N.
C     OUTPUT ARGUMENTS--
C           B     VECTOR OF COEFFICIENTS (M+1 BY 1).
C           Z     VECTOR OF RESIDUALS (N BY 1).
C           T     VECTOR OF STANDARD DEVIATIONS OF COEFFICIENTS (M+1 BY 1).
C           V     VECTOR OF STANDARD DEVIATIONS OF PREDICTED VALUES
C                    (N BY 1).
C           S     VECTOR OF SQUARED FOURIER COEFFICIENTS (M+3 BY 1).  THE
C                    FIRST M ELEMENTS OF THIS ARRAY ARE SUMS OF SQUARES
C                    WHICH CAN BE USED IN AN ANALYSIS OF VARIANCE.  THE
C                    LAST TWO ELEMENTS OF S ARE NOT COMPUTED IN THIS SUB-
C                    ROUTINE BUT ARE RESERVED FOR QUANTITIES TO BE COMPUTED
C                    IN THE CALLING PROGRAM.
C           E     RESIDUAL SUM OF SQUARES.
C           D     AVERAGE NUMBER OF DIGITS IN AGREEMENT BETWEEN INITIAL
C                    SOLUTION AND THE FIRST ITERATION (IN SUBROUTINE SLVE).
C           SD    RESIDUAL STANDARD DEVIATION.
C           NDF   NO. OF DEGREES OF FREEDOM.
C           SCR   A SCRATCH VECTOR USED FOR INTERNAL CALCULATIONS
C           ID    ID = 0  EVERYTHING IS OK.
C                 ID = 1  AUGMENTED MATRIX IS SINGULAR.
C                 ID = 2  ITERATION PROCEDURE FAILED TO CONVERGE.
C
C     NOTE--THE INPUT ARRAYS X, Y AND W ARE LEFT UNCHANGED
C           BY THIS SUBROUTINE.
C     NOTE--THE SCR VECTOR MUST HAVE SIZE EQUAL TO OR GREATER THAN
C           ((M + 1) (M + 2) / 2) + N*M + 2*N + 2*M +1
C     PRIMARY CALLING SEQUENCE--
C           LSQRT
C                 LSQ
C                       SCALE
C                       PDECOM
C                       SLVE
C                       DSUMAL
C                       SDPRED
C                       PINVRT
C     ADDITIONAL SUBROUTINES THAT HAVE BEEN CONVERTED FROM FUNCTIONS--
C           DPDIV
C           SPDIV
C           DPCON
C           DPSQRT
C           SPSQRT
C           SPLO10
C           IDIV
C
C     SUBROUTINE LSQ COMPUTES SOLUTIONS TO LINEAR LEAST SQUARES
C        PROBLEMS USING A MODIFIED GRAM-SCHMIDT ALGORITHM WITH
C        ITERATIVE REFINEMENT OF THE SOLUTION.
C
C     SUBROUTINES PDECOM, SLVE AND PINVRT ARE BASED ON ...
C        (1) ITERATIVE REFINEMENT OF LINEAR LEAST SQUARES SOLUTIONS II,
C            BY AKE BJORCK, BIT, VOL. 8 (1968), PP. 8-30.
C        (2) SOLUTIONS TO WEIGHTED LEAST SQUARES PROBLEMS BY MODIFIED
C            GRAM-SCHMIDT WITH ITERATIVE REFINEMENT, BY ROY H. WAMPLER,
C            ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, VOL. 5 (1979),
C            TO APPEAR.
C
C     PRECISION--
C        SINGLE PRECISION ARITHMETIC IS USED FOR ALL CALCULATIONS EXCEPT
C        THE DOUBLE PRECISION ACCUMULATION OF INNER PRODUCTS.  (THE
C        VARIABLE SUM (OR DSUM) IS DECLARED TO BE DOUBLE PRECISION IN
C        SUBROUTINE LSQ, SCALE, PDECOM, SLVE, SDPRED AND PINVRT.)  IT
C        IS ESSENTIAL FOR THE SUCCESS OF THE ITERATIVE REFINEMENT
C        PROCEDURE IN SUBROUTINE SLVE THAT INNER PRODUCTS BE ACCUMULATED
C        IN DOUBLE PRECISION.
C
C *   CONVERSION OF THE PROGRAM TO STRICTLY DOUBLE PRECISION, AND      *
C *   CONVERSION OF THE PROGRAM TO STRICTLY SINGLE PRECISION.          *
C *      ON COMPUTERS HAVING SHORT WORD LENGTH (AS THE IBM 360/370)    *
C *      IT MAY BE DESIRABLE TO PERFORM ALL CALCULATIONS IN DOUBLE     *
C *      PRECISION.  ON COMPUTERS HAVING LONG WORD LENGTH (AS THE CDC  *
C *      6600) IT MAY BE DESIRABLE TO PERFORM ALL CALCULATIONS IN      *
C *      SINGLE PRECISION.  IN SUCH CASES, THE ITERATIVE REFINEMENT    *
C *      PRESENTLY INCLUDED IN SUBROUTINE SLVE SHOULD BE OMITTED.      *
C *      ADDITIONAL REMARKS ON HOW TO OMIT THE ITERATIVE REFINEMENT    *
C *      ARE GIVEN IN SUBROUTINE SLVE.                                 *
C *      IF ALL COMPUTING IS DONE IN DOUBLE PRECISION, THE VALUE OF    *
C *      ETA, A MACHINE DEPENDENT PARAMETER, SHOULD BE CHANGED SO THAT *
C *      ETA IS THE SMALLEST DOUBLE PRECISION NUMBER SUCH THAT         *
C *      1.0 + ETA IS GREATER THAN 1.0 IN DOUBLE PRECISION ARITHMETIC. *
C
C     TEST PROBLEM--
C           SAMPLE INPUT FOR A MULTILINEAR FIT
C           (4 INDEPENDENT VARIABLES EQUIVALENT TO A CUBIC FIT
C           AND UNIT WEIGHTING)--
C           FIRST LINE GIVES SAMPLE SIZE, DEGREE, POLYNOMIAL TYPE
C
C            7 4 2
C            10. 1. 3.4 11.56 39.304 1.
C            20. 1. 11.7 136.89 1601.613 1.
C            30. 1. 37.2 1383.84 51478.848 1.
C            40. 1. 80.1 6416.01 513922.401 1.
C            50. 1. 151.4 22921.96 3470384.744 1.
C            60. 1. 253.2 64110.24 16232712.768 1.
C            70. 1. 392.6 154134.76 60513306.776 1.
C
C           SAMPLE INPUT FOR A CUBIC POLYNOMIAL FIT
C           (SAME EXAMPLE AS ABOVE)--
C           FIRST LINE GIVES SAMPLE SIZE, NUMBER OF VAR., MULTILINEAR TYPE
C
C            7 3 1
C            10.   3.4 1.
C            20.  11.7 1.
C            30.  37.2 1.
C            40.  80.1 1.
C            50. 151.4 1.
C            60. 253.2 1.
C            70. 392.6 1.
C
C     OUTPUT (FROM EITHER OF THE ABOVE 2 TEST PROBLEMS)--
C
C       COEFFICIENTS
C          .12212494E+02    .46908681E+00   -.16867931E-02    .22115341E-05
C       RESIDUALS
C         -.37879763E+01    .25265538E+01    .25578816E+01   -.10042261E+00
C         -.22425069E+01    .12562386E+01   -.20976813E+00
C       S D OF COEFFICIENTS
C          .26445864E+01    .86317750E-01    .57921800E-03    .98128429E-06
C       S D OF PREDICATED VALUES
C          .24379267E+01    .20369802E+01    .17428904E+01    .23363574E+01
C          .23017371E+01    .31747709E+01    .33588546E+01
C       SQUARED FOURIER COEFFICIENTS
C          .11200000E+05    .24784422E+04    .23016542E+03    .57456310E+02
C       RESIDUAL SUM OF SQUARES =    .33936057E+02
C       AVERAGE NO. DIGITS IN AGREEMENT =    .78267799E+01
C       RESIDUAL STANDARD DEVIATION =    .33633345E+01
C       DEGREES OF FREEDOM =   3
C
C     NOTE--IN THE ABOVE TEST PROBLEMS, N = 7 AND M = 4
C           AND THUS THE DIMENSION OF SCR MUST BE AT LEAST
C           ((M + 1) (M + 2) / 2) + N*M + 2*N + 2*M +1 =
C           ((4 + 1) (4 + 2) / 2) + 7*4 + 2*7 + 2*4 +1 = 66
C
C     NOTE--MAXOBV = MAXIMUM NUMBER OF OBSERVATIONS PER VARIABLE
C                    (= 2048 (JULY 1987))
C           MAXCMF = MAXIMUM NUMBER OF COEFFICIENTS THAT MAY
C                    BE ESTIMATED IN A MULTILINEAR FIT
C                    (= 30 (JULY 1987))
C     WRITTEN BY--ROY H. WAMPLER
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 A337 ADMINISTRATION BUILDING
C                 NATIONAL BUREAU OF STANDARDS
C                 GAITHERSBURG, MD. 20899
C                 301-975-2844
C
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C     UPDATED         --MARCH     1988.  CHECK THAT SCRATCH AREA NOT EXCEEDED
C     UPDATED         --NOVEMBER  1989.  DIMENSION SCR(1) TO SCR(*)
C     UPDATED         --SEPTEMBER 1993.  ADD ISUBRO TO INPUT ARGS
C     UPDATED         --JULY      1995.  ADJUST DEBUG FORMATS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C-----DIMENSION-------------------------------------------------------
 
      INCLUDE 'DPCOPA.INC'
C
CCCCC DIMENSION X(NR,M),Y(N),W(N),B(M),Z(N),T(M+1),V(N),S(M+2),SCR(1)
CCCCC DIMENSION X(NR,M)
CCCCC DIMENSION X(MAXOBV,MAXCMF)
      DIMENSION X(NR,*)
      DIMENSION Y(N)
      DIMENSION W(N)
      DIMENSION B(M)
      DIMENSION Z(N)
      DIMENSION T(M+1)
      DIMENSION V(N)
      DIMENSION S(M+2)
CCCCC THE FOLLOWING LINE WAS CORRECTED NOVEMBER 1989
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC DIMENSION SCR(1)
      DIMENSION SCR(*)
C
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
CCCCC THE FOLLOWING LINE WAS CHANGED      SEPTEBMER 1993
CCCCC IF(IBUGA3.EQ.'OFF')GOTO90
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SQRT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LSQRT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)N,M,IT
   55 FORMAT('N,M,IT = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO56J=1,M
      DO57I=1,N
      WRITE(ICOUT,58)I,J,Y(I),X(I,J),W(I)
   58 FORMAT('I,J,Y(I),X(I,J),W(I) = ',2I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   57 CONTINUE
   56 CONTINUE
   90 CONTINUE
C
CCCCC THE FOLLOWING SECTION OF CODE WAS INSERTED MARCH 1988.
C     CHECK THAT THE SCRATCH AREA WILL NOT OVERFLOW
C
      INEED=(((M+1)*(M+2))/2)+2*M+1+N*(M+2)+2
      IAVAIL=MAXOBW
      IF(INEED.LE.IAVAIL)GOTO190
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LSQRT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      INTERNAL REGRESSION SCRATCH AREA EXCEEDED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)INEED
  113 FORMAT('      NEEDED    SCRATCH AREA SIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)IAVAIL
  114 FORMAT('      AVAILABLE SCRATCH AREA SIZE = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      RECOMMENDATION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('         1. FIT TO A SUBSET; OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)
  117 FORMAT('         2. SIMPLIFY THE MODEL.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  190 CONTINUE
C
C     DEFINE STARTING POINT FOR THE R MATRIX
C
      ISUBR = 1
      MZ = M
      IF (IT.EQ.1) MZ = MZ+1
      MIN2 = (MZ+1) * (MZ+2) / 2
C
C     DEFINE STARTING POINT FOR THE Q VECTOR
C
      ISUBQ = ISUBR + MIN2
      MM1 = N * (MZ+1)
C
C     DEFINE STARTING POINT FOR THE F VECTOR
C
      ISUBF = ISUBQ + MM1
C
C     DEFINE STARTING POINT FOR THE P VECTOR
C
      ISUBP = ISUBF + MZ + 1
C
C     DEFINE STARTING POINT FOR THE A VECTOR
C
      ISUBA = ISUBP + N
      C = 0.0
      H = 0.0
C
CCCCC THE FOLLOWING ARGUMENT LIST WAS AUGMENTED     SEPTEMBER 1995
      CALL LSQ (N,MZ,NR,X,Y,W,H,C,IT,B,Z,SCR(ISUBR),T,V,S,E,SCR(ISUBQ),
CCCCC1SCR(ISUBF),SCR(ISUBP),SCR(ISUBA),ID,D)
     1SCR(ISUBF),SCR(ISUBP),SCR(ISUBA),ID,D,
     1IBUGA3,ISUBRO,IERROR)
CCCCC WRITE(6,770)ID
CC770 FORMAT('ID = ',I8)
C
      NDF = 0
      DO 1100 I = 1,N
      IF (W(I) .GT. 0.0) NDF = NDF + 1
 1100 CONTINUE
      NDF = NDF-MZ
CCCCC SD = SPDIV(E,FLOAT(NDF),IND)
      CALL SPDIV(E,FLOAT(NDF),IND,RESULT)
      SD = RESULT
CCCCC SD = SPSQRT(SD)
      CALL SPSQRT(SD,RESULT)
      SD=RESULT
C
 9000 CONTINUE
CCCCC THE FOLLOWING SECTION WAS ADDED      SEPTEBMER 1993
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'SQRT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LSQRT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO
 9012 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 8 LINES WERE CHANGED / ADDED   JULY 1995
      WRITE(ICOUT,9015)SD,RESULT,M,NDF
 9015 FORMAT('SD,RESULT,M,NDF = ',2E15.7,2I8)
      CALL DPWRST('XXX','BUG ')
      DO9016I=1,M
         WRITE(ICOUT,9017)I,B(I),T(I)
 9017    FORMAT('I,B(I),T(I) = ',I8,2E15.7)
         CALL DPWRST('XXX','BUG ')
 9016 CONTINUE
 9090 CONTINUE
      RETURN
      END
CCCCC-----LSQ--------------------------------------
      SUBROUTINE LSQ (N,M,NR,X,Y,W,H,C,IT,B,Z,R,T,V,S,E,Q,F,P,A,ID,D,
     1IBUGA3,ISUBRO,IERROR)
CCCCC SUBROUTINE LSQ (N,M,NR,X,Y,W,H,C,IT,B,Z,R,T,V,S,E,Q,F,P,A,ID,D)
CCCCC THE ABOVE ARGUMENT LIST WAS AUGMENTED    SEPTEMBER 1995
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG,MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO (*) (AND MOVED)
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --SEPTEMBER 1995. ADD BUGS TO ARGUMENT LIST
C
C     ==================================================================
C
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
CCCCC THE FOLLOWING 3 LINES WERE ADDED    SEPTEMBER 1995
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
CCCCC THE FOLLOWING 6 LINES WERE MOVED        NOVEMBER 1989
CCCCC AND CHANGED DIMENSION (1) TO (*)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             A(1), B(1), F(1), P(1), Q(1), R(1), S(1)
CCCCC REALCCCCC        T(1), V(1), W(1), X(NR,M), Y(1), Z(1)
CCCCC REAL             T(1), V(1), W(1), X, Y(1), Z(1)
CCCCC REAL             C, D, E, H
CCCCC REAL             ETA, RESDF, RMS, RSS, SD, TOL, U, WC, WW, YINC
CCCCC REALCCCCC        SPDIV, DPCON, SPSQRT
C
CCCCC THE FOLLOWING LINE WAS CORRECTED      NOVEMBER 1989
CCCCC SPLIT INTO 2 LINES
CCCCC AND CHANGED DIMENSION (1) TO (MAXOBV) (SEE BELOW)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC DOUBLE PRECISION DX(1)
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION SUM
CCCCC THE FOLLOWING 2 LINES WERE ADDED    SEPTEMBER 1995
      DOUBLE PRECISION SNEG
      DOUBLE PRECISION SPOS
C
      REAL             A(*), B(*), F(*), P(*), Q(*), R(*), S(*)
CCCCC REAL             T(*), V(*), W(*), X(NR,M), Y(*), Z(*)
      REAL             T(*), V(*), W(*), X, Y(*), Z(*)
      REAL             C, D, E, H
      REAL             ETA, RESDF, RMS, RSS, SD, TOL, U, WC, WW, YINC
CCCCC REAL             SPDIV, DPCON, SPSQRT
C
      INCLUDE 'DPCOPA.INC'
CCCCC DIMENSION X(MAXOBV,MAXCMF)
      DIMENSION X(NR,*)
C
      EXTERNAL SCALE
      DIMENSION DX(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZD.INC'
      EQUIVALENCE (DGARBG(IDGAR1),DX(1))
CCCCC END CHANGE
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-----------------------------------------------------
C
      DATA RMXINT / 134217727. /
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,2001)
 2001   FORMAT('AT START OF LSQ ROUTINE')
        CALL DPWRST('XXX','BUG ')
        DO2000I=1,N
          WRITE(ICOUT,2011)(X(I,J),J=1,MAX(M,5))
 2011     FORMAT('I,J,(X(I,J),J=1,MAX(M,5)) = ',2I5,5G15.7)
          CALL DPWRST('XXX','BUG ')
 2000   CONTINUE
      ENDIF
      ID = 0
      NN  = N
      MM  = M
      WC = H
      U   = 0.0
C
C     SET VALUE OF ETA, A MACHINE-DEPENDENT PARAMETER.
C        ETA IS THE SMALLEST POSITIVE REAL NUMBER FOR WHICH 1.0 + ETA IS
C        GREATER THAN 1.0 IN FLOATING-POINT ARITHMETIC.
C        THE VALUE ETA = 2.**(-26) IS APPROPRIATE FOR THE UNIVAC 1108.
C
CCCCC ETA = SPDIV (RMXINT,2.0,IRR) + 1.0
      CALL  SPDIV (RMXINT,2.0,IRR,RESULT)
      ETA = RESULT + 1.0
CCCCC ETA = SPDIV (1.0,ETA,IND)
      CALL  SPDIV (1.0,ETA,IND,ETA)
C
C     SET VALUE OF TOL, A TOLERANCE USED IN DETERMINING THE RANK OF THE
C        SYSTEM OF EQUATIONS.
C
C     EMPIRICAL EVIDENCE SUGGESTS THAT TOL SHOULD BE CHOSEN NO SMALLER
C        THAN N*ETA.
C
      TOL = FLOAT (NN) * ETA
C
C     SET SCALE PARAMETER, ISCALE, EQUAL TO ZERO.
C        ISCALE = 0 INDICATES THAT A SOLUTION IS SOUGHT WITHOUT SCALING
C        THE INPUT DATA.
C
C     IN THE EVENT THAT THE ALGORITHM FAILS TO OBTAIN A SOLUTION WITH
C        UNSCALED DATA, ISCALE IS THEN SET EQUAL TO 1 AND ANOTHER
C        ATTEMPT IS C        ATTEMPT IS MADE TO OBTAIN A SOLUTION WITH THE DATA
C
      ISCALE = 0
      MP1 = MM + 1
C
C     SET UP MATRIX Q, INPUT FOR SUBROUTINES SCALE AND PDECOM.
C
  10  IF (IT.EQ.2) GO TO 50
C
C     CALL SUBROUTINE SCALE TO COMPUTE MEAN OF X-VECTOR (DENOTED BY U)
C        FOR POLYNOMIAL TYPE PROBLEMS, IF DATA ARE TO BE SCALED.
C
      IF (ISCALE.EQ.1) THEN
        CALL SCALE (ISCALE,2,NN,MM,IT,NR,W,WC,X,U,Q,S,B,A,Z,R,F,IFAULT)
        IF (IFAULT.EQ.1) ID = 1
        IF(IBUGA3.EQ.'ON')THEN
          WRITE(ICOUT,2101)
 2101     FORMAT('AFTER FIRST CALL TO SCALE')
          CALL DPWRST('XXX','BUG ')
          DO2100I=1,N
            WRITE(ICOUT,2111)(X(I,J),J=1,MAX(M,5))
 2111       FORMAT('I,J,(X(I,J),J=1,MAX(M,5)) = ',2I5,5G15.7)
            CALL DPWRST('XXX','BUG ')
 2100     CONTINUE
        ENDIF
      ENDIF
C
      MM1 = MM - 1
      DO 40 I=1,NN
        K = MM * NN + I
        Q(K) = Y(I)
        Q(I) = 1.0
        IF (MM.EQ.1) GO TO 40
        DO 30 J=1,MM1
          K = (J) * NN + I
          Q(K) = (X(I,1) - U) ** (J)
  30    CONTINUE
  40  CONTINUE
C
      GO TO 80
C
  50  IF(ISCALE.EQ.1) GO TO 80
      DO 70 I=1,NN
        K = MM * NN + I
        Q(K) = Y(I)
        DO 60 J=1,MM
          K = (J-1) * NN + I
          Q(K) = X(I,J)
  60    CONTINUE
  70  CONTINUE
C
C     CALL SUBROUTINE SCALE TO COMPUTE VECTOR NORMS AND TO SET VALUES OF
C        SCALE FACTORS (F).
C
  80  CONTINUE
      CALL SCALE (ISCALE,1,NN,MM,IT,NR,W,WC,X,U,Q,S,B,A,Z,R,F,
     1            IFAULT)
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,2201)
 2201   FORMAT('AT START OF LSQ ROUTINE')
        CALL DPWRST('XXX','BUG ')
        DO2200I=1,N
          WRITE(ICOUT,2211)(X(I,J),J=1,MAX(M,5))
 2211     FORMAT('I,J,(X(I,J),J=1,MAX(M,5)) = ',2I5,5G15.7)
          CALL DPWRST('XXX','BUG ')
 2200   CONTINUE
      ENDIF
C
C     IFAULT IS SET EQUAL TO ONE IN SUBROUTINE SCALE WHEN A COLUMN OF
C        MATRIX X IS FOUND TO EQUAL ZERO.
C
      IF (IFAULT.EQ.1) GO TO 240
C
C     CALL SUBROUTINE PDECOM TO OBTAIN AN ORTHOGONAL QR-DECOMPOSITION OF
C        THE MATRIX CONTAINED IN Q ON ENTRY TO PDECOM.  ON RETURN FROM
C        PDECOM, M1 IS THE COMPUTED RANK OF THE SYSTEM OF EQUATIONS.
C        IF MATRIX Q IS FOUND TO BE SINGULAR, IS = 0 ON RETURN FROM
C        PDECOM.  OTHERWISE, IS = 1.
C
      CALL PDECOM (NN,MP1,TOL,W,WC,IS,M1,Q,T,R)
CCCCC APRIL 2002: PRINT WARNING MESSAGE FOR POTENTIAL SINGULARITY
C
      IF(IS.EQ.1)THEN
        WRITE(ICOUT,99)
   99   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1001)
 1001   FORMAT('***** WARNING: POTENTIAL SINGULARITY FROM (LINEAR) ',
     1         'FIT DETECTED.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1003)
 1003   FORMAT('      POTENTIAL CAUSES OF SINGULARITY INCLUDE:')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1005)
 1005   FORMAT('      1. A COLUMN IN THE X MATRIX CONTAINS ALL THE ',
     1         'SAME VALUES.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1007)
 1007   FORMAT('      2. TWO COLUMNS IN THE X MATRIX ARE EQUAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1009)
 1009   FORMAT('      3. A MORE COMPLICATED LINEAR DEPENDENCY EXISTS ',
     1         'BETWEEN')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1010)
 1010   FORMAT('         BETWEEN THE COLUMNS IN THE X MATRIX.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1011)
 1011   FORMAT('      FOR MULTI-LINEAR FITS, DATAPLOT CHECKS FOR THE ',
     1         'FIRST TWO CAUSES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1012)
 1012   FORMAT('      FOR SINGULARITY.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1013)
 1013   FORMAT('      RECOMMENDED FIX: PERFORM THE FIT AFTER REMOVING ',
     1         'ONE OR MORE OF')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1014)
 1014   FORMAT('      ONE OR MORE OF THE INDEPENDENT VARIABLES.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF (IS.EQ.0) GO TO 100
      IF (M1.GT.0) GO TO 90
      GO TO 240
C
C     ..................................................................
C
  90  IF (M1.EQ.MM) GO TO 100
      IF (ISCALE.EQ.1) GO TO 240
      ISCALE = 1
      GO TO 10
 100  IR = ISCALE
C
C     TRANSFER T(J) TO ARRAY R SO THAT T IS AVAILABLE FOR WORK AREA.
C
      DO 110 I=1,MP1
CCCCC   LD = IDIV (2*(I-1)*MP1-I*(I-3),2,IRR)
        CALL IDIV (2*(I-1)*MP1-I*(I-3),2,IRR,LD)
        R(LD) = T(I)
 110  CONTINUE
C
C     CALL SUBROUTINE SLVE TO OBTAIN THE SOLUTION (COEFFICIENTS AND
C        RESIDUALS) OF THE LEAST SQUARES PROBLEM.  ITERATIVE REFINEMENT
C        IS USED TO IMPROVE (IF POSSIBLE) THE ACCURACY OF THE
C        INITIAL SOLUTION.  ON RETURN FROM SLVE, PARAMETER IR = 0 IF THE
C        ITERATIVE REFINEMENT PROCEDURE CONVERGED TO A SOLUTION.
C        OTHERWISE, IR = 1.
C
      CALL SLVE (NN,MM,NR,X,Y,W,WC,IT,ETA,F,U,Q,T,R,IR,B,P,Z,V,S,NI)
CCCCC THE FOLLOWING WRITE SECTION WAS ACTIVATED   SEPTEMBER 1995
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,771)
  771    FORMAT(1H ,'*****FROM LSQ, AFTER 1ST CALL TO SLVE--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,772)E
  772    FORMAT('AFTER 120--E = ',E15.7)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      D = V(1)
C
      IF (IR.EQ.0) GO TO 130
      IF (ISCALE.EQ.1) GO TO 120
      ISCALE = 1
      GO TO 10
 120  CONTINUE
CCCCC THE FOLLOWING LINE WAS ACTIVATED   SEPTEMBER 1995
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,773)ISCALE
  773    FORMAT('FROM LSQ, AFTER 120--ISCALE = ',I8)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C     GO TO 240
      ID =2
      RETURN
C
C     COMPUTATIONS NEEDED FOR COMPUTING ACCURATE DIGITS.
C        SUBROUTINE SLVE IS NOW CALLED TO OBTAIN A VECTOR OF
C        COEFFICIENTS (A) BY FITTING PREDICTED VALUES (Y - Z) INSTEAD OF
C        THE ORIGINAL OBSERVATIONS (Y).  A COMPARISON OF VECTOR B WITH
C        VECTOR A IS USED TO ASSESS THE ACCURACY OF VECTOR B.
C        THIS CALL TO SLVE IS OMITTED WHENEVER --
C           L1 = 24  (TWOWAY)
C           L2 =  2  (SPOLYFIT)
C           L2 =  4  (SFIT)
C
C130  IF (L1.EQ.24) GO TO 140
C     IF (L2.EQ.2.OR. L2.EQ.4) GO TO 140
C
 130  IZ  = ISCALE
      ITT = IT + 2
C
      CALL SLVE (NN,MM,NR,X,Y,W,WC,ITT,ETA,F,U,Q,T,R,IZ,A,Z,P,V,S,NJ)
CCCCC THE FOLLOWING WRITE SECTION WAS ACTIVATED   SEPTEMBER 1995
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,775)
  775    FORMAT(1H ,'*****FROM LSQ, AFTER 2ND CALL TO SLVE--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,776)IZ,ID,E
  776    FORMAT('AFTER 120--IZ,ID,E = ',2I8,E15.7)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (IZ.EQ.0) GO TO 140
      ID = 2
      RETURN
C
C     ..................................................................
C
C     COMPUTE SQUARED FOURIER COEFFICIENTS (S) NEEDED FOR ANALYSIS OF
C        VARIANCE.
C
 140  L = MP1
      DO 150 J=1,MM
CCCCC   LD = IDIV (2*(J-1)*(MM+1)-J*J+3*J,2,IRR)
       CALL IDIV  (2*(J-1)*(MM+1)-J*J+3*J,2,IRR,LD)
        S(J) = R(LD) * R(L)**2
        L = L + MP1 - J
 150  CONTINUE
C
C     CALL SUBROUTINE SCALE TO ADJUST RESIDUALS (Z) AND SQUARED
C        FOURIER COEFFICIENTS (S) FOR SCALING, IF DATA WERE SCALED.
C
      IF (ISCALE.EQ.1) THEN
      CALL SCALE (ISCALE,3,NN,MM,IT,NR,W,WC,X,U,Q,S,B,A,Z,R,F,IFAULT)
      IF (IFAULT.EQ.1) GO TO 420
      ENDIF
C     ADJUST THE FIRST SQUARED FOURIER COEFFICIENT IF Y MID-RANGE WAS
C        SUBTRACTED FROM Y-VECTOR.  IN THIS CASE C IS NONZERO.
C
      YINC = C
CCCCC IF (YINC.NE.0.0) S(1) = R(1) * ( SPDIV(R(MP1),F(MP1),IND) +
CCCCC1  SPDIV(YINC,F(1),IRR) )**2
      IF(YINC.NE.0.0)CALL SPDIV(R(MP1),F(MP1),IND,RESUL1)
      IF(YINC.NE.0.0)CALL SPDIV(YINC,F(1),IRR,RESUL2)
      IF(YINC.NE.0.0)S(1)=R(1)*(RESUL1+RESUL2)**2
C
C     COMPUTE RESIDUAL SUM OF SQUARES (E) AND RESIDUAL STANDARD
C        DEVIATION (SD).
C
      CALL DSUMAL (DX,0,SNEG,SPOS,SUM)
      WW = WC
      DO 160 I=1,NN
        IF (WC.LE.0.0) WW = W(I)
        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
           WRITE(ICOUT,871)I,WC,WW
  871      FORMAT('FROM LSQ,160--I,WC,WW = ',I8,2E15.7)
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,872)I,Z(I),SUM
  872      FORMAT('FROM LSQ,160--I,Z(I),SUM = ',I8,E15.7,D15.7)
           CALL DPWRST('XXX','BUG ')
        ENDIF
        DX(1) = DBLE (Z(I)**2) * DBLE (WW)
        CALL DSUMAL (DX,-1,SNEG,SPOS,SUM)
 160  CONTINUE
      CALL DSUMAL (DX,1,SNEG,SPOS,SUM)
CCCCC RSS = DPCON (SUM)
      CALL  DPCON (SUM,RSS)
C
      IF (NN.EQ.MM) GO TO 170
      GO TO 180
C
 170  RMS = 0.0
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,873)NN,MM,RSS,WC
  873    FORMAT('FROM LSQ,170--NN,MM,RSS,WC = ',2I8,2E15.7)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      GO TO 210
C
 180  NOZWTS = 0
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,874)NN,MM,RSS,WC
  874    FORMAT('FROM LSQ,180--NN,MM,RSS,WC = ',2I8,2E15.7)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (WC.GT.0.0) GO TO 200
      DO 190 I=1,NN
        IF (W(I).NE.0.0) GO TO 190
        NOZWTS = NOZWTS + 1
 190  CONTINUE
 200  RESDF = NN - MM - NOZWTS
CCCCC RMS = SPDIV (RSS,RESDF,IRR)
      CALL  SPDIV (RSS,RESDF,IRR,RMS)
C210  SD = SPSQRT (RMS)
 210  CONTINUE
      CALL SPSQRT (RMS,RESULT)
      SD=RESULT
      E = RSS
C
C     CALL SUBROUTINE SDPRED TO COMPUTE STANDARD DEVIATION OF PREDICTED
C        VALUES (V).
C
      CALL SDPRED (NN,MM,R,Q,T,SD,V)
C
C     CALL SUBROUTINE PINVRT TO OBTAIN THE INVERSE OF (X-TRANSPOSE)*W*X
C        USING RESULTS FROM PDECOM (MATRIX R) AS INPUT.
C
C     MATRIX R IS OVERWRITTEN AND WILL EQUAL THE DESIRED INVERSE UPON
C        RETURN TO SUBROUTINE LSQ.
C
C     SINCE THE INVERSE MATRIX IS SYMMETRIC, ONLY THE PORTION ON OR
C        ABOVE THE PRINCIPAL DIAGONAL IS STORED.  COMMENTS AT THE
C        BEGINNING OF SUBROUTINE PINVRT GIVE FURTHER DETAILS.
C
      CALL PINVRT (MM,R,T)
C
C     CALL SUBROUTINE SCALE TO ADJUST COEFFICIENTS (B AND A) AND
C        COVARIANCE MATRIX (R) FOR SCALING, IF DATA WERE SCALED.
C
      IF (ISCALE.EQ.1) THEN
      CALL SCALE (ISCALE,4,NN,MM,IT,NR,W,WC,X,U,Q,S,B,A,Z,R,F,IFAULT)
      IF (IFAULT.EQ.1) GO TO 420
      ENDIF
C
C     COMPUTE STANDARD DEVIATIONS OF COEFFICIENTS (T).
C
      DO 230 I=1,MM
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LSQ')THEN
         WRITE(ICOUT,777)I,R(I),RMS,RESDF,RSS
  777    FORMAT('FROM LSQ,230--I,R(I),RMS,RESDF,RSS = ',I8,4E15.7)
         CALL DPWRST('XXX','BUG ')
      ENDIF
CCCCC   L = IDIV  (2*(I-1)*MM-I*I+3*I,2,IRR)
        CALL IDIV (2*(I-1)*MM-I*I+3*I,2,IRR,L)
        IF (R(L).GE.0.0) GO TO 220
        R(L) = 0.0
C220    T(I) = SPSQRT (R(L)*RMS)
 220    CONTINUE
        CALL   SPSQRT (R(L)*RMS,RESULT)
        T(I) = RESULT
 230  CONTINUE
C
C     SET VALUE OF ID.
 240  ID=NI
      RETURN
C
 420  ID = 1
C     IF (ISCALE.EQ.0) ID = - ID
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----SCALE--------------------------------------
      SUBROUTINE SCALE (IS,NC,N,M,IT,NR,W,WC,X,U,Q,SS,B,A,Z,R,SF,IFT)
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     SUBROUTINE SCALE SCALES THE MATRIX Q IN ORDER TO MITIGATE THE
C        ROUNDING ERROR PROBLEMS WHICH CAN OCCUR IN CONNECTION WITH
C        SOLVING ILL-CONDITIONED SYSTEMS OF EQUATIONS.  THIS IS DONE BY
C        MULTIPLYING EACH COLUMN OF Q BY ITS APPROPRIATE SCALE FACTOR SO
C        THAT THE COLUMNS OF THE SCALED MATRIX ALL HAVE UNIT LENGTH.  IN
C        THE CASE OF POLYNOMIAL TYPE PROBLEMS, THE MEAN OF THE X-VECTOR
C        IS COMPUTED SO THAT IT CAN BE SUBTRACTED FROM EACH ELEMENT OF
C        X WHENEVER POWERS OF X ARE GENERATED (IN SUBROUTINES LSQ AND
C        SLVE).  AFTER A SOLUTION IS OBTAINED FOR A SCALED PROBLEM, THE
C        COEFFICIENTS, RESIDUALS, SQUARED FOURIER COEFFICIENTS AND
C        COVARIANCE MATRIX MUST BE ADJUSTED TO ACCOUNT FOR SCALING.
C
C     REFERENCE --
C        A. BJORCK, COMMENT ON THE ITERATIVE REFINEMENT OF LEAST-SQUARES
C        SOLUTIONS, JOURNAL OF THE AMERICAN STATISTICAL ASSOCIATION,
C        VOL. 73 (1978), PP. 161-166.
C
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG, MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO (*) (AND MOVE)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
C
C
CCCCC THE FOLLOWING 5 LINES WERE MOVED       NOVEMBER 1989
CCCCC AND CHANGED DIMENSION (1) TO (*)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             A(1), B(1), Q(1), R(1), SF(1), SS(1)
CCCCC REALCCCCC        W(1), X(NR,1), Z(1)
CCCCC REAL             W(1), X, Z(1)
CCCCC REAL             U, WC
CCCCC REAL             VNORM2, WW
C
CCCCC REAL             SPDIV, DPCON
C
      DOUBLE PRECISION DSUM
CCCCC DOUBLE PRECISION DPDIV, DPSQRT
      DOUBLE PRECISION DRESUL
C
      REAL             A(*), B(*), Q(*), R(*), SF(*), SS(*)
CCCCC REAL             W(1), X(NR,1), Z(1)
      REAL             W(*), X, Z(*)
      REAL             U, WC
      REAL             VNORM2, WW
C
CCCCC INCLUDE 'DPCOPA.INC'
CCCCC DIMENSION X(MAXOBV,MAXCMF)
      DIMENSION X(NR,*)
C
C     ==================================================================
C
      MP1 = M + 1
      IFT = 0
CCCCC TEMPORARY CHANGE OF NCC TO NC AS SUGGESTED BY RUTH VARNER MAY 1989
CCCCC GO TO (10,80,100,130), NCC
      GO TO (10,80,100,130), NC
  10  IF (IS.EQ.1) GO TO 30
C
C     IS = 0.  SET SF(I) = 1.0 FOR I=1,...,M+1.
C
      DO 20 I=1,MP1
        SF(I) = 1.0
  20  CONTINUE
      RETURN
C
C     ..................................................................
C
C     IS = 1.  COMPUTE VECTOR NORMS.
C                  COMPUTE SCALE FACTORS (SF).
C                  SCALE MATRIX Q.
C
  30  WW = WC
      DO 70 J=1,MP1
        DSUM = 0.0D0
        K = (J-1) * N + 1
        DO 40 I=1,N
          IF (WC.LE.0.0) WW = W(I)
          DSUM = DSUM + DBLE (Q(K)) * DBLE (Q(K)) * DBLE (WW)
          K = K + 1
  40    CONTINUE
CCCCC   DSUM   = DPSQRT (DSUM)
        CALL     DPSQRT (DSUM,DRESUL)
        DSUM   = DRESUL
CCCCC   VNORM2 = DPCON (DSUM)
        CALL     DPCON (DSUM,VNORM2)
C
C       VECTOR NORMS COULD BE SAVED HERE, IF DESIRED.
C
        IF (VNORM2.GT.0.0) GO TO 50
        IFT = 1
C
C       IFT = 1 INDICATES ERROR RETURN.
C
        RETURN
C
C     ..................................................................
C
CC50    SF(J) = SPDIV (1.0,VNORM2,IRR)
   50 CONTINUE
        CALL    SPDIV (1.0,VNORM2,IRR,SF(J))
C
C       SCALE MATRIX Q.
C
        K = (J-1) * N + 1
        DO 60 I=1,N
          Q(K) = Q(K) * SF(J)
          K    = K + 1
  60    CONTINUE
  70  CONTINUE
      RETURN
C
C     ..................................................................
C
C     COMPUTE MEAN OF X VECTOR (DENOTED BY U) FOR POLYNOMIAL TYPE
C        PROBLEMS.
C
  80  DSUM = 0.0D0
      NW   = 0
      DO 90 I=1,N
        L    = L + 1
        IF (WC.LE.0.0 .AND. W(I).EQ.0.0) GO TO 90
        NW   = NW + 1
        DSUM = DSUM + DBLE (X(I,1))
  90  CONTINUE
CCCCC U = DPCON (DPDIV (DSUM,DBLE (FLOAT (NW)),IRR))
      CALL        DPDIV (DSUM,DBLE (FLOAT (NW)),IRR,DRESUL)
CCCCC U = DPCON (DRESUL)
      CALL DPCON (DRESUL,U)
      RETURN
C
C     ..................................................................
C
C     ADJUST SQUARED FOURIER COEFFICIENTS (SS) AND RESIDUALS (Z) FOR
C        SCALING.
C
 100   DO 110 J=1,M
CCCCC   SS(J) = SPDIV (SS(J),SF(MP1)*SF(MP1),IRR)
        CALL    SPDIV (SS(J),SF(MP1)*SF(MP1),IRR,SS(J))
 110  CONTINUE
C
      DO 120 I=1,N
CCCCC   Z(I) = SPDIV (Z(I),SF(MP1),IRR)
        CALL   SPDIV (Z(I),SF(MP1),IRR,Z(I))
 120  CONTINUE
      RETURN
C
C     ..................................................................
C
C     ADJUST COEFFICIENTS (B AND A) AND COVARIANCE MATRIX (R) FOR
C        SCALING.
C
 130  DO 140 J=1,M
CCCCC   B(J) = SPDIV (B(J) * SF(J),SF(MP1),IRR)
        CALL   SPDIV (B(J) * SF(J),SF(MP1),IRR,B(J))
CCCCC   A(J) = SPDIV (A(J) * SF(J),SF(MP1),IRR)
        CALL   SPDIV (A(J) * SF(J),SF(MP1),IRR,A(J))
 140  CONTINUE
      L = 0
      DO 160 I=1,M
        DO 150 J=I,M
          L    = L + 1
          R(L) = R(L) * SF(I) * SF(J)
 150    CONTINUE
 160  CONTINUE
      IF (IT.EQ.2) RETURN
C
C     ..................................................................
C
C     COMPLETE ADJUSTMENTS OF B, A AND R FOR SCALING IN POLYNOMIAL TYPE
C        PROBLEMS.
C     REFERENCE --
C        G. A. F. SEBER, LINEAR REGRESSION ANALYSIS (1977), THEOREM
C        1.4 AND COROLLARIES, PAGES 10-11.
C
      K = 0
      DO 180 I=1,M
        DO 170 J=I,M
          K = K + 1
          L = (I - 1) * M + J
          Q(L) = R(K)
          IF (I.EQ.J) GO TO 170
          L = (J - 1) * M + I
          Q(L) = R(K)
 170    CONTINUE
 180  CONTINUE
      DO 250 I=1,M
        SF(I) = 1.0
        IP1   = I + 1
        IF (IP1.GT.M) GO TO 200
        DO 190 J=IP1,M
CCCCC     SF(J) = DPCON (-DPDIV (DBLE(FLOAT(J-1)),DBLE(FLOAT(J-I)),IND)
CCCCC1    * DBLE (SF(J-1)) * DBLE (U) )
          CALL   DPDIV (DBLE(FLOAT(J-1)),DBLE(FLOAT(J-I)),IND,DRESUL)
CCCCC     SF(J) = DPCON (-DRESUL)
CCCCC1    * DBLE (SF(J-1)) * DBLE (U)
          CALL    DPCON (-DRESUL,RESULT)
          SF(J) = RESULT
     1    * DBLE (SF(J-1)) * DBLE (U)
 190    CONTINUE
 200    DSUM = 0.0D0
        DO 210 J=I,M
          DSUM = DSUM + DBLE (SF(J)) * DBLE (B(J))
 210    CONTINUE
        B(I) = DSUM
        DSUM = 0.0D0
        DO 220 J=I,M
          DSUM = DSUM + DBLE (SF(J)) * DBLE (A(J))
 220    CONTINUE
        A(I) = DSUM
        DO 240 J=I,M
          DSUM = 0.0D0
          DO 230 K=I,M
            L = (K-1)*M + J
            DSUM = DSUM + DBLE (SF(K)) * DBLE (Q(L))
 230      CONTINUE
          L    = (I - 1) * M + J
          Q(L) = DSUM
 240    CONTINUE
 250  CONTINUE
      DO 300 J=1,M
        SF(J) = 1.0
        IP1   = J + 1
        IF (IP1.GT.M) GO TO 270
        DO 260 I=IP1,M
CCCCC     SF(I) = DPCON (-DPDIV (DBLE(FLOAT(I-1)),DBLE(FLOAT(I-J)),IND)
CCCCC1    * DBLE (SF(I-1)) * DBLE (U) )
          CALL   DPDIV (DBLE(FLOAT(I-1)),DBLE(FLOAT(I-J)),IND,DRESUL)
CCCCC     SF(I) = DPCON (-DRESUL)
CCCCC1    * DBLE (SF(I-1)) * DBLE (U)
          CALL    DPCON (-DRESUL,RESULT)
          SF(I) = RESULT
     1    * DBLE (SF(I-1)) * DBLE (U)
 260    CONTINUE
 270    DO 290 I=1,J
          DSUM = 0.0D0
          DO 280 K=J,M
            L    = (I - 1) * M + K
            DSUM = DSUM + DBLE (Q(L)) * DBLE (SF(K))
 280      CONTINUE
          L    = (I - 1) * M + J
          Q(L) = DSUM
 290    CONTINUE
 300  CONTINUE
      K = 0
      DO 320 I=1,M
        DO 310 J=I,M
          K    = K + 1
          L    = (I - 1) * M + J
          R(K) = Q(L)
 310    CONTINUE
 320  CONTINUE
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----PDECOM--------------------------------------
      SUBROUTINE PDECOM (KN,KM,TOL,W,WCC,ISING,M1,Q,D,R)
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     SUBROUTINE PDECOM USES A MODIFIED GRAM-SCHMIDT ALGORITHM TO OBTAIN
C        AN ORTHOGONAL QR-DECOMPOSITION OF THE INPUT MATRIX GIVEN IN Q.
C
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GSITHERSBURG, MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO (*) (AND MOVE)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
C
CCCCC THE FOLLOWING 3 LINES WERE MOVED        NOVEMBER 1989
CCCCC AND DIMENSION (1) CHANGED TO DIMENSION (*)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             D(1), Q(1), R(1), W(1)
CCCCC REAL             TOL, WCC
CCCCC REAL             DMAX, DS, RSJ, TOL2, WW
C
CCCCC REAL             SPDIV, DPCON
C
      DOUBLE PRECISION DSUM
C
      REAL             D(*), Q(*), R(*), W(*)
      REAL             TOL, WCC
      REAL             DMAX, DS, RSJ, TOL2, WW
C
C     ==================================================================
C
      WW    = WCC
      ISING = 1
      M     = KM
      N     = KN
      M1    = 0
CCCCC M2 = IDIV (M*(M+1),2,IRR)
      CALL IDIV (M*(M+1),2,IRR,M2)
      DO 10 J=1,M
        D(J) = 0.0
  10  CONTINUE
C
      DO 20 L=1,M2
        R(L) = 0.0
  20  CONTINUE
C
      TOL2 = TOL * TOL
      DMAX = 0.0
      DO 110 I=1,M
C
C     STEP NUMBER I IN THE DECOMPOSITION.
C
        DSUM = 0.0D0
        DO 30 L=1,N
          IF (WCC.LE.0.0) WW = W(L)
          J = (I-1) * N + L
          DSUM = DSUM + DBLE (Q(J)) * DBLE (Q(J)) * DBLE (WW)
  30    CONTINUE
C
CCCCC   D(I) = DPCON (DSUM)
        CALL   DPCON (DSUM,D(I))
        DS = D(I)
        IF (I.GT.1) GO TO 40
        DMAX = D(1)
        GO TO 50
C
  40    IF (DS.GT.DMAX) DMAX = D(I)
  50    DO 60 J=1,I
          IF (D(J).LE.TOL2*DMAX) RETURN
  60    CONTINUE
C
        IF (DS.EQ.0.0) RETURN
        IPLUS1 = I + 1
        IF (IPLUS1.GT.M) GO TO 100
C
C     BEGIN ORTHOGONALIZATION.
C
CCCCC   LD = IDIV (2*(I-1)*M-I*I+3*I,2,IRR)
        CALL IDIV (2*(I-1)*M-I*I+3*I,2,IRR,LD)
        K = 1
        DO 90 J=IPLUS1,M
          DSUM = 0.0D0
          DO 70 L=1,N
            IF (WCC.LE.0.0) WW = W(L)
            LS = (I-1) * N + L
            LJ = (J-1) * N + L
            DSUM = DSUM + DBLE(Q(LS)) * DBLE(Q(LJ)) * DBLE (WW)
  70      CONTINUE
C
          L = LD + K
CCCCC     R(L) = DPCON (DSUM)
          CALL   DPCON (DSUM,R(L))
CCCCC     R(L) = SPDIV (R(L),DS,IRR)
          CALL   SPDIV (R(L),DS,IRR,R(L))
          RSJ  = R(L)
          K    = K + 1
          JJ   = (J-1) * N + 1
          JS   = (I-1) * N + 1
          DO 80 L=1,N
            Q(JJ) = Q(JJ) - RSJ * Q(JS)
            JJ    = JJ + 1
            JS    = JS + 1
  80      CONTINUE
C
  90    CONTINUE
C
C     END ORTHOGONALIZATION.
C
 100    M1 = I
        IF (I.EQ.M-1) ISING = 0
 110  CONTINUE
C
C     END STEP NUMBER I.
C
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----SLVE--------------------------------------
      SUBROUTINE SLVE (N,M,NR,X,Y,W,WA,IT,E,S,U,Q,D,A,K,B,R,Z,F,G,NI)
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     SUBROUTINE SLVE COMPUTES THE SOLUTION (COEFFICIENTS AND RESIDUALS)
C        OF THE LEAST SQUARES PROBLEM.  ITERATIVE REFINEMENT IS USED TO
C        IMPROVE (IF POSSIBLE) THE ACCURACY OF THE INITIAL SOLUTION.
C
C     SUBROUTINE SLVE IS GENERALLY CALLED TWICE FROM SUBROUTINE LSQ.
C        IN THE FIRST CALL, THE OBSERVATIONS (Y) ARE FITTED.  LET R
C           DENOTE THE RESIDUALS FROM THIS FIT.
C        IN THE SECOND CALL, THE PREDICTED VALUES (Y - R) ARE FITTED.
C           THE COEFFICIENTS OBTAINED FROM THIS FIT WILL BE USED IN
C           ASSESSING THE ACCURACY OF THE COEFFICIENTS FROM THE FIRST FIT.
C
C *   CONVERSION OF THE PROGRAM TO STRICTLY DOUBLE PRECISION, AND      *
C *   CONVERSION OF THE PROGRAM TO STRICTLY SINGLE PRECISION.          *
C *      ON COMPUTERS HAVING SHORT WORD LENGTH (AS THE IBM 360/370)    *
C *      IT MAY BE DESIRABLE TO PERFORM ALL CALCULATIONS IN DOUBLE     *
C *      PRECISION.  ON COMPUTERS HAVING LONG WORD LENGTH (AS THE CDC  *
C *      6600) IT MAY BE DESIRABLE TO PERFORM ALL CALCULATIONS IN      *
C *      SINGLE PRECISION.  IN SUCH CASES, THE ITERATIVE REFINEMENT    *
C *      PRESENTLY INCLUDED IN SUBROUTINE SLVE SHOULD BE OMITTED.      *
C *                                                                    *
C *      THE SIMPLEST WAY TO OBTAIN THE EFFECT OF OMITTING THE         *
C *      ITERATIVE REFINEMENT (WITHOUT ACTUALLY DOING SO) IS TO CHANGE *
C *      THE ONE STATEMENT WHICH PRESENTLY READS                       *
C *        310  K = 1 (USE THIS FOR 64-BIT MACHINES)                *
C *      TO READ                                                       *
C *        310  K = 0 (USE THIS FOR 32-BIT MACHINES)               *
C *                                                                    *
C *      TO ACTUALLY OMIT THE ITERATIVE REFINEMENT THE FOLLOWING       *
C *      APPROACH MAY BE USED.                                         *
C *      1. OMIT USAGE OF E, ETA2, RNB, RNDB1, RNDB2, RNDR1, RNDR2,    *
C *         RNR, AND SPCA FROM SUBROUTINE, REAL, AND DATA STATEMENTS.  *
C *      2. ATTACH LABEL  30  TO THE STATEMENT WHICH PRESENTLY READS   *
C *               DO 50 I=1,KN                                         *
C *      3. INSERT A STATEMENT READING                                 *
C *               GO TO 320                                            *
C *         IMMEDIATELY BEFORE THE STATEMENT WHICH PRESENTLY READS     *
C *          160  DO 210 ISX=1,KM                                      *
C *      4. OMIT THE FOUR BLOCKS OF STATEMENTS WHICH ARE SET OFF IN    *
C *         THE FOLLOWING MANNER --                                    *
C *                                                                    *
C BLOCK I ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C               (STATEMENTS TO BE OMITTED)
C
C BLOCK I (END) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C *                                                                    *
C *         BLOCK 1 CONTAINS  3 STATEMENTS (EXCLUDING COMMENTS).       *
C *         BLOCK 2 CONTAINS 10 STATEMENTS (EXCLUDING COMMENTS).       *
C *         BLOCK 3 CONTAINS 22 STATEMENTS (EXCLUDING COMMENTS).       *
C *         BLOCK 4 CONTAINS  4 STATEMENTS (EXCLUDING COMMENTS).       *
C *                                                                    *
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG, MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO (*) (AND MOVED)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
CCCCC THE FOLLOWING 9 LINES WERE MOVED      NOVEMBER 1989
CCCCC AND CHANGED DIMENSION (1) TO (*)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             A(1), B(1), D(1), F(1), G(1), Q(1)
CCCCC REALCCCCC        R(1), S(1), W(1), X(NR,M), Y(1), Z(1)
CCCCC REAL             R(1), S(1), W(1), X, Y(1), Z(1)
CCCCC REAL             E, U, WA
CCCCC REAL             C, ETA2, DIGITS, DXNORM
CCCCC REAL             RNB, RNDB1, RNDB2, RNDR1, RNDR2
CCCCC REAL             RNR, WC, WW, XNORM
CCCCC REALCCCCC        SPDIV, DPCON, SPLO10, SPSQRT
CCCCC REAL             SPCA
C
      DOUBLE PRECISION DX, DSUM, DY
C
      REAL             A(*), B(*), D(*), F(*), G(*), Q(*)
CCCCC REAL             R(*), S(*), W(*), X(NR,M), Y(*), Z(*)
      REAL             R(*), S(*), W(*), X, Y(*), Z(*)
      REAL             E, U, WA
      REAL             C, ETA2, DIGITS, DXNORM
      REAL             RNB, RNDB1, RNDB2, RNDR1, RNDR2
      REAL             RNR, WC, WW, XNORM
CCCCC REAL             SPDIV, DPCON, SPLO10, SPSQRT
      REAL             SPCA
C
CCCCC INCLUDE 'DPCOPA.INC'
      DIMENSION X(NR,*)
C
C     ==================================================================
C
C                 ***   DATA INITIALIZATION STATEMENTS   ***
C
      DATA SPCA / 64.0 /
C
C     ==================================================================
C
C     SET ISWAD = 0 IF COEFFICIENTS FOR ACCURATE DIGITS ARE NOT BEING
C                   COMPUTED.
C     SET ISWAD = 1 IF COEFFICIENTS FOR ACCURATE DIGITS ARE BEING
C                   COMPUTED.
C
      ISWAD = 0
      IF (IT.GT.2) ISWAD = 1
      KN = N
      KM = M
      MN = KM * KN
      WC = WA
      ITYP   = IT
      IF (ITYP.GT.2) ITYP = ITYP - 2
      MPLUS1 = KM + 1
      DIGITS = 0.0
C
C BLOCK 1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
CCCCC ITMAX = INT (-SPLO10(E)) - 2   JUNE 1987
      CALL SPLO10(E,RESULT)
      ITMAX = INT (-RESULT)    - 2
      IF (K.EQ.1) ITMAX = ITMAX + 3
      ETA2 = E * E
C
C BLOCK 1 (END) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     USE ELEMENTS M*N+1, M*N+2, ..., M*N+N OF ARRAY Q AS WORK AREA.
C
CCCCC IF (WC.GT.0.0) WW = SPSQRT(WC)
      IF (WC.GT.0.0) CALL SPSQRT(WC,RESULT)
      IF (WC.GT.0.0) WW = RESULT
      DO 10 I=1,KN
CCCCC   IF (WC.LE.0.0) WW = SPSQRT(W(I))
        IF (WC.LE.0.0) CALL SPSQRT(W(I),RESULT)
        IF (WC.LE.0.0) WW = RESULT
        IF (ISWAD.EQ.0) F(I) = Y(I) * WW * S(MPLUS1)
CCCCC   IF (ISWAD.EQ.1 ) F(I) = (Y(I)-SPDIV(R(I),S(MPLUS1),IND)) * WW
CCCCC1                            * S(MPLUS1)
        IF (ISWAD.EQ.1 ) CALL         SPDIV(R(I),S(MPLUS1),IND,RESULT)
        IF (ISWAD.EQ.1 ) F(I) = (Y(I)-RESULT)                   * WW
     1                            * S(MPLUS1)
        J = MN + I
        Q(J) = 0.0
        Z(I) = 0.0
  10  CONTINUE
C
      DO 20 J=1,KM
        B(J) = 0.0
        G(J) = 0.0
  20  CONTINUE
C
      KI    = 0
      RNR   = 0.0
      RNB   = 0.0
      RNDB1 = 0.0
      RNDR1 = 0.0
C
C BLOCK 2 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      RNDB2 = 0.0
      RNDR2 = 0.0
C
C     BEGIN KI-TH ITERATION STEP.
C
  30  IF (KI.LT.2) GO TO 40
      IF (SPCA*RNDB2.LT.RNDB1 .AND. RNDB2.GT.ETA2*RNB .OR.
     1    SPCA*RNDR2.LT.RNDR1 .AND. RNDR2.GT.ETA2*RNR) GO TO 40
      GO TO 300
C
  40  RNDB1 = RNDB2
      RNDR1 = RNDR2
      RNDB2 = 0.0
      RNDR2 = 0.0
C
C BLOCK 2 (END) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IF (KI.EQ.0) GO TO 160
C
C     NEW RESIDUALS.
C
      DO 50 I=1,KN
CCCCC   IF (WC.LE.0.0) WW = SPSQRT(W(I))
        IF (WC.LE.0.0) CALL SPSQRT(W(I),RESULT)
        IF (WC.LE.0.0) WW = RESULT
               J = MN + I
        Q(J) = Q(J) + F(I) * WW
CCCCC   Z(I) = Z(I) + SPDIV (F(I),WW,IRR)
        CALL          SPDIV (F(I),WW,IRR,RESULT)
        Z(I) = Z(I) + RESULT
  50  CONTINUE
C
      DO 100 ISX=1,KM
        B(ISX) = B(ISX) + G(ISX)
        DSUM = 0.0D0
        IF (ITYP.EQ.2) GO TO 70
        DO 60 L=1,KN
          J  = MN + L
          DX = DBLE (Q(J)) * DBLE (S(ISX))
          IF (ISX.GT.1) DX = DX * DBLE(X(L,1)-U) ** (ISX-1)
          DSUM = DSUM + DX
  60    CONTINUE
        GO TO 90
C
  70    DO 80 L=1,KN
          J    = MN + L
          DSUM = DSUM + DBLE (Q(J)) * DBLE (X(L,ISX) * S(ISX))
  80    CONTINUE
C
CC90    G(ISX) = -DPCON (DSUM)
  90    CONTINUE
        CALL      DPCON (DSUM,RESULT)
        G(ISX) = -RESULT
 100  CONTINUE
C
      DO 150 I=1,KN
        DSUM = DBLE ( Z(I) )
        IF (ITYP.EQ.2) GO TO 120
        DSUM = DSUM + DBLE (B(1)) * DBLE (S(1))
        IF (KM.EQ.1) GO TO 140
        DO 110 L=2,KM
          DSUM = DSUM + DBLE(B(L))*DBLE(X(I,1)-U)**(L-1)*DBLE(S(L))
 110    CONTINUE
        GO TO 140
C
 120    DO 130 L=1,KM
          DSUM = DSUM + DBLE(B(L)) * DBLE(X(I,L) * S(L))
 130    CONTINUE
C
 140    DY = DBLE ( Y(I) )
CCCCC   IF (ISWAD.EQ.1) DY = DBLE (Y(I) - SPDIV (R(I),S(MPLUS1),IND) )
        IF (ISWAD.EQ.1) CALL         SPDIV (R(I),S(MPLUS1),IND,RESULT)
        IF (ISWAD.EQ.1) DY = DBLE (Y(I) - RESULT                    )
        DSUM = DSUM - DY * DBLE (S(MPLUS1))
CCCCC   F(I) = -DPCON (DSUM)
        CALL    DPCON (DSUM,RESULT)
        F(I) = -RESULT
CCCCC   IF (WC.LE.0.0) WW = SPSQRT(W(I))
        IF (WC.LE.0.0) CALL SPSQRT(W(I),RESULT)
        IF (WC.LE.0.0) WW = RESULT
        F(I) = F(I) * WW
CCCCC   IF (WW.EQ.0.0) Z(I) = DPCON (DBLE (Z(I)) - DSUM)
        IF (WW.EQ.0.0) CALL   DPCON (DBLE (Z(I)) - DSUM,Z(I))
 150  CONTINUE
C
C     END NEW RESIDUALS.
C
 160  DO 210 ISX=1,KM
        LESS1 = ISX - 1
        DSUM  = - DBLE (G(ISX))
        IF (1.GT.LESS1) GO TO 180
        J    = ISX
        DO 170 L=1,LESS1
          DSUM = DSUM + DBLE (D(L)) * DBLE (A(J))
          J = J + MPLUS1 - L
 170    CONTINUE
C
C180    D(ISX) = - DPCON (DSUM)
 180    CONTINUE
        CALL       DPCON (DSUM,RESULT)
        D(ISX) = - RESULT
        DO 190 L=1,KN
CCCCC     IF (WC.LE.0.0) WW = SPSQRT (W(L))
          IF (WC.LE.0.0) CALL SPSQRT (W(L),RESULT)
          IF (WC.LE.0.0) WW = RESULT
          JJ   = (ISX-1) * KN + L
          DSUM = DSUM + DBLE (F(L)) * DBLE (Q(JJ)) * DBLE (WW)
 190    CONTINUE
C
CCCCC   C  = DPCON (DSUM)
        CALL DPCON (DSUM,C)
CCCCC   LD = IDIV (2*(ISX-1)*(MPLUS1)-ISX*ISX+3*ISX,2,IRR)
        CALL IDIV (2*(ISX-1)*(MPLUS1)-ISX*ISX+3*ISX,2,IRR,LD)
CCCCC   C  = SPDIV (C,A(LD),IRR)
        CALL SPDIV (C,A(LD),IRR,C)
        G(ISX) = C
        DO 200 I=1,KN
CCCCC     IF (WC.LE.0.0) WW = SPSQRT (W(I))
          IF (WC.LE.0.0) CALL SPSQRT (W(I),RESULT)
          IF (WC.LE.0.0) WW = RESULT
          JJ   = (ISX-1) * KN + I
          F(I) = F(I) - C * Q(JJ) * WW
 200    CONTINUE
C
 210  CONTINUE
      DO 240 IS=1,KM
        ISX    = MPLUS1 - IS
        IPLUS1 = ISX + 1
        DSUM   = DBLE (-G(ISX))
        IF (IPLUS1.GT.KM) GO TO 230
CCCCC   LD     = IDIV (2*(ISX-1)*(MPLUS1)-ISX*ISX+3*ISX,2,IRR)
        CALL     IDIV (2*(ISX-1)*(MPLUS1)-ISX*ISX+3*ISX,2,IRR,LD)
        J      = 0
        DO 220 L=IPLUS1,KM
          J    = J + 1
          LJ   = LD + J
          DSUM = DSUM + DBLE (G(L)) * DBLE (A(LJ))
 220    CONTINUE
C230    G(ISX) = - DPCON (DSUM)
 230    CONTINUE
        CALL       DPCON (DSUM,RESULT)
        G(ISX) = - RESULT
 240  CONTINUE
C
C BLOCK 3 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      DSUM = RNDB2
      DO 250 ISX=1,KM
        DSUM = DSUM + DBLE (G(ISX) * G(ISX) )
 250  CONTINUE
C
CCCCC RNDB2 = DPCON (DSUM)
      CALL    DPCON (DSUM,RNDB2)
      DSUM  = RNDR2
      DO 260 I=1,KN
        DSUM = DSUM + DBLE (F(I) * F(I) )
 260  CONTINUE
C
CCCCC RNDR2 = DPCON (DSUM)
      CALL    DPCON (DSUM,RNDR2)
      IF (KI.NE.0) GO TO 270
      RNB = RNDB2
      RNR = RNDR2
C
C     COMPUTE DIGITS = AVERAGE NUMBER OF DIGITS IN AGREEMENT BETWEEN
C                         INITIAL SOLUTION AND FIRST ITERATION.
C
 270  IF (KI.NE.1) GO TO 290
CCCCC XNORM  = SPSQRT (RNB)
      CALL     SPSQRT (RNB,RESULT)
      XNORM  = RESULT
CCCCC DXNORM = SPSQRT (RNDB2)
      CALL     SPSQRT (RNDB2,RESULT)
      DXNORM = RESULT
      IF (XNORM.NE.0.0) GO TO 280
CCCCC DIGITS = - SPLO10 (E)  JUNE 1987
      CALL SPLO10(E,RESULT)
      DIGITS = - RESULT
      GO TO 290
C
C280  DIGITS = - SPLO10 (AMAX1(SPDIV(DXNORM,XNORM,IND),E))
  280 CONTINUE
CCCCC CALL       SPLO10 (AMAX1(SPDIV(DXNORM,XNORM,IND),E),RESULT)
      CALL                     SPDIV(DXNORM,XNORM,IND,RESUL2)
      CALL       SPLO10 (AMAX1(RESUL2,E),RESULT)
      DIGITS = - RESULT
C
C     END KI-TH ITERATION STEP.
C
 290  KI = KI + 1
      IF (KI.GT.ITMAX) GO TO 310
C
C BLOCK 3 (END) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      GO TO 30
C
C BLOCK 4 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
 300  IF (RNDR2.GT.4.0*ETA2*RNR .AND. RNDB2.GT.4.0*ETA2*RNB) GO TO 310
      K = 0
      GO TO 320
C
C310  K = 1    COMMENTED OUT (JUNE 1987) TO GIVE CORRECT ANSWERS ON THE VAX.
 310  K = 0
C
C BLOCK 4 (END) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
 320  NI   = KI - 1
      F(1) = DIGITS
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----DSUMAL--------------------------------------
      SUBROUTINE DSUMAL (DX,NN,SNEG,SPOS,SUM)
CCCCC SUBROUTINE DSUMAL (DX,NN,SUM)
CCCCC THE ARGUMENTS SNEG AND SPOS WERE ADDED     SEPTEMBER 1995
CCCCC UPDATED--SEPTEMBER 1995 HAVE SNEG & SPOS AS  INPUT/OUTPUT ARGUMENTS
CCCCC                         TO AVOID FAILURE-TO-SAVE ON SOME COMPUTERS
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     ALGORITHM DESCRIBED BY MALCOLM IN COM. OF ACM VOL. 14, NO. 11
C
C     SPECIAL ALGORITHM FOR SUMMING DOUBLE PRECISION NUMBERS.
C        (USE SUMMAL, IF NUMBERS ARE REAL.)
C
C     NN EQUALS       ZERO, CLEAR AREA TO PREPARE FOR NEW SUM.
C     NN EQUALS        ONE, OBTAIN FINAL SUM.
C     NN GREATER THAN ZERO, CLEAR, DO SUM ON NN TERMS AND GET FINAL SUM.
C     NN LESS THAN    ZERO, CONTINUE SUM FOR NEXT ABS(NN) TERMS,
C                              DO NOT GET FINAL SUM.
C
C               WRITTEN BY -
C                      SALLY T. PEAVY,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG, MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO DIMENSION (*)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
CCCCC THE FOLLOWING LINE WAS MOVED AND       NOVEMBER 1989
CCCCC CONVERTED (1) TO (*)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC DIMENSION DX(1)
C
      DOUBLE PRECISION             DX, SUM, SNEG, SPOS
C
      DIMENSION DX(*)
C
C     ==================================================================
C
      IF(NN) 30,10,20
  10  SPOS = 0.0
      SNEG = 0.0
      RETURN
C
C     ..................................................................
C
  20  IF (NN.EQ.1) GO TO 50
      SPOS = 0.0
      SNEG = 0.0
C
  30  N = IABS (NN)
      DO 40 I=1,N
        IF (DX(I).LT.0.0) SNEG = SNEG + DX(I)
        IF (DX(I).GE.0.0) SPOS = SPOS + DX(I)
  40  CONTINUE
C
      IF (NN.LT.0) RETURN
C
  50  SUM = SPOS + SNEG
      RETURN
C
C     ==================================================================
C
      END
      SUBROUTINE SDPRED (N,M,R,Q,SB,SD,SDYHAT)
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     SUBROUTINE SDPRED COMPUTES STANDARD DEVIATIONS OF PREDICTED
C        VALUES.
C
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG, MD. 20899
C                          TELEPHONE 301-975-2844
C
C     UPDATED--NOVEMBER  1989--DIMENSION (1) TO DIMENSION (*)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
CCCCC THE FOLLOWING LINE WAS TRANSLATED TO    NOVEMBER 1989
CCCCC 4 DIMENSION STATEMENTS (SEE BELOW)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             Q(1), R(1), SB(1), SDYHAT(1)
      REAL             SD
CCCCC REAL             SPDIV, DPCON, SPSQRT
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Q(*)
      DIMENSION R(*)
      DIMENSION SB(*)
      DIMENSION SDYHAT(*)
C
C     ==================================================================
C
      DO 10 J=1,M
CCCCC   L =  IDIV (2*(J-1)*(M+1)-J*J+3*J,2,IND)
        CALL IDIV (2*(J-1)*(M+1)-J*J+3*J,2,IND,L)
CCCCC   SB(J) = SPDIV (1.0,SPSQRT (R(L)),IND)
        CALL SPSQRT(R(L),RESULT)
CCCCC   SB(J) = SPDIV (1.0,RESULT,IND)
        CALL    SPDIV (1.0,RESULT,IND,SB(J))
  10  CONTINUE
C
      DO 30 I=1,N
        DSUM = 0.0D0
        DO 20 J=1,M
          L = (J-1) * N + I
          DSUM = DSUM + (DBLE (Q(L)) * DBLE (SB(J))) ** 2
  20    CONTINUE
C
CCCCC   SDYHAT(I) = DPCON (DSUM)
        CALL        DPCON (DSUM,SDYHAT(I))
        IF (SDYHAT(I).LT.0.0) SDYHAT(I) = 0.0
CCCCC   SDYHAT(I) = SD * SPSQRT (SDYHAT(I))
        CALL SPSQRT(SDYHAT(I),RESULT)
        SDYHAT(I) = SD * RESULT
  30  CONTINUE
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----PINVRT--------------------------------------
      SUBROUTINE PINVRT (M,R,D)
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     SUBROUTINE PINVRT OBTAINS THE UNSCALED COVARIANCE MATRIX OF THE
C        COEFFICIENTS, EQUAL TO THE INVERSE OF (X-TRANSPOSE)*W*X.
C        MATRIX R OBTAINED FROM SUBROUTINE PDECOM IS USED AS INPUT.
C        THIS MATRIX IS OVERWRITTEN AND ON EXIT WILL EQUAL THE DESIRED
C        INVERSE.
C
C     SINCE THE INVERSE MATRIX IS SYMMETRIC, ONLY THE PORTION ON OR
C        ABOVE THE PRINCIPAL DIAGONAL IS STORED.
C
C               WRITTEN BY -
C                      ROY H. WAMPLER,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      GAITHERSBURG,MD. 20899
C                          TELEPHONE 301-975-2844
C
C      UPDATED--NOVEMBER  1989--DIMENSION (1) TO DIMENSION (*)
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
CCCCC THE FOLLOWING LINE WAS TRANSLATED INTO     NOVEMBER 1989
CCCCC 2 DIMENSION STATEMENTS (SEE BELOW)
CCCCC (BUG UNCOVERED BY NELSON HSU)
CCCCC REAL             D(1), R(1)
C
CCCCC REAL             SPDIV, DPCON
C
      DOUBLE PRECISION DSUM
C
      DIMENSION D(*)
      DIMENSION R(*)
C
C     ==================================================================
C
      DO 10 L=1,M
CCCCC   LL = IDIV (2*(L-1)*(M+1)-L*L+3*L,2,IRR)
        CALL IDIV (2*(L-1)*(M+1)-L*L+3*L,2,IRR,LL)
CCCCC   R(LL) = SPDIV (1.0,R(LL),IRR)
        CALL    SPDIV (1.0,R(LL),IRR,R(LL))
  10  CONTINUE
C
      IF (M.EQ.1) RETURN
      L = M
  20  J = L - 1
CCCCC LJ = IDIV (2*(J-1)*(M+1)-J*J+3*J,2,IRR)
      CALL IDIV (2*(J-1)*(M+1)-J*J+3*J,2,IRR,LJ)
      INC = 0
      DO 30 K=L,M
        INC  = INC + 1
        JK   = LJ + INC
        D(K) = R(JK)
  30  CONTINUE
C
      I = M
      DO 50 KA=J,M
        DSUM = 0.0D0
        IF (I.EQ.J) DSUM = DBLE (R(LJ))
        DO 40 K=L,M
          JK    = MIN0 (K,I)
CCCCC     LL    = IDIV (2*(JK-1)*(M+1)-JK*JK+3*JK,2,IRR)
          CALL    IDIV (2*(JK-1)*(M+1)-JK*JK+3*JK,2,IRR,LL)
          INC   = IABS (K-I)
          JK    = LL + INC
          DSUM = DSUM -DBLE (D(K)) * DBLE (R(JK))
  40    CONTINUE
        INC = I - J
        JK = LJ + INC
CCCCC   R(JK) = DPCON (DSUM)
        CALL    DPCON (DSUM,R(JK))
        I = I - 1
  50  CONTINUE
      L = L - 1
      IF (L.GT.1) GO TO 20
C
C    C
C     PACK VECTOR R.
C
      DO 70 I=2,M
CCCCC   L =  IDIV (2*(I-1)*M-I*I+3*I,2,IRR)
        CALL IDIV (2*(I-1)*M-I*I+3*I,2,IRR,L)
        DO 60 J=I,M
          K = L + I - 1
          R(L) = R(K)
          L = L + 1
  60    CONTINUE
  70  CONTINUE
C
      RETURN
C
C     ==================================================================
C
      END
CCCCC-----DPDIV--------------------------------------
      SUBROUTINE DPDIV(FN,FD,IND,DRESUL)
C
C     PURPOSE--PERFORM DOUBLE PRECISION DIVISION FN/FD,
C              IF THE DENOMINATOR EQUALS ZERO,
C              THE RESULT IS SET TO ZERO,
C              AND THE INDICATOR, IND, IS SET EQUAL TO ONE.
C              OTHERWISE, IND IS SET TO 0.
C     INPUT  ARGUMENTS--FN
C                     --FD
C     OUTPUT ARGUMENTS--IND
C                     --DRESUL
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION FN
      DOUBLE PRECISION FD
      DOUBLE PRECISION DRESUL
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IND = 0
      IF(FD.EQ.0.0D0)GOTO1010
      DRESUL=FN/FD
      GOTO9000
C
 1010 CONTINUE
      DRESUL=0.0D0
      IND=1
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
CCCCC-----SPDIV--------------------------------------
      SUBROUTINE SPDIV(FN,FD,IND,RESULT)
C
C     PURPOSE--PERFORM SINGLE PRECISION DIVISION FN/FD,
C              IF THE DENOMINATOR EQUALS ZERO,
C              THE RESULT IS SET TO ZERO,
C              AND THE INDICATOR, IND, IS SET EQUAL TO ONE.
C              OTHERWISE, IND IS SET TO 0.
C     INPUT  ARGUMENTS--FN
C                     --FD
C     OUTPUT ARGUMENTS--IND
C                     --RESULT
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IND = 0
      IF(FD.EQ.0.0D0)GOTO1010
      RESULT=FN/FD
      GOTO9000
C
 1010 CONTINUE
      RESULT=0.0D0
      IND=1
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
CCCCC-----DPCON--------------------------------------
      SUBROUTINE DPCON(DX,RESULT)
C
C     PURPOSE--CONVERT DOUBLE PRECISION NUMBER
C              TO SINGLE PRECISION NUMBER BY OCTAL ROUNDING
C              INSTEAD OF TRUNCATION.
C     INPUT  ARGUMENTS--DX          (DOUBLE PRECISION)
C     OUTPUT ARGUMENTS--RESULT      (SINGLE PRECISION)
C               WRITTEN BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL BUREAU OF STANDARDS,
C                      WASHINGTON, DC 20234
C                          TELEPHONE 301-975-2855
C                  ORIGINAL VERSION -   AUGUST, 1969.
C                   CURRENT VERSION - NOVEMBER, 1978.
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL             Y
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXX
      DOUBLE PRECISION  D
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMETNS-------------------------------------------------
C
      DATA RMIFY / -1.0E37 /
      DATA RPIFY /  1.0E38 /
C
C-----START POINT-----------------------------------------------------
C
      DXX = DX
      IF (DXX.GT.DBLE(RPIFY)) DXX = RPIFY
      IF (DXX.LT.DBLE(RMIFY)) DXX = RMIFY
C
      Y = DXX
      D = Y
      RESULT = DXX + (DXX-D)
C
      RETURN
      END
CCCCC-----DPSQRT--------------------------------------
      SUBROUTINE DPSQRT(DX,DRESUL)
C
C     PURPOSE--PERFORM DOUBLE PRECISION SQUARE ROOT OF DX,
C              IF THE DENOMINATOR IS LESS THAN 0,
C              THE OUTPUT RESULT IS SET TO 0,
C              AND AN ARITHMETIC FAULT MESSAGE IS PRINTED.
C     INPUT  ARGUMENTS--X
C     OUTPUT ARGUMENTS--DRESUL
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DRESUL
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(DX.LE.0.0D0)GOTO1010
      DRESUL=DSQRT(DX)
      GOTO9000
C
 1010 CONTINUE
      DRESUL=0.0D0
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
CCCCC-----SPSQRT--------------------------------------
      SUBROUTINE SPSQRT(X,RESULT)
C
C     PURPOSE--PERFORM SINGLE PRECISION SQUARE ROOT OF X,
C              IF THE DENOMINATOR IS LESS THAN 0,
C              THE OUTPUT RESULT IS SET TO 0,
C              CALLS ERROR(101) IS DONE.
C     INPUT  ARGUMENTS--X
C     OUTPUT ARGUMENTS--RESULT
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--NOVEMBER  1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LE.0.0)GOTO1010
      RESULT=SQRT(X)
      GOTO9000
C
 1010 CONTINUE
      RESULT=0.0D0
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
CCCCC-----SPLO10--------------------------------------
      SUBROUTINE SPLO10(X,RESULT)
C
C     PURPOSE--COMPUTER LOG TO BASE 10 OF X
C              USING LIBRARY FUNCTION OF X IS POSITIVE, OR
C              CALLS ERROR(101) AND SETS FUNCTION VALUE
C              EQUAL TO 0 IF X IS NONPOSITIVE.
C
C     INPUT  ARGUMENTS--X
C     OUTPUT ARGUMENTS--RESULT
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.0.0)GOTO1020
      RESULT=0.0
      GOTO9000
C
 1020 CONTINUE
      RESULT=ALOG10(X)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
CCCCC-----IDIV--------------------------------------
      SUBROUTINE IDIV(IN,ID,IND,IRESUL)
C
C     PURPOSE--THIS INTEGER FUNCTION PERFORMS THE DIVISION IN/ID, WHEN
C              THE NUMERATOR, IN, AND THE DENOMINATOR, ID, ARE INTEGERS.
C              IF ID = 0, THE FUNCTION VALUE IS SET EQUAL TO ZERO.
C
C     INPUT  ARGUMENTS--IN
C                     --ID
C     OUTPUT ARGUMENTS--IND
C                     --IRESUL
C     WRITTEN BY--ROY WAMPLER
C                 DAVE HOGBEN
C                 SALLY PEAVY
C     CONVERTED TO DATAPLOT BY--JAMES J. FILLIBEN (JUNE 1987)
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/7
C     ORIGINAL VERSION--JUNE      1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----DIMENSION-------------------------------------------------------
 
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IND = 0
      IF(ID.EQ.0)GOTO1010
      IRESUL=IN/ID
      GOTO9000
C
 1010 CONTINUE
      IRESUL=0
      IND=1
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DBOCLS (W,MDW,MCON,MROWS,NCOLS,BL,BU,IND,
     * IOPT,X,RNORMC,RNORM,MODE,RW,IW)
C     REVISED 830118-0920
C     REVISED YYMMDD-HHMM
C
C    PURPOSE
C    -------
C     THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE LEAST SQUARES
C     PROBLEM CONSISTING OF LINEAR CONSTRAINTS
C
C              C*X = Y
C
C     AND LEAST SQUARES EQUATIONS
C
C              E*X = F
C
C     IN THIS FORMULATION THE VECTORS X AND Y ARE BOTH UNKNOWNS.
C     FURTHER, X AND Y MAY BOTH HAVE USER-SPECIFIED BOUNDS ON EACH
C     COMPONENT.  THE USER MUST HAVE DIMENSION STATEMENTS OF THE
C     FORM
C
C     DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON),BU(NCOLS+MCON),
C               X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON)
C
C     INTEGER IND(NCOLS+MCON), IOPT(1+NI), IW(2*(NCOLS+MCON))
C
      DOUBLE PRECISION            W(MDW,*),BL(*),BU(*),X(*),RW(*)
      DOUBLE PRECISION            ONE,ZERO,T,T1,T2,WT,ANORM,CNORM,RNORM,
     *                            SRELPR,DDOT,DASUM,DNRM2
      INTEGER IND(*),IOPT(*),IW(*),JOPT(05)
      LOGICAL CHECKL,FILTER,ACCUM,PRETRI
      SAVE IGO,ACCUM,CHECKL
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DATA IGO/0/
      LEVEL=1
      IF (.NOT.(IGO.EQ.0)) GO TO 20002
      GO TO 30001
20005 CONTINUE
      GO TO 30002
20006 IF (.NOT.(CHECKL)) GO TO 20007
      GO TO 30003
20010 CONTINUE
20007 CONTINUE
C
C     OPTIONALLY GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES
C     EQUATIONS AND DIRECTIONS FOR PROCESSING THESE EQUATIONS.
20002 CONTINUE
      GO TO 30004
20011 IF(ACCUM) RETURN
      GO TO 30005
20012 IGO=0
      RETURN
C     PROCEDURE(CHECK LENGTHS OF ARRAYS)
C
C     THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE
C     ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE.
30003 IF (.NOT.(LMDW.LT.MCON+MOUT)) GO TO 20013
      NERR=41
      NCHAR=88
CCCCC CALL XERRWV('DBOCLS(). THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.
CCCCC* THE NUMBER OF EFFECTIVE ROWS=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LMDW,MCON+MOUT, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** ERROR FROM DBOCLS.THE ROW DIMENSION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)LMDW,MCON+MOUT
   52 FORMAT('      OF W, ',I5,' MUST BE GREATER THAN ',
     1'OR EQUAL TO THE NUMBER OF EFFECTIVE ROWS, ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20016 TO NPR006
      GO TO 30006
20016 CONTINUE
20013 IF (.NOT.(LNDW.LT.NCOLS+MCON+1)) GO TO 20017
      NERR=42
      NCHAR=75
CCCCC CALL XERRWV('DBOCLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .
CCCCC*GE. NCOLS+MCON+1=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LNDW,NCOLS+MCON+1, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)
   61 FORMAT('***** ERROR FROM DBOCLS.  THE COLUMN DIMENSION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)LNDW,NCOLS+MCON+1
   62 FORMAT('      OF W, ',I5,' MUST BE GREATER ',
     1'THAN OR EQUAL TO NCOLS+MCON+1 = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20020 TO NPR006
      GO TO 30006
20020 CONTINUE
20017 IF (.NOT.(LLB.LT.NCOLS+MCON)) GO TO 20021
      NERR=43
      NCHAR=94
CCCCC CALL XERRWV('DBOCLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND
CCCCC* IND()=(I1) MUST BE .GE. NCOLS+MCON=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLB,NCOLS+MCON, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)
   71 FORMAT('***** ERROR FROM DBOCLS.  THE DIMENSIONS OF THE ARRAYS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)NCOLS+MCON
   72 FORMAT('      BL, BU, AND IND MUST BE GREATER THAN OR EQUAL TO ',
     1'NCOLS+MCON = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20024 TO NPR006
      GO TO 30006
20024 CONTINUE
20021 IF (.NOT.(LLX.LT.LENX)) GO TO 20025
      NERR=44
      NCHAR=71
CCCCC CALL XERRWV('DBOCLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE
CCCCC* REQD. LENGTH=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLX,LENX, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)LLX
   81 FORMAT('***** ERROR FROM DBOCLS.  THE DIMENSION OF X()=',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)LENX
   82 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO THE REQUIRED ',
     1'LENGTH ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20028 TO NPR006
      GO TO 30006
20028 CONTINUE
20025 IF (.NOT.(LLRW.LT.6*NCOLS+5*MCON)) GO TO 20029
      NERR=45
      NCHAR=70
CCCCC CALL XERRWV('DBOCLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 6*N
CCCCC*COLS+5*MCON=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLRW,6*NCOLS+5*MCON, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,91)LLRW
   91 FORMAT('***** ERROR FROM DBOCLS.  THE DIMENSION OF RW()=',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,92)6*NCOLS+5*MCON
   92 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'6*NCOLS + 5*MCON =',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20032 TO NPR006
      GO TO 30006
20032 CONTINUE
20029 IF (.NOT.(LLIW.LT.2*NCOLS+2*MCON)) GO TO 20033
      NERR=46
      NCHAR=69
CCCCC CALL XERRWV('DBOCLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NC
CCCCC*OLS+2*MCON=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLIW,2*NCOLS+2*MCON,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)LLIW
  101 FORMAT('***** ERROR FROM DBOCLS.  THE DIMENSION OF IW()=',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)2*NCOLS+2*MCON
  102 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'2*NCOLS + 2*MCON =',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20036 TO NPR006
      GO TO 30006
20036 CONTINUE
20033 IF (.NOT.(LIOPT.LT.LP+1)) GO TO 20037
      NERR=47
      NCHAR=72
CCCCC CALL XERRWV('DBOCLS(). THE DIMENSION OF IOPT()=(I1) MUST BE .GE. T
CCCCC*HE REQD. LEN.=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LIOPT,LP+1,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)LIOPT
  111 FORMAT('***** ERROR FROM DBOCLS.  THE DIMENSION OF IOPT()=',I5,
     1'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)LP+1
  112 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'THE REQUIRED LENGTH = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20040 TO NPR006
      GO TO 30006
20040 CONTINUE
20037 GO TO 20010
C     PROCEDURE(CHECK VALIDITY OF INPUT DATA)
C
C     SEE THAT MDW IS .GT.0. GROSS CHECK ONLY.
30001 IF (.NOT.(MDW.LE.0)) GO TO 20041
      NERR=53
      NCHAR=36
CCCCC CALL XERRWV('DBOCLS(). MDW=(I1) MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,MDW,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR FROM DBOCLS.  MDW MUST BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20044 TO NPR006
      GO TO 30006
20044 CONTINUE
C
C     SEE THAT NUMBER OF CONSTRAINTS IS NONNEGATIVE.
20041 IF (.NOT.(MCON.LT.0)) GO TO 20045
      NERR=54
      NCHAR=40
CCCCC CALL XERRWV('DBOCLS(). MCON=(I1) MUST BE NONNEGATIVE.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,MCON,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** ERROR FROM DBOCLS.  THE NUMBER OF CONSTRAINTS ',
     1'MUST BE NON-NEGATIVE,')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20048 TO NPR006
      GO TO 30006
20048 CONTINUE
C
C     SEE THAT NUMBER OF UNKNOWNS IS POSITIVE.
20045 IF (.NOT.(NCOLS.LE.0)) GO TO 20049
      NERR=55
      NCHAR=59
CCCCC CALL XERRWV('DBOCLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POS
CCCCC*ITIVE.', NCHAR,NERR,LEVEL,
CCCCC* 1,NCOLS,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR FROM DBOCLS.  THE NUMBER OF VARIABLES ',
     1'MUST BE POSITIVE,')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20052 TO NPR006
      GO TO 30006
20052 CONTINUE
C
C     SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED.
20049 J=1
      N20053=NCOLS+MCON
      GO TO 20054
20053 J=J+1
20054 IF ((N20053-J).LT.0) GO TO 20055
      IF (.NOT.(IND(J).LT.1 .OR. IND(J).GT.4)) GO TO 20057
      NERR=56
      NCHAR=46
CCCCC CALL XERRWV('DBOCLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 2,J,IND(J),0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)J,IND(J)
  151 FORMAT('***** ERROR FROM DBOCLS.  FOR J = ',I5,', IND(J) = ',I5,
     1'MUST BE 1-4.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20060 TO NPR006
      GO TO 30006
20060 CONTINUE
20057 GO TO 20053
C
C     SEE THAT BOUNDS ARE CONSISTENT.
20055 J=1
      N20061=NCOLS+MCON
      GO TO 20062
20061 J=J+1
20062 IF ((N20061-J).LT.0) GO TO 20063
      IF (.NOT.(IND(J).EQ.3)) GO TO 20065
      IF (.NOT.(BL(J) .GT. BU(J))) GO TO 20068
      NERR=57
      NCHAR=58
CCCCC CALL XERRWV('DBOCLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=
CCCCC*(R2).', NCHAR,NERR,LEVEL,
CCCCC* 1,J,IDUM, 2,BL(J),BU(J))
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,161)J,BL(J),BU(J)
  161 FORMAT('***** ERROR FROM DBOCLS.  FOR J = ',I5,', BOUND BL(J) ',
     1'= ',F10.5,' IS GREATER THAN BU(J) = ',F10.5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20071 TO NPR006
      GO TO 30006
20071 CONTINUE
20068 CONTINUE
20065 GO TO 20061
20063 GO TO 20005
C     PROCEDURE(PROCESS OPTION ARRAY)
30002 ZERO=0.D0
      ONE=1.D0
      SRELPR=D1MACH(4)
      CHECKL=.FALSE.
      FILTER=.TRUE.
      LENX=2*(NCOLS+MCON)+2
      LIOPT=17
      ISCALE=1
      IGO=1
      ACCUM=.FALSE.
      PRETRI=.TRUE.
      LOPT=0
      MOPT=0
      LP=0
      LDS=0
20072 LP=LP+LDS
      LIOPT=LIOPT+LDS
      IP=IOPT(LP+1)
      JP=IABS(IP)
C
C     TEST FOR NO MORE OPTIONS.
      IF (.NOT.(IP.EQ.99)) GO TO 20074
      IF(LOPT.EQ.0)LOPT=-(LP+2)
      IF(MOPT.EQ.0)MOPT=-(IABS(LOPT)+7)
      IF (.NOT.(LOPT.LT.0)) GO TO 20077
      LBOU=IABS(LOPT)
      GO TO 20078
20077 LBOU=LOPT-15
C
C     SEND COL. SCALING TO DBOLS().
20078 IOPT(LBOU)=4
      IOPT(LBOU+1)=1
C
C     PASS AN OPTION ARRAY FOR DBOLSM().
      IOPT(LBOU+2)=5
C
C     LOC. OF OPTION ARRAY FOR DBOLSM( ).
      IOPT(LBOU+3)=8
C
C     SKIP TO START OF USER-GIVEN OPTION ARRAY FOR DBOLS().
      IOPT(LBOU+4)=6
      IOPT(LBOU+6)=99
      IF (.NOT.(LOPT.GT.0)) GO TO 20080
      IOPT(LBOU+5)=LOPT-LBOU+1
      GO TO 20081
20080 IOPT(LBOU+4)=-IOPT(LBOU+4)
20081 IF (.NOT.(MOPT.LT.0)) GO TO 20083
      LBOUM=IABS(MOPT)
      GO TO 20084
20083 LBOUM=MOPT-8
C
C     CHANGE PRETRIANGULARIZATION FACTOR IN DBOLSM().
20084 IOPT(LBOUM)=5
      IOPT(LBOUM+1)=NCOLS+MCON+1
C
C     PASS WEIGHT TO DBOLSM() FOR RANK TEST.
      IOPT(LBOUM+2)=6
      IOPT(LBOUM+3)=NCOLS+MCON+2
      IOPT(LBOUM+4)=MCON
C
C     SKIP TO USER-GIVEN OPTION ARRAY FOR DBOLSM( ).
      IOPT(LBOUM+5)=1
      IOPT(LBOUM+7)=99
      IF (.NOT.(MOPT.GT.0)) GO TO 20086
      IOPT(LBOUM+6)=MOPT-LBOUM+1
      GO TO 20087
20086 IOPT(LBOUM+5)=-IOPT(LBOUM+5)
20087 GO TO 20073
20074 IF (.NOT.(JP.EQ.99)) GO TO 10001
      LDS=1
      GO TO 20072
10001 IF (.NOT.(JP.EQ.1)) GO TO 10002
      IF (.NOT.(IP.GT.0)) GO TO 20089
C
C     SET UP DIRECTION FLAG LOCATION, ROW STACKING POINTER
C     LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS.
      LOCACC=LP+2
C
C                  IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION.
C     CONTENTS..   IOPT(LOCACC  )=USER DIRECTION FLAG, 1 OR 2.
C                  IOPT(LOCACC+1)=ROW STACKING POINTER.
C                  IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS.
C     USER ACTION WITH THIS OPTION..
C      (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).)
C      (MOVE BLOCK OF EQUATIONS INTO W(*,*)  STARTING AT FIRST
C       ROW OF W(*,*) BELOW THE ROWS FOR THE CONSTRAINT MATRIX C.
C       SET IOPT(LOCACC+2)=NO. OF LEAST SQUARES EQUATIONS IN BLOCK.
C              LOOP
C              CALL DBOCLS()
C
C                  IF(IOPT(LOCACC) .EQ. 1) THEN
C                      STACK EQUAS. INTO W(*,*), STARTING AT
C                      ROW IOPT(LOCACC+1).
C                       INTO W(*,*).
C                       SET IOPT(LOCACC+2)=NO. OF EQUAS.
C                      IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2.
C                  ELSE IF IOPT(LOCACC) .EQ. 2) THEN
C                      (PROCESS IS OVER. EXIT LOOP.)
C                  ELSE
C                      (ERROR CONDITION. SHOULD NOT HAPPEN.)
C                  END IF
C              END LOOP
      IOPT(LOCACC+1)=MCON+1
      ACCUM=.TRUE.
      IOPT(LOCACC)=IGO
20089 LDS=4
      GO TO 20072
10002 IF (.NOT.(JP.EQ.2)) GO TO 10003
      IF (.NOT.(IP.GT.0)) GO TO 20092
C
C     GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS.
      LOCDIM=LP+2
C
C     LMDW.GE.MCON+MOUT
C     LNDW.GE.NCOLS+MCON+1
C     LLB .GE.NCOLS+MCON
C     LLX .GE.2*(NCOLS+MCON)+2+EXTRA REQD. IN OPTIONS.
C     LLRW.GE.6*NCOLS+5*MCON
C     LLIW.GE.2*(NCOLS+MCON)
C     LIOP.GE. AMOUNT REQD. FOR OPTION ARRAY.
      LMDW=IOPT(LOCDIM  )
      LNDW=IOPT(LOCDIM+1)
      LLB= IOPT(LOCDIM+2)
      LLX= IOPT(LOCDIM+3)
      LLRW=IOPT(LOCDIM+4)
      LLIW=IOPT(LOCDIM+5)
      LIOPT=IOPT(LOCDIM+6)
      CHECKL=.TRUE.
20092 LDS=8
      GO TO 20072
C
C     OPTION TO MODIFY THE COLUMN SCALING.
10003 IF (.NOT.(JP.EQ.3)) GO TO 10004
      IF (.NOT.(IP.GT.0)) GO TO 20095
      ISCALE=IOPT(LP+2)
C
C     SEE THAT ISCALE IS 1 THRU 3.
      IF (.NOT.(ISCALE.LT.1 .OR. ISCALE.GT.3)) GO TO 20098
      NERR=48
      NCHAR=41
CCCCC CALL XERRWV('DBOCLS(). ISCALE OPTION=(I1) MUST BE 1-3.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,ISCALE,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,166)ISCALE
  166 FORMAT('***** ERROR FROM DBOCLS.  ISCALE OPTION = ',I5,' MUST ',
     1'BE 1-3.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20101 TO NPR006
      GO TO 30006
20101 CONTINUE
20098 CONTINUE
20095 LDS=2
      GO TO 20072
C
C     IN THIS OPTION THE USER HAS PROVIDED SCALING.  THE
C     SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)).
10004 IF (.NOT.(JP.EQ.4)) GO TO 10005
      IF (.NOT.(IP.GT.0)) GO TO 20102
      ISCALE=4
      IF (.NOT.(IOPT(LP+2).LE.0)) GO TO 20105
      NERR=49
      NCHAR=86
CCCCC CALL XERRWV('DBOCLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED
CCCCC* COLUMN SCALING MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,IOPT(LP+2),IDUM,0,RDUM,RDUM)
      ASSIGN 20108 TO NPR006
      GO TO 30006
20108 CONTINUE
20105 CALL DCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1)
      LENX=LENX+NCOLS
      J=1
      N20109=NCOLS
      GO TO 20110
20109 J=J+1
20110 IF ((N20109-J).LT.0) GO TO 20111
      IF (.NOT.(RW(J).LE.ZERO)) GO TO 20113
      NERR=50
      NCHAR=84
CCCCC CALL XERRWV('DBOCLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POS
CCCCC*ITIVE. COMP. (I1)   NOW = (R1).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,J,IDUM,1,RW(J),RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,191)
  191 FORMAT('***** ERROR FROM DBOCLS.  EACH PROVIDED COLUMN SCALE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,192)J,RW(J)
  192 FORMAT('      FACTOR MUST BE POSITIVE.  COMPONENT ',I5,' NOW = ',
     1E15.7)
      ASSIGN 20116 TO NPR006
      GO TO 30006
20116 CONTINUE
20113 GO TO 20109
20111 CONTINUE
20102 LDS=2
      GO TO 20072
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLS().
10005 IF (.NOT.(JP.EQ.5)) GO TO 10006
      IF (.NOT.(IP.GT.0)) GO TO 20117
      LOPT=IOPT(LP+2)
20117 LDS=2
      GO TO 20072
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM().
10006 IF (.NOT.(JP.EQ.6)) GO TO 10007
      IF (.NOT.(IP.GT.0)) GO TO 20120
      MOPT=IOPT(LP+2)
20120 LDS=2
      GO TO 20072
C
C     THIS OPTION USES THE NEXT LOC OF IOPT(*) AS A
C     POINTER VALUE TO SKIP TO NEXT.
10007 IF (.NOT.(JP.EQ.7)) GO TO 10008
      IF (.NOT.(IP.GT.0)) GO TO 20123
      LP=IOPT(LP+2)-1
      LDS=0
      GO TO 20124
20123 LDS=2
20124 GO TO 20072
C
C     THIS OPTION AVOIDS THE CONSTRAINT RESOLVING PHASE FOR
C     THE LINEAR CONSTRAINTS C*X=Y.
10008 IF (.NOT.(JP.EQ.8)) GO TO 10009
      FILTER=.NOT.(IP.GT.0)
      LDS=1
      GO TO 20072
C
C     THIS OPTION SUPPRESSES PRETIRANGULARIZATION OF THE LEAST
C     SQUARES EQATIONS.
10009 IF (.NOT.(JP.EQ.9)) GO TO 10010
      PRETRI=.NOT.(IP.GT.0)
      LDS=1
      GO TO 20072
C
C     NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION.
10010 NERR=51
      NCHAR=48
CCCCC CALL XERRWV('DBOCLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,JP,IDUM,0,IDUM,IDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,201)
  201 FORMAT('***** ERROR FROM DBOCLS.  INVALID OPTION NUMBER.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20126 TO NPR006
      GO TO 30006
20126 CONTINUE
20075 GO TO 20072
20073 GO TO 20006
C     PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS)
30004 IF (.NOT.(ACCUM)) GO TO 20127
      MROWS=IOPT(LOCACC+1)-1-MCON
      INROWS=IOPT(LOCACC+2)
      MNEW=MROWS+INROWS
      IF (.NOT.(MNEW.LT.0 .OR. MNEW+MCON.GT.MDW)) GO TO 20130
      NERR=52
      NCHAR=66
CCCCC CALL XERRWV('DBOCLS(). NO. OF ROWS=(I1) MUST BE .GE. 0 .AND. .LE.
CCCCC*MDW-MCON=(I2).',NCHAR,NERR,LEVEL,
CCCCC*2,MNEW,MDW-MCON,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,211)
  211 FORMAT('***** ERROR FROM DBOCLS.  INVALID NUMBER OF ROWS.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20133 TO NPR006
      GO TO 30006
20133 CONTINUE
20130 CONTINUE
20127 CONTINUE
C
C     USE THE SOFTWARE OF DBOLS( ) FOR THE TRIANGULARIZATION OF THE
C     LEAST SQUARES MATRIX.  THIS MAY INVOLVE A SYSTALTIC INTERCHANGE
C     OF PROCESSING POINTERS BETWEEN THE CALLING AND CALLED (DBOLS())
C     PROGRAM UNITS.
20128 JOPT(01)=1
      JOPT(02)=2
      JOPT(04)=MROWS
      JOPT(05)=99
      IRW=NCOLS+1
      IIW=1
      IF (.NOT.(ACCUM.OR.PRETRI)) GO TO 20134
      CALL DBOLS(W(MCON+1,1),MDW,MOUT,NCOLS,BL,BU,IND,
     * JOPT,X,REAL(RNORM),MODE,RW(IRW),IW(IIW))
      GO TO 20135
20134 MOUT=MROWS
20135 CONTINUE
20136 IF (.NOT.(ACCUM)) GO TO 20137
      ACCUM=IOPT(LOCACC).EQ.1
      IOPT(LOCACC+1)=JOPT(03)+MCON
      MROWS=MIN0(NCOLS+1,MNEW)
20137 CONTINUE
20138 GO TO 20011
C     PROCEDURE(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM)
C
C     MOVE RIGHT HAND SIDE OF LEAST SQUARES EQUATIONS.
30005 CALL DCOPY(MOUT,W(MCON+1,NCOLS+1),1,W(MCON+1,NCOLS+MCON+1),1)
      IF (.NOT.(MCON.GT.0 .AND. FILTER)) GO TO 20140
C
C     PROJECT THE LINEAR CONSTRAINTS INTO A REACHABLE SET.
      I=1
      N20143=MCON
      GO TO 20144
20143 I=I+1
20144 IF ((N20143-I).LT.0) GO TO 20145
      CALL DCOPY(NCOLS,W(I,1),MDW,W(MCON+1,NCOLS+I),1)
      GO TO 20143
C
C      PLACE (-)IDENTITY MATRIX AFTER CONSTRAINT DATA.
20145 J=NCOLS+1
      N20147=NCOLS+MCON+1
      GO TO 20148
20147 J=J+1
20148 IF ((N20147-J).LT.0) GO TO 20149
      W(1,J)=ZERO
      CALL DCOPY(MCON,W(1,J),0,W(1,J),1)
      GO TO 20147
20149 W(1,NCOLS+1)=-ONE
      CALL DCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1)
C
C     OBTAIN A 'FEASIBLE POINT' FOR THE LINEAR CONSTRAINTS.
      JOPT(01)=99
      IRW=NCOLS+1
      IIW=1
      CALL DBOLS(W,MDW,MCON,NCOLS+MCON,BL,BU,IND,JOPT,X,
     * RNORMC,MODEC,RW(IRW),IW(IIW))
C
C     ENLARGE THE BOUNDS SET, IF REQUIRED, TO INCLUDE POINTS THAT
C     CAN BE REACHED.
      J=NCOLS+1
      N20151=NCOLS+MCON
      GO TO 20152
20151 J=J+1
20152 IF ((N20151-J).LT.0) GO TO 20153
      ICASE=IND(J)
      IF (.NOT.(ICASE.LT.4)) GO TO 20155
      T=DDOT(NCOLS,W(MCON+1,J),1,X,1)
20155 NX0162=ICASE
      IF (NX0162.LT.1.OR.NX0162.GT.4) GO TO 20162
      GO TO (20158,20159,20160,20161), NX0162
20158 BL(J)=DMIN1(T,BL(J))
      GO TO 20163
20159 BU(J)=DMAX1(T,BU(J))
      GO TO 20163
20160 BL(J)=DMIN1(T,BL(J))
      BU(J)=DMAX1(T,BU(J))
      GO TO 20163
20161 CONTINUE
20162 CONTINUE
20163 GO TO 20151
C
C     MOVE CONSTRAINT DATA BACK TO THE ORIGINAL AREA.
20153 J=NCOLS+1
      N20164=NCOLS+MCON
      GO TO 20165
20164 J=J+1
20165 IF ((N20164-J).LT.0) GO TO 20166
      CALL DCOPY(NCOLS,W(MCON+1,J),1,W(J-NCOLS,1),MDW)
      GO TO 20164
20166 CONTINUE
20140 CONTINUE
20141 IF (.NOT.(MCON.GT.0)) GO TO 20168
      J=NCOLS+1
      N20171=NCOLS+MCON
      GO TO 20172
20171 J=J+1
20172 IF ((N20171-J).LT.0) GO TO 20173
      W(MCON+1,J)=ZERO
      CALL DCOPY(MOUT,W(MCON+1,J),0,W(MCON+1,J),1)
      GO TO 20171
C
C     PUT IN (-)IDENTITY MATRIX (POSSIBLY) ONCE AGAIN.
20173 J=NCOLS+1
      N20175=NCOLS+MCON+1
      GO TO 20176
20175 J=J+1
20176 IF ((N20175-J).LT.0) GO TO 20177
      W(1,J)=ZERO
      CALL DCOPY(MCON,W(1,J),0,W(1,J),1)
      GO TO 20175
20177 W(1,NCOLS+1)=-ONE
      CALL DCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1)
20168 CONTINUE
C
C     COMPUTE NOMINAL COLUMN SCALING FOR THE UNWEIGHTED MATRIX.
20169 CNORM=ZERO
      ANORM=ZERO
      J=1
      N20179=NCOLS
      GO TO 20180
20179 J=J+1
20180 IF ((N20179-J).LT.0) GO TO 20181
      T1=DASUM(MCON,W(1,J),1)
      T2=DASUM(MOUT,W(MCON+1,1),1)
      T=T1+T2
      IF(T.EQ.ZERO)T=ONE
      CNORM=DMAX1(CNORM,T1)
      ANORM=DMAX1(ANORM,T2)
      X(NCOLS+MCON+J)=ONE/T
      GO TO 20179
20181 NX0187=ISCALE
      IF (NX0187.LT.1.OR.NX0187.GT.4) GO TO 20187
      GO TO (20183,20184,20185,20186), NX0187
20183 GO TO 20188
C
C     SCALE COLS. (BEFORE WEIGHTING) TO HAVE LENGTH ONE.
20184 J=1
      N20189=NCOLS
      GO TO 20190
20189 J=J+1
20190 IF ((N20189-J).LT.0) GO TO 20191
      T=DNRM2(MCON+MOUT,W(1,J),1)
      IF(T.EQ.ZERO)T=ONE
      X(NCOLS+MCON+J)=ONE/T
      GO TO 20189
20191 GO TO 20188
C
C     SUPPRESS SCALING (USE UNIT MATRIX).
20185 X(NCOLS+MCON+1)=ONE
      CALL DCOPY(NCOLS,X(NCOLS+MCON+1),0,X(NCOLS+MCON+1),1)
      GO TO 20188
C
C     THE USER HAS PROVIDED SCALING.
20186 CALL DCOPY(NCOLS,RW,1,X(NCOLS+MCON+1),1)
20187 CONTINUE
20188 J=NCOLS+1
      N20193=NCOLS+MCON
      GO TO 20194
20193 J=J+1
20194 IF ((N20193-J).LT.0) GO TO 20195
      X(NCOLS+MCON+J)=ONE
      GO TO 20193
C
C     WEIGHT THE LEAST SQUARES EQUATIONS.
20195 WT=SRELPR
      IF(ANORM.GT.ZERO)WT=WT/ANORM
      IF(CNORM.GT.ZERO)WT=WT*CNORM
      I=1
      N20197=MOUT
      GO TO 20198
20197 I=I+1
20198 IF ((N20197-I).LT.0) GO TO 20199
      CALL DSCAL(NCOLS,WT,W(I+MCON,1),MDW)
      GO TO 20197
20199 CALL DSCAL(MOUT,WT,W(MCON+1,MCON+NCOLS+1),1)
      LRW=1
      LIW=1
C
C     SET THE NEW TRIANGULARIZATION FACTOR.
      X(2*(NCOLS+MCON)+1)=ZERO
C
C     SET THE WEIGHT TO USE IN COMPONENTS .GT. MCON,
C     WHEN MAKING LINEAR INDEPENDENCE TEST.
      X(2*(NCOLS+MCON)+2)=ONE/WT
      CALL DBOLS(W,MDW,MOUT+MCON,NCOLS+MCON,BL,BU,IND,IOPT(LBOU),X,
     * REAL(RNORM),MODE,RW(LRW),IW(LIW))
      RNORM=RNORM/WT
      GO TO 20012
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
30006 IGO=0
      IF(.TRUE.) RETURN
      GO TO NPR006, (20016,20020,20024,20028,20032,20036,20040,20044,200
     *48,20052,20060,20071,20101,20108,20116,20126,20133)
      END
      SUBROUTINE DBOLSM(W,MDW,MINPUT,NCOLS,BL,BU,IND,
     *  IOPT,X,RNORM,MODE,RW,WW,SCL,IBASIS,IBB)
C
C     PURPOSE
C     -------
C     THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED
C     LEAST SQUARES PROBLEM.  THE PROBLEM SOLVED HERE IS:
C
C     SOLVE E*X =  F  (LEAST SQUARES SENSE)
C     WITH BOUNDS ON SELECTED X VALUES.
C
C     REVISED 831102-1100
C     REVISED YYMMDD-HHMM
C
C     TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN
C     EDITING AT THE CARD 'C++'.
C     CHANGE THE STRINGS / ABS/ TO /DABS/, /DMAX1/ TO /DMAX1/,
C     /DAXPY/ TO /DAXPY/, /DCOPY/ TO /DCOPY/, /DMIN1/ TO /DMIN1/,
C     /DDOT/ TO /DDOT/, /DNRM2/ TO /DNRM2/, /DSQRT/ TO /DDSQRT/,
C     /DROT/ TO /DROT/, /DROTG/ TO /DROTG/, /D1MACH/ TO /D1MACH/,
C     /DSWAP/ TO /DSWAP/, /DASUM/ TO /DASUM/.
C     /DOUBLE PRECISION            / TO /DOUBLE PRECISION/.
C++
C
C     THIS VARIABLE REMAINS TYPE REAL.
CCCCC REAL RDUM
      DOUBLE PRECISION W(MDW,*),BL(*),BU(*), X(*),RW(*),WW(*),SCL(*)
      DOUBLE PRECISION             ALPHA, BETA, BOU, COLABV, COLBLO
      DOUBLE PRECISION             CL1, CL2, CL3, ONE, BIG
      DOUBLE PRECISION             FAC, RNORM, SC, SS, T, TOLIND, WT
      DOUBLE PRECISION TWO, T1, T2, WBIG, WLARGE, WMAG, XNEW
CCCCC DOUBLE PRECISION ZERO,  DABS, DMAX1, DMIN1, DDOT, DNRM2, DSQRT
CCCCC DOUBLE PRECISION             DASUM, TOLSZE
      DOUBLE PRECISION ZERO,  DABS, DMIN1, DDOT, DNRM2, DSQRT
      DOUBLE PRECISION             TOLSZE
      INTEGER   IBASIS(*),IBB(*),IND(*),IOPT(*)
      LOGICAL FOUND,CONSTR
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRNT2
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRNT2
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      INEXT(IDUM)=MIN0(IDUM+1,MROWS)
      LEVEL=1
C
C    VERIFY THAT THE PROBLEM DIMENSIONS ARE DEFINED PROPERLY.
      IF (.NOT.(MINPUT.LE.0)) GO TO 20002
      NERR=31
      NCHAR=51
CCCCC CALL XERRWV('DBOLSM(). THE NUMBER OF ROWS=(I1) MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,LEVEL, 1,MINPUT,IDUM, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** ERROR FROM DBSOLM.  THE NUMBER OF ROWS MUST BE ',
     1'POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20005 TO NPR001
      GO TO 30001
20005 CONTINUE
20002 IF (.NOT.(NCOLS.LE.0)) GO TO 20006
      NERR=32
      NCHAR=51
CCCCC CALL XERRWV('DBOLSM(). THE NUMBER OF COLS.=(I1) MUST BE POSTIVE.',
CCCCC* NCHAR,NERR,LEVEL, 1,NCOLS,IDUM, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)
   61 FORMAT('***** ERROR FROM DBSOLM.  THE NUMBER OF COLUMNS MUST ',
     1'BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20009 TO NPR001
      GO TO 30001
20009 CONTINUE
20006 IF (.NOT.(MDW.LT.MINPUT)) GO TO 20010
      NERR=33
      NCHAR=78
CCCCC CALL XERRWV('DBOLSM(). THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.
CCCCC* THE NUMBER OF ROWS=(I2).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 2,MDW,MROWS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)MDW
   71 FORMAT('***** ERROR FROM DBSOLM.  THE ROW DIMENSION OF W = ',I5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)MINPUT
   72 FORMAT('      MUST BE GREATER THAN OR EQUAL TO THE NUMBER OF ',
     1'ROWS = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20013 TO NPR001
      GO TO 30001
20013 CONTINUE
C
C     VERIFY THAT BOUND INFORMATION IS CORRECT.
20010 J=1
      N20014=NCOLS
      GO TO 20015
20014 J=J+1
20015 IF ((N20014-J).LT.0) GO TO 20016
      IF (.NOT.(IND(J).LT.1 .OR. IND(J).GT.4)) GO TO 20018
      NERR=34
      NCHAR=58
CCCCC CALL XERRWV('DBOLSM(). FOR J=(I1) THE CONSTRAINT INDICATOR MUST BE
CCCCC* 1-4.',NCHAR,NERR,LEVEL,
CCCCC* 2, J,IND(J), 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)J
   81 FORMAT('***** ERROR FROM DBSOLM.  FOR J = ',I5,', THE ',
     1'CONSTRAINT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)MINPUT
   82 FORMAT('      INDICATOR MUST BE 1-4.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20021 TO NPR001
      GO TO 30001
20021 CONTINUE
20018 CONTINUE
20019 GO TO 20014
20016 J=1
      N20022=NCOLS
      GO TO 20023
20022 J=J+1
20023 IF ((N20022-J).LT.0) GO TO 20024
      IF (.NOT.(IND(J).EQ.3)) GO TO 20026
      IF (.NOT.(BU(J).LT.BL(J))) GO TO 20029
      NERR=35
      NCHAR=71
CCCCC CALL XERRWV('DBOLSM(). FOR J=(I1) THE LOWER BOUND=(R1) IS .GT. THE
CCCCC* UPPER BOUND=(R2).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,J,IDUM, 2,BL(J),BU(J))
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,91)J,BL(J)
   91 FORMAT('***** ERROR FROM DBSOLM.  FOR J = ',I5,', THE ',
     1'LOWER BOUND = ',F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,92)BU(J)
   92 FORMAT('      IS GREATER THAN THE UPPER BOUND = ',F10.5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20032 TO NPR001
      GO TO 30001
20032 CONTINUE
20029 CONTINUE
20026 CONTINUE
20027 GO TO 20022
C
C     CHECK THAT PERMUTATION AND POLARITY ARRAYS HAVE BEEN SET.
20024 J=1
      N20033=NCOLS
      GO TO 20034
20033 J=J+1
20034 IF ((N20033-J).LT.0) GO TO 20035
      IF (.NOT.(IBASIS(J).LT.1 .OR. IBASIS(J).GT.NCOLS)) GO TO 20037
      NERR=36
      NCHAR=74
CCCCC CALL XERRWV('DBOLSM(). THE INPUT ORDER OF COLUMNS=(I1) IS NOT BETW
CCCCC*EEN 1 AND NCOLS=(I2).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 2, IBASIS(J),NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)IBASIS(J)
  101 FORMAT('***** ERROR FROM DBSOLM.  THE INPUT ORDER OF COLUMNS ',
     1I5,' IS NOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)NCOLS
  102 FORMAT('      BETWEEN 1 AND NCOLS = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20040 TO NPR001
      GO TO 30001
20040 CONTINUE
20037 CONTINUE
20038 IF (.NOT.(IBB(J).LE.0)) GO TO 20041
      NERR=37
      NCHAR=81
CCCCC CALL XERRWV('DBOLSM(). THE BOUND POLARITY FLAG IN COMPONENT J=(I1)
CCCCC* MUST BE POSITIVE. NOW=(I2).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 2,J,IBB(J), 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR FROM DBSOLM.  THE BOUND POLARITY FLAG FOR ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)J,IBB(J)
  112 FORMAT('      COMPONENT J = ',I5,' MUST BE POSITIVE.  IT IS ',
     1'EQUAL TO ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20044 TO NPR001
      GO TO 30001
20044 CONTINUE
20041 CONTINUE
20042 GO TO 20033
20035 CONTINUE
      GO TO 30002
20045 CONTINUE
      GO TO 30003
20046 IF (.NOT.(IPRINT.GT.0)) GO TO 20047
      CALL DMOUT(MROWS,NCOLS+1,MDW,W,'('' PRETRI. INPUT MATRIX'')',-4)
      CALL SVOUT(NCOLS,BL,'('' LOWER BOUNDS'')',-4)
      CALL SVOUT(NCOLS,BU,'('' UPPER BOUNDS'')',-4)
20047 CONTINUE
20050 ITER=ITER+1
      IF (.NOT.(ITER.GT.ITMAX)) GO TO 20052
      NERR=21
      NCHAR=80
CCCCC CALL XERRWV('DBOLSM(). MORE THAN (I1)=ITMAX ITERATIONS SOLVING BOU
CCCCC*NDED LEAST SQUARES PROBLEM.',NCHAR,NERR,LEVEL,
CCCCC* 1,ITMAX,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)ITMAX
  121 FORMAT('***** ERROR FROM DBSOLM.  MOTE THAN ',I5,' ITERATIONS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      SOLVING BOUNDED LEAST SQUARES PROBLEM.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20055 TO NPR004
      GO TO 30004
20055 ASSIGN 20056 TO NPR001
      GO TO 30001
20056 CONTINUE
20052 CONTINUE
20053 CONTINUE
      GO TO 30005
20057 IF (.NOT.(.NOT. FOUND)) GO TO 20058
      ASSIGN 20061 TO NPR004
      GO TO 30004
20061 MODE=NSETB
      RETURN
20058 CONTINUE
      GO TO 30006
20062 CONTINUE
20059 CONTINUE
20060 GO TO 20050
20051 CONTINUE
C     PROCEDURE(RESCALE AND TRANSLATE VARIABLES)
30004 CALL DCOPY(NSETB,X,1,RW,1)
      X(1)=ZERO
      CALL DCOPY(NCOLS,X,0,X,1)
      J=1
      N20063=NSETB
      GO TO 20064
20063 J=J+1
20064 IF ((N20063-J).LT.0) GO TO 20065
      JCOL=IABS(IBASIS(J))
      X(JCOL)=RW(J)*DABS(SCL(JCOL))
      GO TO 20063
20065 J=1
      N20067=NCOLS
      GO TO 20068
20067 J=J+1
20068 IF ((N20067-J).LT.0) GO TO 20069
      IF(MOD(IBB(J),2).EQ.0)X(J)=BU(J)-X(J)
      GO TO 20067
20069 J=1
      N20071=NCOLS
      GO TO 20072
20071 J=J+1
20072 IF ((N20071-J).LT.0) GO TO 20073
      JCOL=IBASIS(J)
      IF(JCOL.LT.0)X(-JCOL)=BL(-JCOL)+X(-JCOL)
      GO TO 20071
20073 J=1
      N20075=NCOLS
      GO TO 20076
20075 J=J+1
20076 IF ((N20075-J).LT.0) GO TO 20077
      IF(SCL(J).LT.ZERO)X(J)=-X(J)
      GO TO 20075
20077 RNORM=ZERO
      I=NSETB+1
      N20079=MROWS
      GO TO 20080
20079 I=I+1
20080 IF ((N20079-I).LT.0) GO TO 20081
      T=W(I,NCOLS+1)
      RNORM=RNORM+T*T
      GO TO 20079
20081 RNORM=DSQRT(RNORM)
      GO TO NPR004, (20055,20061)
C     PROCEDURE(FIND A VARIABLE TO BECOME NON-ACTIVE)
C
C     COMPUTE (NEGATIVE) OF GRADIENT VECTOR, W=
C     (TRANSPOSE OF E)*(F-E*X).
30005 WW(1)=ZERO
      CALL DCOPY(NCOLS,WW,0,WW,1)
      J=NSETB+1
      N20083=NCOLS
      GO TO 20084
20083 J=J+1
20084 IF ((N20083-J).LT.0) GO TO 20085
      JCOL=IABS(IBASIS(J))
      WW(J)=
     *DDOT(MROWS-NSETB,W(INEXT(NSETB),J),1,W(INEXT(NSETB),NCOLS+1),1)
     * * DABS(SCL(JCOL))
      GO TO 20083
20085 IF (.NOT.(IPRINT.GT.0)) GO TO 20087
      CALL SVOUT(NCOLS,WW,'('' GRADIENT VALUES'')',-4)
      CALL IVOUT(NCOLS,IBASIS,'('' INTERNAL VARIABLE ORDER'')',-4)
      CALL IVOUT(NCOLS,IBB,'('' BOUND POLARITY'')',-4)
20087 CONTINUE
C
C     IF ACTIVE SET = NUMBER OF TOTAL ROWS, QUIT.
20090 IF (.NOT.(NSETB.EQ.MROWS)) GO TO 20092
      FOUND=.FALSE.
      GO TO 31005
C
C     CHOOSE AN EXTREMAL COMPONENT OF GRADIENT VECTOR
C     FOR A CANDIDATE TO BECOME NON-ACTIVE.
20092 WLARGE=-BIG
      WMAG=-BIG
      J=NSETB+1
      N20095=NCOLS
      GO TO 20096
20095 J=J+1
20096 IF ((N20095-J).LT.0) GO TO 20097
      T=WW(J)
      IF (T.EQ.BIG) GO TO 20095
      ITEMP=IBASIS(J)
      JCOL=IABS(ITEMP)
      T1=DNRM2(MVAL-NSETB,W(INEXT(NSETB),J),1)
      IF (.NOT.(ITEMP.LT.0)) GO TO 20099
      IF(MOD(IBB(JCOL),2).EQ.0)T=-T
      IF (T.LT.ZERO) GO TO 20095
      IF(MVAL.GT.NSETB)T=T1
      IF (.NOT.(T.GT.WLARGE)) GO TO 20102
      WLARGE=T
      JLARGE=J
20102 GO TO 20100
20099 IF(MVAL.GT.NSETB)T=T1
      IF (.NOT.( DABS(T).GT.WMAG)) GO TO 20105
      WMAG= DABS(T)
      JMAG=J
20105 CONTINUE
20100 GO TO 20095
C
C     CHOOSE MAG. OF LARGEST COMPONENT OF GRADIENT FOR CANDIDATE.
20097 JBIG=0
      WBIG=ZERO
      IF (.NOT.(WLARGE.GT.ZERO)) GO TO 20108
      JBIG=JLARGE
      WBIG=WLARGE
20108 IF (.NOT.(WMAG.GE.WBIG)) GO TO 20111
      JBIG=JMAG
      WBIG=WMAG
20111 IF (.NOT.(JBIG.EQ.0)) GO TO 20114
      FOUND=.FALSE.
      IF (.NOT.(IPRINT.GT.0)) GO TO 20117
      CALL IVOUT(0,I,'('' FOUND NO VARIABLE TO ENTER'')',-4)
20117 GO TO 31005
C
C     SEE IF THE INCOMING COL. IS SUFFICIENTLY INDEPENDENT.
C     THIS TEST IS MADE BEFORE AN ELIMINATION IS PERFORMED.
20114 IF (.NOT.(IPRINT.GT.0)) GO TO 20120
      CALL IVOUT(1,JBIG,'('' TRY TO BRING IN THIS COL.'')',-4)
20120 IF (.NOT.(MVAL.LE.NSETB)) GO TO 20123
      CL1=DNRM2(MVAL,W(1,JBIG),1)
      CL2=DABS(WT)*DNRM2(NSETB-MVAL,W(INEXT(MVAL),JBIG),1)
      CL3=DABS(WT)*DNRM2(MROWS-NSETB,W(INEXT(NSETB),JBIG),1)
      COLABV=DSQRT(CL1**2+CL2**2)
      COLBLO=CL3
      GO TO 20124
20123 CL1=DNRM2(NSETB,W(1,JBIG),1)
      CL2=DNRM2(MVAL-NSETB,W(INEXT(NSETB),JBIG),1)
      CL3=DABS(WT)*DNRM2(MROWS-MVAL,W(INEXT(MVAL),JBIG),1)
      COLABV=CL1
      COLBLO=DSQRT(CL2**2+CL3**2)
20124 IF (.NOT.(COLBLO .LE. TOLIND*COLABV)) GO TO 20126
      WW(JBIG)=BIG
      IF (.NOT.(IPRINT.GT.0)) GO TO 20129
      CALL IVOUT(0,I,'('' VARIABLE IS DEPENDENT; NOT USED.'')',-4)
20129 GO TO 20090
C
C     SWAP MATRIX COLS. NSETB+1 AND JBIG, PLUS POINTER INFO., AND
C     GRADIENT VALUES.
20126 NSETB=NSETB+1
      IF (.NOT.(NSETB.NE.JBIG)) GO TO 20132
      CALL DSWAP(MROWS,W(1,NSETB),1,W(1,JBIG),1)
      CALL DSWAP(    1,WW(NSETB),1   ,WW(JBIG),1)
      ITEMP=IBASIS(NSETB)
      IBASIS(NSETB)=IBASIS(JBIG)
      IBASIS(JBIG)=ITEMP
C
C     ELIMINATE ENTRIES BELOW THE PIVOT LINE IN COL. NSETB.
20132 IF (.NOT.(MROWS.GT.NSETB)) GO TO 20135
      I=MROWS
      N20138=NSETB+1
      GO TO 20139
20138 I=-1+I
20139 IF (-(N20138-I).LT.0) GO TO 20140
      IF (I.EQ.MVAL+1) GO TO 20138
      CALL DROTG(W(I-1,NSETB),W(I,NSETB),SC,SS)
      W(I,NSETB)=ZERO
      CALL DROT(NCOLS-NSETB+1,W(I-1,NSETB+1),MDW,W(I,NSETB+1),MDW,
     * SC,SS)
      GO TO 20138
20140 IF (.NOT.(MVAL.GE.NSETB)) GO TO 20142
      CALL DROTG(W(NSETB,NSETB),W(MVAL+1,NSETB),SC,SS)
      W(MVAL+1,NSETB)=ZERO
      CALL DROT(NCOLS-NSETB+1,W(NSETB,NSETB+1),MDW,W(MVAL+1,NSETB+1),
     * MDW,SC,SS)
20142 CONTINUE
20135 IF (.NOT.(W(NSETB,NSETB).EQ.ZERO)) GO TO 20145
      WW(NSETB)=BIG
      NSETB=NSETB-1
      IF (.NOT.(IPRINT.GT.0)) GO TO 20148
      CALL IVOUT(0,I,'('' PIVOT IS ZERO; NOT USED.'')',-4)
20148 GO TO 20090
C
C     CHECK THAT NEW VARIABLE IS MOVING IN THE RIGHT DIRECTION.
20145 ITEMP=IBASIS(NSETB)
      JCOL=IABS(ITEMP)
      XNEW=W(NSETB,NCOLS+1)/(W(NSETB,NSETB)*DABS(SCL(JCOL)))
      IF (.NOT.(ITEMP.LT.0)) GO TO 20153
      IF (WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) GO TO 20152
      IF (WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) GO TO 20152
20153 GO TO 20151
20152 WW(NSETB)=BIG
      NSETB=NSETB-1
      IF (.NOT.(IPRINT.GT.0)) GO TO 20156
      CALL IVOUT(0,I,'('' VARIABLE HAS BAD DIRECTION; NOT USED.'')',-4)
20156 CONTINUE
20157 GO TO 20090
20151 FOUND=.TRUE.
      GO TO 31005
20091 CONTINUE
31005 GO TO 20057
C     PROCEDURE(SOLVE THE TRIANGULAR SYSTEM)
30007 CALL DCOPY(NSETB,W(1,NCOLS+1),1,RW,1)
      J=NSETB
      GO TO 20160
20159 J=-1+J
20160 IF (-(1-J).LT.0) GO TO 20161
      RW(J)=RW(J)/W(J,J)
      JCOL=IABS(IBASIS(J))
      T=RW(J)
      IF(MOD(IBB(JCOL),2).EQ.0)RW(J)=-RW(J)
      CALL DAXPY(J-1,-T,W(1,J),1,RW,1)
      RW(J)=RW(J)/DABS(SCL(JCOL))
      GO TO 20159
20161 IF (.NOT.(IPRINT.GT.0)) GO TO 20163
      CALL SVOUT(NSETB,RW,'('' SOLN. VALUES'')',-4)
      CALL IVOUT(NSETB,IBASIS,'('' COLS. USED'')',-4)
20163 CONTINUE
31007 GO TO NPR007, (20166,20233)
C     PROCEDURE(MAKE MOVE AND UPDATE FACTORIZATION)
30006 ASSIGN 20166 TO NPR007
      GO TO 30007
C
C     SEE IF THE UNCONSTRAINED SOL. (OBTAINED BY SOLVING THE
C     TRIANGULAR SYSTEM) SATISFIES THE PROBLEM BOUNDS.
20166 ALPHA=TWO
      BETA=TWO
      X(NSETB)=ZERO
      J=1
      N20167=NSETB
      GO TO 20168
20167 J=J+1
20168 IF ((N20167-J).LT.0) GO TO 20169
      ITEMP=IBASIS(J)
      JCOL=IABS(ITEMP)
      T1=TWO
      T2=TWO
      IF (.NOT.(ITEMP.LT.0)) GO TO 20171
      BOU=ZERO
      GO TO 20172
20171 BOU=BL(JCOL)
20172 CONTINUE
20173 IF((-BOU).NE.BIG)BOU=BOU/DABS(SCL(JCOL))
      IF(RW(J).LE.BOU)T1=(X(J)-BOU)/(X(J)-RW(J))
      BOU=BU(JCOL)
      IF(BOU.NE.BIG)BOU=BOU/DABS(SCL(JCOL))
      IF(RW(J).GE.BOU)T2=(BOU-X(J))/(RW(J)-X(J))
C
C     IF NOT, THEN COMPUTE A STEP LENGTH SO THAT THE
C     VARIABLES REMAIN FEASIBLE.
      IF (.NOT.(T1.LT.ALPHA)) GO TO 20174
      ALPHA=T1
      JDROP1=J
20174 CONTINUE
20175 IF (.NOT.(T2.LT.BETA)) GO TO 20177
      BETA=T2
      JDROP2=J
20177 CONTINUE
20178 GO TO 20167
20169 CONSTR=ALPHA.LT.TWO .OR. BETA.LT.TWO
      IF (.NOT.(.NOT. CONSTR)) GO TO 20180
C
C     ACCEPT THE CANDIDATE BECAUSE IT SATISFIES THE STATED BOUNDS
C     ON THE VARIABLES.
      CALL DCOPY(NSETB,RW,1,X,1)
      GO TO 31006
C
C     TAKE A STEP THAT IS AS LARGE AS POSSIBLE WITH ALL
C     VARIABLES REMAINING FEASIBLE.
20180 J=1
      N20183=NSETB
      GO TO 20184
20183 J=J+1
20184 IF ((N20183-J).LT.0) GO TO 20185
      X(J)=X(J)+DMIN1(ALPHA,BETA)*(RW(J)-X(J))
      GO TO 20183
20185 IF (.NOT.(ALPHA.LE.BETA)) GO TO 20187
      JDROP2=0
      GO TO 20188
20187 JDROP1=0
20188 CONTINUE
20190 IF (.NOT.(JDROP1+JDROP2.GT.0.AND.NSETB.GT.0)) GO TO 20191
      JDROP=JDROP1+JDROP2
      ITEMP=IBASIS(JDROP)
      JCOL=IABS(ITEMP)
      IF (.NOT.(JDROP2.GT.0)) GO TO 20192
C
C     VARIABLE IS AT AN UPPER BOUND.  SUBTRACT MULTIPLE OF THIS COL.
C     FROM RIGHT HAND SIDE.
      T=BU(JCOL)
      IF (.NOT.(ITEMP.GT.0)) GO TO 20195
      BU(JCOL)=T-BL(JCOL)
      BL(JCOL)=-T
      ITEMP=-ITEMP
      SCL(JCOL)=-SCL(JCOL)
      I=1
      N20198=JDROP
      GO TO 20199
20198 I=I+1
20199 IF ((N20198-I).LT.0) GO TO 20200
      W(I,JDROP)=-W(I,JDROP)
      GO TO 20198
20200 GO TO 20196
20195 IBB(JCOL)=IBB(JCOL)+1
      IF(MOD(IBB(JCOL),2).EQ.0)T=-T
C     VARIABLE IS AT A LOWER BOUND.
20196 GO TO 20193
20192 IF (.NOT.(ITEMP.LT.ZERO)) GO TO 20202
      T=ZERO
      GO TO 20203
20202 T=-BL(JCOL)
      BU(JCOL)=BU(JCOL)+T
      ITEMP=-ITEMP
20203 CONTINUE
20193 CONTINUE
20194 CALL DAXPY(JDROP,T,W(1,JDROP),1,W(1,NCOLS+1),1)
C
C     MOVE CERTAIN COLS. LEFT TO ACHIEVE UPPER HESSENBERG FORM.
      CALL DCOPY(JDROP,W(1,JDROP),1,RW,1)
      J=JDROP+1
      N20205=NSETB
      GO TO 20206
20205 J=J+1
20206 IF ((N20205-J).LT.0) GO TO 20207
      IBASIS(J-1)=IBASIS(J)
      X(J-1)=X(J)
      CALL DCOPY(J,W(1,J),1,W(1,J-1),1)
      GO TO 20205
20207 IBASIS(NSETB)=ITEMP
      W(1,NSETB)=ZERO
      CALL DCOPY(MROWS-JDROP,W(1,NSETB),0,W(JDROP+1,NSETB),1)
      CALL DCOPY(JDROP,RW,1,W(1,NSETB),1)
C
C     TRANSFORM THE MATRIX FROM UPPER HESSENBERG FORM TO
C     UPPER TRIANGULAR FORM.
      NSETB=NSETB-1
      I=JDROP
      N20211=NSETB
      GO TO 20212
20211 I=I+1
20212 IF ((N20211-I).LT.0) GO TO 20213
C
C     LOOK FOR SMALL PIVOTS AND AVOID MIXING WEIGHTED AND
C     NONWEIGHTED ROWS.
      IF (.NOT.(I.EQ.MVAL)) GO TO 20215
      T=ZERO
      J=I
      N20218=NSETB
      GO TO 20219
20218 J=J+1
20219 IF ((N20218-J).LT.0) GO TO 20220
      JCOL=IABS(IBASIS(J))
      T1=DABS(W(I,J)*SCL(JCOL))
      IF (.NOT.(T1.GT.T)) GO TO 20222
      JBIG=J
      T=T1
20222 GO TO 20218
20220 GO TO 20210
20215 CALL DROTG(W(I,I),W(I+1,I),SC,SS)
      W(I+1,I)=ZERO
      CALL DROT(NCOLS-I+1,W(I,I+1),MDW,W(I+1,I+1),MDW,SC,SS)
      GO TO 20211
20213 GO TO 20209
C
C     THE TRIANGULARIZATION IS COMPLETED BY GIVING UP
C     THE HESSENBERG FORM AND TRIANGULARIZING A RECTANGULAR MATRIX.
20210 CALL DSWAP(MROWS,W(1,I),1,W(1,JBIG),1)
      CALL DSWAP(    1,WW(I),1,WW(JBIG),1)
      CALL DSWAP(    1,X(I),1,X(JBIG),1)
      ITEMP=IBASIS(I)
      IBASIS(I)=IBASIS(JBIG)
      IBASIS(JBIG)=ITEMP
      JBIG=I
      J=JBIG
      N20225=NSETB
      GO TO 20226
20225 J=J+1
20226 IF ((N20225-J).LT.0) GO TO 20227
      I=J+1
      N20229=MROWS
      GO TO 20230
20229 I=I+1
20230 IF ((N20229-I).LT.0) GO TO 20231
      CALL DROTG(W(J,J),W(I,J),SC,SS)
      W(I,J)=ZERO
      CALL DROT(NCOLS-J+1,W(J,J+1),MDW,W(I,J+1),MDW,SC,SS)
      GO TO 20229
20231 GO TO 20225
20227 CONTINUE
C
C     SEE IF THE REMAINING COEFFICIENTS ARE FEASIBLE.  THEY SHOULD
C     BE BECAUSE OF THE WAY MIN(ALPHA,BETA) WAS CHOSEN.  ANY THAT ARE
C     NOT FEASIBLE WILL BE SET TO THEIR BOUNDS AND
C     APPROPRIATELY TRANSLATED.
20209 JDROP1=0
      JDROP2=0
      ASSIGN 20233 TO NPR007
      GO TO 30007
20233 CALL DCOPY(NSETB,RW,1,X,1)
      J=1
      N20234=NSETB
      GO TO 20235
20234 J=J+1
20235 IF ((N20234-J).LT.0) GO TO 20236
      ITEMP=IBASIS(J)
      JCOL=IABS(ITEMP)
      IF (.NOT.(ITEMP.LT.0)) GO TO 20238
      BOU=ZERO
      GO TO 20239
20238 BOU=BL(JCOL)
20239 IF((-BOU).NE.BIG)BOU=BOU/DABS(SCL(JCOL))
      IF (.NOT.(X(J).LE.BOU)) GO TO 20241
      JDROP1=J
      GO TO 20190
20241 BOU=BU(JCOL)
      IF(BOU.NE.BIG)BOU=BOU/DABS(SCL(JCOL))
      IF (.NOT.(X(J).GE.BOU)) GO TO 20244
      JDROP2=J
      GO TO 20190
20244 GO TO 20234
20236 GO TO 20190
20191 CONTINUE
20181 CONTINUE
31006 GO TO 20062
C     PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES)
C
C     PRETRIANGULARIZE RECTANGULAR ARRAYS OF CERTAIN SIZES
C     FOR INCREASED EFFICIENCY.
30003 IF (.NOT.(FAC*MINPUT.GT.NCOLS)) GO TO 20247
      J=1
      N20250=NCOLS+1
      GO TO 20251
20250 J=J+1
20251 IF ((N20250-J).LT.0) GO TO 20252
      I=MINPUT
      N20254=J+MVAL+1
      GO TO 20255
20254 I=-1+I
20255 IF (-(N20254-I).LT.0) GO TO 20256
      CALL DROTG(W(I-1,J),W(I,J),SC,SS)
      W(I,J)=ZERO
      CALL DROT(NCOLS-J+1,W(I-1,J+1),MDW,W(I,J+1),MDW,SC,SS)
      GO TO 20254
20256 GO TO 20250
20252 MROWS=NCOLS+MVAL+1
      GO TO 20248
20247 MROWS=MINPUT
C
C      SET THE X(*) ARRAY TO ZERO SO ALL COMPONENTS ARE DEFINED.
20248 X(1)=ZERO
      CALL DCOPY(NCOLS,X,0,X,1)
C
C     THE ARRAYS IBASIS(*), IBB(*) ARE INITIALIZED BY THE CALLING
C     PROGRAM UNIT.
C     THE COL. SCALING IS DEFINED IN THE CALLING PROGRAM UNIT.
C    'BIG' IS PLUS INFINITY ON THIS MACHINE.
      BIG=D1MACH(2)
      J=1
      N20258=NCOLS
      GO TO 20259
20258 J=J+1
20259 IF ((N20258-J).LT.0) GO TO 20260
      ICASE=IND(J)
      NX0266=ICASE
      IF (NX0266.LT.1.OR.NX0266.GT.4) GO TO 20266
      GO TO (20262,20263,20264,20265), NX0266
20262 BU(J)=BIG
      GO TO 20267
20263 BL(J)=-BIG
      GO TO 20267
20264 GO TO 20267
20265 BL(J)=-BIG
      BU(J)= BIG
20266 CONTINUE
20267 GO TO 20258
20260 J=1
      N20268=NCOLS
      GO TO 20269
20268 J=J+1
20269 IF ((N20268-J).LT.0) GO TO 20270
      IF (.NOT.((BL(J).LE.ZERO.AND.ZERO.LE.BU(J).AND.DABS(BU(J)).LT.
     *        DABS(BL(J))).OR.BU(J).LT.ZERO)) GO TO 20272
      T=BU(J)
      BU(J)=-BL(J)
      BL(J)=-T
      SCL(J)=-SCL(J)
      I=1
      N20275=MROWS
      GO TO 20276
20275 I=I+1
20276 IF ((N20275-I).LT.0) GO TO 20277
      W(I,J)=-W(I,J)
      GO TO 20275
20277 CONTINUE
C
C     INDICES IN SET T(=TIGHT) ARE DENOTED BY NEGATIVE VALUES
C     OF IBASIS(*).
20272 IF (.NOT.(BL(J).GE.ZERO)) GO TO 20279
      IBASIS(J)=-IBASIS(J)
      T=-BL(J)
      BU(J)=BU(J)+T
      CALL DAXPY(MROWS,T,W(1,J),1,W(1,NCOLS+1),1)
20279 GO TO 20268
20270 NSETB=0
      ITER=0
31003 GO TO 20046
C     PROCEDURE(PROCESS OPTION ARRAY)
30002 ZERO=0.E0
      FAC=0.75
      ONE=1.E0
      TWO=2.E0
      TOLIND=DSQRT(D1MACH(4))
      TOLSZE=DSQRT(D1MACH(4))
      ITMAX=5*MAX0(MROWS,NCOLS)
      WT=ONE
      MVAL=0
      IPRINT=0
C
C     CHANGES TO SOME PARAMETERS CAN OCCUR THROUGH THE OPTION
C     ARRAY, IOPT(*).  PROCESS THIS ARRAY LOOKING CAREFULLY
C     FOR INPUT DATA ERRORS.
      LP=0
      LDS=0
20282 LP=LP+LDS
C
C     TEST FOR NO MORE OPTIONS.
      IP=IOPT(LP+1)
      JP=IABS(IP)
      IF (.NOT.(IP.EQ.99)) GO TO 20284
      GO TO 20283
20284 IF (.NOT.(JP.EQ.99)) GO TO 10001
      LDS=1
      GO TO 20282
10001 IF (.NOT.(JP.EQ.1)) GO TO 10002
C
C     MOVE THE IOPT(*) PROCESSING POINTER.
      IF (.NOT.(IP.GT.0)) GO TO 20287
      LP=IOPT(LP+2)-1
      LDS=0
      GO TO 20288
20287 LDS=2
20288 GO TO 20282
10002 IF (.NOT.(JP.EQ.2)) GO TO 10003
C
C     CHANGE TOLERANCE FOR RANK DETERMINATION.
      IF (.NOT.(IP.GT.0)) GO TO 20290
      IOFF=IOPT(LP+2)
      IF (.NOT.(IOFF.LE.0)) GO TO 20293
      NERR=24
      NCHAR=89
CCCCC CALL XERRWV('DBOLSM(). THE OFFSET=(I1) BEYOND POSTION NCOLS=(I2)
CCCCC* MUST BE POSITIVE FOR OPTION NUMBER 2.',NCHAR,NERR,LEVEL,
CCCCC* 2,IOFF,NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)IOFF
  131 FORMAT('***** ERROR FROM DBSOLM.  THE OFFSET = ',I5,' BEYOND ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)NCOLS
  132 FORMAT('      POSITION NCOLS = ',I5,' MUST BE POSITIVE FOR ',
     1'OPTION 2.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20296 TO NPR001
      GO TO 30001
20296 CONTINUE
20293 TOLIND=X(NCOLS+IOFF)
      IF (.NOT.(TOLIND.LT.D1MACH(4))) GO TO 20297
      NERR=25
      NLEVEL=0
      NCHAR=88
CCCCC CALL XERRWV('DBOLSM(). THE TOLERANCE FOR RANK DETERMINATION=(R1) I
CCCCC*S LESS THAN MACHINE PRECISION=(R2).',NCHAR,NERR,NLEVEL,
CCCCC* 0,IDUM,IDUM, 2,TOLIND,D1MACH(4))
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)TOLIND
  141 FORMAT('***** ERROR FROM DBSOLM.  THE TOLERANCE FOR RANK ',
     1'DETERMINANTION = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)D1MACH(4)
  142 FORMAT('      IS LESS THAN MACHINE PRECISION = ',D15.7)
      CALL DPWRST('XXX','BUG ')
20297 CONTINUE
20290 LDS=2
      GO TO 20282
10003 IF (.NOT.(JP.EQ.3)) GO TO 10004
C
C     CHANGE BLOWUP FACTOR FOR ALLOWING VARIABLES TO BECOME
C     INACTIVE.
      IF (.NOT.(IP.GT.0)) GO TO 20300
      IOFF=IOPT(LP+2)
      IF (.NOT.(IOFF.LE.0)) GO TO 20303
      NERR=26
      NCHAR=89
CCCCC CALL XERRWV('DBOLSM(). THE OFFSET=(I1) BEYOND POSITION NCOLS=(I2)
CCCCC* MUST BE POSTIVE FOR OPTION NUMBER 3.', NCHAR,NERR,LEVEL,
CCCCC* 2,IOFF,NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)IOFF
  151 FORMAT('***** ERROR FROM DBSOLM.  THE OFFSET = ',I5,' BEYOND ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)NCOLS
  152 FORMAT('      POSITION NCOLS = ',I5,' MUST BE POSITIVE FOR ',
     1'OPTION 3.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20306 TO NPR001
      GO TO 30001
20306 CONTINUE
20303 TOLSZE=X(NCOLS+IOFF)
      IF (.NOT.(TOLSZE.LE.ZERO)) GO TO 20307
      NERR=27
CCCCC CALL XERRWV('DBOLSM(). THE RECIPROCAL OF THE BLOW-UP FACTOR FOR RE
CCCCC*JECTING VARIABLES MUST BE POSITIVE. NOW=(R1).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 0,IDUM,IDUM, 1,TOLSZE,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,161)
  161 FORMAT('***** ERROR FROM DBSOLM.  THE RECIPROCAL OF THE BLOW-UP',
     1' FACTOR FOR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,162)TOLSZE
  162 FORMAT('      REJECTING VARIABLES MUST BE POSITIVE.  IT IS ',
     1'NOW = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20310 TO NPR001
      GO TO 30001
20310 CONTINUE
20307 CONTINUE
20300 LDS=2
      GO TO 20282
10004 IF (.NOT.(JP.EQ.4)) GO TO 10005
C
C     CHANGE THE MAX. NO. OF ITERATIONS ALLOWED.
      IF (.NOT.(IP.GT.0)) GO TO 20311
      ITMAX=IOPT(LP+2)
      IF (.NOT.(ITMAX.LE.0)) GO TO 20314
      NERR=28
      NCHAR=65
CCCCC CALL XERRWV('DBOLSM(). THE MAXIMUM NUMBER OF ITERATIONS=(I1) MUST
CCCCC* BE POSITIVE.',NCHAR,NERR,LEVEL,
CCCCC* 1,ITMAX,IDUM, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,171)ITMAX
  171 FORMAT('***** ERROR FROM DBSOLM.  THE MAXIMUM NUMBER OF ',
     1' ITERATIONS = ',I5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,172)
  172 FORMAT('      MUST BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20317 TO NPR001
      GO TO 30001
20317 CONTINUE
20314 CONTINUE
20311 LDS=2
      GO TO 20282
10005 IF (.NOT.(JP.EQ.5)) GO TO 10006
C
C     CHANGE THE FACTOR FOR PRETRIANGULARIZING THE DATA MATRIX.
      IF (.NOT.(IP.GT.0)) GO TO 20318
      IOFF=IOPT(LP+2)
      IF (.NOT.(IOFF.LE.0)) GO TO 20321
      NERR=29
      NCHAR=89
CCCCC CALL XERRWV('DBOLSM(). THE OFFSET=(I1) BEYOND POSITION NCOLS=(I2)
CCCCC* MUST BE POSTIVE FOR OPTION NUMBER 5.', NCHAR,NERR,LEVEL,
CCCCC* 2,IOFF,NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,181)IOFF
  181 FORMAT('***** ERROR FROM DBSOLM.  THE OFFSET = ',I5,' BEYOND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,182)NCOLS
  182 FORMAT('      POSITION NCOLS = ',I5,'MUST BE POSITIVE FOR ',
     1'OPTION 5.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20324 TO NPR001
      GO TO 30001
20324 CONTINUE
20321 FAC=X(NCOLS+IOFF)
      IF (.NOT.(FAC.LT.ZERO)) GO TO 20325
      NERR=30
      NLEVEL=0
      NCHAR=104
CCCCC CALL XERRWV('DBOLSM(). THE FACTOR (NCOLS/MROWS) WHERE PRE-TRIANGUL
CCCCC*ARIZING IS PERFORMED MUST BE NONNEGATIVE. NOW=(R1).',
CCCCC* NCHAR,NERR,NLEVEL,
CCCCC* 0,IDUM,IDUM, 1,FAC,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,191)
  191 FORMAT('***** ERROR FROM DBSOLM.  THE FACTOR (NCOLS/MROWS) ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,192)FAC
  192 FORMAT('      WHERE PRE-TRIANGULARIZATION IS PERFORMED MUST ',
     1'BE NONNEGATIVE.  IT IS NOW = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20328 TO NPR001
      GO TO 30001
20328 CONTINUE
20325 CONTINUE
20318 LDS=2
      GO TO 20282
10006 IF (.NOT.(JP.EQ.6)) GO TO 10007
C
C     CHANGE THE WEIGHTING FACTOR (FROM ONE) TO APPLY TO COMPONENTS
C     NUMBERED .GT. MVAL (INITIALLY SET TO 1.)  THIS TRICK IS NEEDED
C     FOR APPLICATIONS OF THIS SUBPROGRAM TO THE HEAVILY WEIGHTED
C     LEAST SQUARES PROBLEM THAT COME FROM EQUALITY CONSTRAINTS.
      IF (.NOT.(IP.GT.0)) GO TO 20329
      IOFF=IOPT(LP+2)
      MVAL=IOPT(LP+3)
      WT=X(NCOLS+IOFF)
20329 IF (.NOT.(MVAL.LT.0 .OR.MVAL.GT.MINPUT.OR.WT .LE. ZERO)) GO TO 203
     *32
      NERR=38
      NLEVEL=0
      NCHAR=116
CCCCC CALL XERRWV('DBOLSM(). THE ROW SEPARATOR TO APPLY WEIGHTING (I1) M
CCCCC*UST LIE BETWEEN 0 AND MROWS (I2). WEIGHT (R1) MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,NLEVEL,
CCCCC* 2,MVAL,MINPUT, 1,WT,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,201)
  201 FORMAT('***** ERROR FROM DBSOLM.  THE ROW SEPARATOR TO APPLY ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,202)MVAL,WT
  202 FORMAT('      WEIGHTING (',I5,') MUST LIE BETWEEN 0 AND MROWS ',
     1'= ',I5,'.  WEIGHT =',E15.7,' MUST BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20335 TO NPR001
      GO TO 30001
20335 CONTINUE
20332 LDS=3
      GO TO 20282
C
C     TURN ON DEBUG OUTPUT.
10007 IF (.NOT.(JP.EQ.7)) GO TO 10008
      IF(IP.GT.0) IPRINT=1
      LDS=1
      GO TO 20282
10008 NERR=22
      NCHAR=46
CCCCC CALL XERRWV('DBOLSM. THE OPTION NUMBER=(I1) IS NOT DEFINED.',
CCCCC* NCHAR,NERR,LEVEL,1,IP,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,211)
  211 FORMAT('***** ERROR FROM DBSOLM.  THE OPTION NUMBER IS NOT ',
     1'DEFINED.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20336 TO NPR001
      GO TO 30001
20336 CONTINUE
20285 GO TO 20282
20283 CONTINUE
31002 GO TO 20045
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
30001 MODE=-NERR
C
C     THIS TEST IS ONLY FOR AVOIDING A COMPILE ERROR ON
C     THE A-GO-TO AFTER THE RETURN.
      IF(.TRUE.) RETURN
31001 GO TO NPR001, (20005,20009,20013,20021,20032,20040,20044,20056,202
     *96,20306,20310,20317,20324,20328,20335,20336)
      END
      SUBROUTINE DBOLS(W,MDW,MROWS,NCOLS, BL,BU,IND,
     *  IOPT,X,RNORM,MODE,RW,IW)
C
C     SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON
C     SELECTED VARIABLES.
C     REVISED 821222-1250
C     REVISED YYMMDD-HHMM
      DOUBLE PRECISION              W(MDW,*), BL(*),BU(*), X(*),RW(*)
C
C     THIS VARIABLE SHOULD REMAIN TYPE REAL.
CCCCC REAL RDUM
      INTEGER    IND(*),IOPT(*),IW(*)
      LOGICAL CHECKL
      DOUBLE PRECISION DNRM2
      DOUBLE PRECISION DJUNK1
      DOUBLE PRECISION DJUNK2
      SAVE IGO,LOCACC,LOPT,ISCALE
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      DATA IGO/0/
      LEVEL=1
      IF (.NOT.(IGO.EQ.0)) GO TO 20002
      GO TO 30001
20005 CONTINUE
      GO TO 30002
20006 IF (.NOT.(CHECKL)) GO TO 20007
      GO TO 30003
20010 CONTINUE
20007 CONTINUE
20002 NX0013=IGO
      IF (NX0013.LT.1.OR.NX0013.GT.2) GO TO 20013
      GO TO (20011,20012), NX0013
C
C     GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES
C     EQUATIONS AND DIRECTIONS TO QUIT PROCESSING.
20011 CONTINUE
      GO TO 30004
20015 IF (.NOT.(IGO.EQ.2)) GO TO 20016
      IGO=0
20016 GO TO 20014
20012 CONTINUE
      GO TO 30005
20019 CONTINUE
      GO TO 30006
20020 IGO=0
20013 CONTINUE
20014 RETURN
C     PROCEDURE(CHECK LENGTHS OF ARRAYS)
C
C     THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE
C     ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE.
30003 IF (.NOT.(LMDW.LT.MROWS)) GO TO 20021
      NERR=11
      NCHAR=76
CCCCC CALL XERRWV('DBOLS(). THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.
CCCCC*THE NUMBER OF ROWS=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LMDW,MROWS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)LMDW
   51 FORMAT('***** ERROR DBSOL.  THE ROW DIMENSION OF W = ',I5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)MROWS
   52 FORMAT('      MUST BE GREATER THAN OR EQUAL TO THE NUMBER OF ',
     1'ROWS = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20024 TO NPR007
      GO TO 30007
20024 CONTINUE
20021 IF (.NOT.(LNDW.LT.NCOLS+1)) GO TO 20025
      NERR=12
      NCHAR=69
CCCCC CALL XERRWV('DBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .G
CCCCC*E. NCOLS+1=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LNDW,NCOLS+1, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)LNDW
   61 FORMAT('***** ERROR DBSOL.  THE COLUMN DIMENSION OF W = ',I5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)NCOLS+1
   62 FORMAT('      MUST BE GREATER THAN OR EQUAL TO THE NUMBER OF ',
     1'COLUMNS + 1 = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20028 TO NPR007
      GO TO 30007
20028 CONTINUE
20025 IF (.NOT.(LLB.LT.NCOLS)) GO TO 20029
      NERR=13
      NCHAR=88
CCCCC  CALL XERRWV('DBOLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND
CCCCC * IND()=(I1) MUST BE .GE. NCOLS=(I2).',NCHAR,NERR,LEVEL,
CCCCC * 2,LLB,NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)
   71 FORMAT('***** ERROR FROM DBOLS.  THE DIMENSIONS OF THE ARRAYS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)NCOLS
   72 FORMAT('      BL, BU, AND IND MUST BE GREATER THAN OR EQUAL TO ',
     1'NCOLS = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20032 TO NPR007
      GO TO 30007
20032 CONTINUE
20029 IF (.NOT.(LLX.LT.LENX)) GO TO 20033
      NERR=14
      NCHAR=70
CCCCC CALL XERRWV('DBOLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE R
CCCCC*EQD. LENGTH=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLX,LENX, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)LLX
   81 FORMAT('***** ERROR FROM DBOLS.  THE DIMENSION OF X =',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,82)LENX
   82 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO THE REQUIRED ',
     1'LENGTH ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20036 TO NPR007
      GO TO 30007
20036 CONTINUE
20033 IF (.NOT.(LLRW.LT.5*NCOLS)) GO TO 20037
      NERR=15
      NCHAR=62
CCCCC CALL XERRWV('DBOLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 5*NC
CCCCC*OLS=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLRW,5*NCOLS, 0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,91)LLRW
   91 FORMAT('***** ERROR FROM DBOLS.  THE DIMENSION OF RW()=',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,92)5*NCOLS
   92 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'5*NCOLS =',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20040 TO NPR007
      GO TO 30007
20040 CONTINUE
20037 IF (.NOT.(LLIW.LT.2*NCOLS)) GO TO 20041
      NERR=16
      NCHAR=61
CCCCC CALL XERRWV('DBOLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NCO
CCCCC*LS=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LLIW,2*NCOLS,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)LLIW
  101 FORMAT('***** ERROR FROM DBOLS.  THE DIMENSION OF IW()=',I5,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)2*NCOLS
  102 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'2*NCOLS =',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20044 TO NPR007
      GO TO 30007
20044 CONTINUE
20041 IF (.NOT.(LIOPT.LT.LP+1)) GO TO 20045
      NERR=17
      NCHAR=71
CCCCC CALL XERRWV('DBOLS(). THE DIMENSION OF IOPT()=(I1) MUST BE .GE. TH
CCCCC*E REQD. LEN.=(I2).',NCHAR,NERR,LEVEL,
CCCCC* 2,LIOPT,LP+1,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)LIOPT
  111 FORMAT('***** ERROR FROM DBOLS.  THE DIMENSION OF IOPT()=',I5,
     1'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)LP+1
  112 FORMAT('      IT MUST BE GREATER THAN OR EQUAL TO ',
     1'THE REQUIRED LENGTH = ',I5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20048 TO NPR007
      GO TO 30007
20048 CONTINUE
20045 GO TO 20010
C     PROCEDURE(CHECK VALIDITY OF INPUT DATA)
C
C     SEE THAT MDW IS .GT.0. GROSS CHECK ONLY.
30001 IF (.NOT.(MDW.LE.0)) GO TO 20049
      NERR=2
      NCHAR=35
CCCCC CALL XERRWV('DBOLS(). MDW=(I1) MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,MDW,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR FROM DBOLS.  MDW MUST BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20052 TO NPR007
      GO TO 30007
20052 CONTINUE
C
C     SEE THAT NUMBER OF UNKNOWNS IS POSITIVE.
20049 IF (.NOT.(NCOLS.LE.0)) GO TO 20053
      NERR=3
      NCHAR=58
CCCCC CALL XERRWV('DBOLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSI
CCCCC*TIVE.', NCHAR,NERR,LEVEL,
CCCCC* 1,NCOLS,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR FROM DBOLS.  THE NUMBER OF VARIABLES ',
     1'MUST BE POSITIVE,')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20056 TO NPR007
      GO TO 30007
20056 CONTINUE
C
C     SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED.
20053 J=1
      N20057=NCOLS
      GO TO 20058
20057 J=J+1
20058 IF ((N20057-J).LT.0) GO TO 20059
      IF (.NOT.(IND(J).LT.1 .OR. IND(J).GT.4)) GO TO 20061
      NERR=4
      NCHAR=45
CCCCC CALL XERRWV('DBOLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 2,J,IND(J),0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)J,IND(J)
  151 FORMAT('***** ERROR FROM DBOLS.  FOR J = ',I5,', IND(J) = ',I5,
     1'MUST BE 1-4.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20064 TO NPR007
      GO TO 30007
20064 CONTINUE
20061 GO TO 20057
C
C     SEE THAT BOUNDS ARE CONSISTENT.
20059 J=1
      N20065=NCOLS
      GO TO 20066
20065 J=J+1
20066 IF ((N20065-J).LT.0) GO TO 20067
      IF (.NOT.(IND(J).EQ.3)) GO TO 20069
      IF (.NOT.(BL(J) .GT. BU(J))) GO TO 20072
      NERR=5
      NCHAR=57
CCCCC CALL XERRWV('DBOLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=(
CCCCC*R2).', NCHAR,NERR,LEVEL,
CCCCC* 1,J,IDUM, 2,BL(J),BU(J))
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,161)J,BL(J),BU(J)
  161 FORMAT('***** ERROR FROM DBOLS.  FOR J = ',I5,', BOUND BL(J) ',
     1'= ',F10.5,' IS GREATER THAN BU(J) = ',F10.5)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20075 TO NPR007
      GO TO 30007
20075 CONTINUE
20072 CONTINUE
20069 GO TO 20065
20067 GO TO 20005
C     PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM)
C
C     INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS,
C     TO =J,=1, FOR USE IN DBOLSM( ).
30006 J=1
      N20076=NCOLS
      GO TO 20077
20076 J=J+1
20077 IF ((N20076-J).LT.0) GO TO 20078
      IW(J)=J
      IW(J+NCOLS)=1
      RW(3*NCOLS+J)=BL(J)
      RW(4*NCOLS+J)=BU(J)
      GO TO 20076
20078 CALL DBOLSM(W,MDW,MROWS,NCOLS,RW(3*NCOLS+1),RW(4*NCOLS+1),IND,
     *IOPT(LOPT),X,DBLE(RNORM),MODE,RW(NCOLS+1),RW(2*NCOLS+1),RW,
     *IW,IW(NCOLS+1))
      GO TO 20020
C     PROCEDURE(PROCESS OPTION ARRAY)
30002 ZERO=0.E0
      ONE=1.E0
      CHECKL=.FALSE.
      LENX=NCOLS
      ISCALE=1
      IGO=2
      LOPT=0
      LP=0
      LDS=0
20080 LP=LP+LDS
      IP=IOPT(LP+1)
      JP=IABS(IP)
C
C     TEST FOR NO MORE OPTIONS.
      IF (.NOT.(IP.EQ.99)) GO TO 20082
      IF(LOPT.EQ.0)LOPT=LP+1
      GO TO 20081
20082 IF (.NOT.(JP.EQ.99)) GO TO 10001
      LDS=1
      GO TO 20080
10001 IF (.NOT.(JP.EQ.1)) GO TO 10002
      IF (.NOT.(IP.GT.0)) GO TO 20085
C
C     SET UP DIRECTION FLAG, ROW STACKING POINTER
C     LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS.
      LOCACC=LP+2
C
C                  IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION.
C     CONTENTS..   IOPT(LOCACC  )=USER DIRECTION FLAG, 1 OR 2.
C                  IOPT(LOCACC+1)=ROW STACKING POINTER.
C                  IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS.
C     USER ACTION WITH THIS OPTION..
C      (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).
C      MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.)
C      (MOVE BLOCK OF EQUATIONS INTO W(*,*)  STARTING AT FIRST
C       ROW OF W(*,*).  SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.)
C              LOOP
C              CALL DBOLS()
C
C                  IF(IOPT(LOCACC) .EQ. 1) THEN
C                      STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1),
C                       INTO W(*,*).
C                       SET IOPT(LOCACC+2)=NO. OF EQUAS.
C                      IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2.
C                  ELSE IF IOPT(LOCACC) .EQ. 2) THEN
C                      (PROCESS IS OVER. EXIT LOOP.)
C                  ELSE
C                      (ERROR CONDITION. SHOULD NOT HAPPEN.)
C                  END IF
C              END LOOP
C              SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION.
C              CALL DBOLS( )
      IOPT(LOCACC+1)=1
      IGO=1
20085 LDS=4
      GO TO 20080
10002 IF (.NOT.(JP.EQ.2)) GO TO 10003
      IF (.NOT.(IP.GT.0)) GO TO 20088
C
C     GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS.
      LOCDIM=LP+2
C
C     LMDW.GE.MROWS
C     LNDW.GE.NCOLS+1
C     LLB .GE.NCOLS
C     LLX .GE.NCOLS+EXTRA REQD. IN OPTIONS.
C     LLRW.GE.5*NCOLS
C     LLIW.GE.2*NCOLS
C     LIOP.GE. AMOUNT REQD. FOR IOPTION ARRAY.
      LMDW=IOPT(LOCDIM  )
      LNDW=IOPT(LOCDIM+1)
      LLB= IOPT(LOCDIM+2)
      LLX= IOPT(LOCDIM+3)
      LLRW=IOPT(LOCDIM+4)
      LLIW=IOPT(LOCDIM+5)
      LIOPT=IOPT(LOCDIM+6)
      CHECKL=.TRUE.
20088 LDS=8
      GO TO 20080
C
C     OPTION TO MODIFY THE COLUMN SCALING.
10003 IF (.NOT.(JP.EQ.3)) GO TO 10004
      IF (.NOT.(IP.GT.0)) GO TO 20091
      ISCALE=IOPT(LP+2)
C
C     SEE THAT ISCALE IS 1 THRU 3.
      IF (.NOT.(ISCALE.LT.1 .OR. ISCALE.GT.3)) GO TO 20094
      NERR=7
      NCHAR=40
CCCCC CALL XERRWV('DBOLS(). ISCALE OPTION=(I1) MUST BE 1-3.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,ISCALE,IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,166)ISCALE
  166 FORMAT('***** ERROR FROM DBOLS.  ISCALE OPTION = ',I5,' MUST ',
     1'BE 1-3.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20097 TO NPR007
      GO TO 30007
20097 CONTINUE
20094 CONTINUE
20091 LDS=2
      GO TO 20080
C
C     IN THIS OPTION THE USER HAS PROVIDED SCALING.  THE
C     SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)).
10004 IF (.NOT.(JP.EQ.4)) GO TO 10005
      IF (.NOT.(IP.GT.0)) GO TO 20098
      ISCALE=4
      IF (.NOT.(IOPT(LP+2).LE.0)) GO TO 20101
      NERR=8
      NCHAR=85
CCCCC CALL XERRWV('DBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED
CCCCC* COLUMN SCALING MUST BE POSITIVE.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,IOPT(LP+2),IDUM,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,168)IOPT(LP+2)
  168 FORMAT('***** ERROR FROM DBOLS.  OFFSET PAST X(NCOLS) ',I5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,169)
  169 FORMAT('      FOR USER-PROVIDED SCALING MUST BE POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20104 TO NPR007
      GO TO 30007
20104 CONTINUE
20101 CALL DCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1)
      LENX=LENX+NCOLS
      J=1
      N20105=NCOLS
      GO TO 20106
20105 J=J+1
20106 IF ((N20105-J).LT.0) GO TO 20107
      IF (.NOT.(RW(J).LE.ZERO)) GO TO 20109
      NERR=9
      NCHAR=85
CCCCC CALL XERRWV('DBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSI
CCCCC*TIVE. COMPONENT (I1) NOW = (R1).',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,J,IDUM,1,RW(J),RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,191)
  191 FORMAT('***** ERROR FROM DBOLS.  EACH PROVIDED COLUMN SCALE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,192)J,RW(J)
  192 FORMAT('      FACTOR MUST BE POSITIVE.  COMPONENT ',I5,' NOW = ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20112 TO NPR007
      GO TO 30007
20112 CONTINUE
20109 GO TO 20105
20107 CONTINUE
20098 LDS=2
      GO TO 20080
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM().
10005 IF (.NOT.(JP.EQ.5)) GO TO 10006
      IF (.NOT.(IP.GT.0)) GO TO 20113
      LOPT=IOPT(LP+2)
20113 LDS=2
      GO TO 20080
C
C     THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN
C     INCREMENT TO SKIP.
10006 IF (.NOT.(JP.EQ.6)) GO TO 10007
      IF (.NOT.(IP.GT.0)) GO TO 20116
      LP=IOPT(LP+2)-1
      LDS=0
      GO TO 20117
20116 LDS=2
20117 GO TO 20080
C
C     NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION.
10007 NERR=6
      NCHAR=47
CCCCC CALL XERRWV('DBOLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED.',
CCCCC* NCHAR,NERR,LEVEL,
CCCCC* 1,JP,IDUM,0,IDUM,IDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,201)
  201 FORMAT('***** ERROR FROM DBOLS.  INVALID OPTION NUMBER.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20119 TO NPR007
      GO TO 30007
20119 CONTINUE
20083 GO TO 20080
20081 GO TO 20006
C     PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS)
30004 MROWS=IOPT(LOCACC+1)-1
      INROWS=IOPT(LOCACC+2)
      MNEW=MROWS+INROWS
      IF (.NOT.(MNEW.LT.0 .OR. MNEW.GT.MDW)) GO TO 20120
      NERR=10
      NCHAR=61
CCCCC CALL XERRWV('DBOLS(). NO. OF ROWS=(I1) MUST BE .GE. 0 .AND. .LE. M
CCCCC*DW=(I2).',NCHAR,NERR,LEVEL,
CCCCC*2,MNEW,MDW,0,RDUM,RDUM)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,211)
  211 FORMAT('***** ERROR FROM DBOLS.  INVALID NUMBER OF ROWS.')
      CALL DPWRST('XXX','BUG ')
      ASSIGN 20123 TO NPR007
      GO TO 30007
20123 CONTINUE
20120 CONTINUE
20121 J=1
      N20124=MIN0(NCOLS+1,MNEW)
      GO TO 20125
20124 J=J+1
20125 IF ((N20124-J).LT.0) GO TO 20126
      I=MNEW
      N20128=MAX0(MROWS,J)+1
      GO TO 20129
20128 I=-1+I
20129 IF (-(N20128-I).LT.0) GO TO 20130
      IBIG=ISAMAX(I-J,W(J,J),1)+J-1
C
C     PIVOT FOR INCREASED STABILITY.
C
C     NOTE 4/2006: USE DUMMY VALUES DJUNK1, DJUNK2 TO AVOID
C                  COMPILATION WARNINGS
C
      DJUNK1=0.0D0
      DJUNK2=0.0D0
      CALL DROTG(W(IBIG,J),W(I,J),DJUNK1,DJUNK2)
      CALL DROT(NCOLS+1-J,W(IBIG,J+1),MDW,W(I,J+1),MDW,DJUNK1,
     1          DJUNK2)
      SC=DJUNK1
      SS=DJUNK2
C
      W(I,J)=ZERO
      GO TO 20128
20130 GO TO 20124
20126 MROWS=MIN0(NCOLS+1,MNEW)
      IOPT(LOCACC+1)=MROWS+1
      IGO=IOPT(LOCACC)
      GO TO 20015
C     PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES)
30005 J=1
      N20132=NCOLS
      GO TO 20133
20132 J=J+1
20133 IF ((N20132-J).LT.0) GO TO 20134
      NX0140=ISCALE
      IF (NX0140.LT.1.OR.NX0140.GT.4) GO TO 20140
      GO TO (20136,20137,20138,20139), NX0140
C
C     THIS IS THE NOMINAL SCALING. EACH NONZERO
C     COL. HAS MAX. NORM EQUAL TO ONE.
20136 IBIG=ISAMAX(MROWS,W(1,J),1)
      RW(J)= DABS(W(IBIG,J))
      IF (.NOT.(RW(J).EQ.ZERO)) GO TO 20142
      RW(J)=ONE
      GO TO 20143
20142 RW(J)=ONE/RW(J)
20143 GO TO 20141
C
C     THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN
C     HAVE EUCLIDEAN LENGTH EQUAL TO ONE.
20137 RW(J)=DNRM2(MROWS,W(1,J),1)
      IF (.NOT.(RW(J).EQ.ZERO)) GO TO 20145
      RW(J)=ONE
      GO TO 20146
20145 RW(J)=ONE/RW(J)
20146 GO TO 20141
C
C     THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING
C     THE SCALING MATRIX TO THE IDENTITY MATRIX.
20138 RW(1)=ONE
      CALL DCOPY(NCOLS,RW,0,RW,1)
      GO TO 20135
20139 GO TO 20135
20140 CONTINUE
20141 GO TO 20132
20134 CONTINUE
20135 GO TO 20019
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
30007 MODE=-NERR
      IGO=0
C
C     THIS TEST IS ONLY FOR AVOIDING A COMPILE ERROR ON
C     THE A-GO-TO AFTER THE RETURN.
      IF(.TRUE.) RETURN
      GO TO NPR007, (20024,20028,20032,20036,20040,20044,20048,20052,200
     *56,20064,20075,20097,20104,20112,20119,20123)
      END
      SUBROUTINE DMOUT(M,N,LDA,A,IFMT,IDIGIT)
C***BEGIN PROLOGUE  DMOUT
C***REFER TO  DBOCLS,DFC
C***ROUTINES CALLED  I1MACH
C***DESCRIPTION
C
C     DOUBLE PRECISION MATRIX OUTPUT ROUTINE.
C
C  INPUT..
C
C  M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M,
C                 J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED
C                 FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING
C                 PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT
C                 IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP.
C                 THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A
C                 PLEASANT FORMAT.
C  IFMT(*)        A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON
C                 OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN
C                 STATEMENT
C                       WRITE(LOUT,IFMT).
C  IDIGIT         PRINT AT LEAST IABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C                 THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR
C                 28 WHICH WILL PRINT AT LEAST IABS(IDIGIT) NUMBER OF
C                 PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE
C                 UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY
C                 A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING
C                 TERMINALS).  IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE
C                 UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (SIMPLEX TABLEAU   ) OF SIZE 10 BY 20 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DOUBLE PRECISION TABLEU(20,20)
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C     M = 10
C     N = 20
C     LDTABL = 20
C     IDIGIT = -6
C     CALL DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT)
C
C
C
C     AUTHORS    JOHN A. WISNIEWSKI   SANDIA LABS ALBUQUERQUE.
C                RICHARD J. HANSON    SANDIA LABS ALBUQUERQUE.
C     DATE       JULY 30,1978.
C***END PROLOGUE  DMOUT
      DOUBLE PRECISION A(LDA,*)
      CHARACTER IFMT*(*),ICOL*3
      DATA ICOL /'COL'/
C***FIRST EXECUTABLE STATEMENT  DMOUT
      LOUT=I1MACH(2)
      WRITE(ICOUT,IFMT)
      CALL DPWRST('XXX','BUG ')
      IF(M.LE.0.OR.N.LE.0.OR.LDA.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 9
C
      DO 5 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(ICOUT,1010) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 5 I = 1, M
      WRITE(ICOUT,1009) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   5  CONTINUE
      RETURN
C
   9  CONTINUE
      IF(NDIGIT.GT.6) GO TO 20
C
      DO 10 K1=1,N,4
      K2 = MIN0(N,K1+3)
      WRITE(ICOUT,1000) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 10 I = 1, M
      WRITE(ICOUT,1004) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.14) GO TO 40
C
      DO 30 K1=1,N,2
      K2 = MIN0(N,K1+1)
      WRITE(ICOUT,1001) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 30 I = 1, M
      WRITE(ICOUT,1005) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.20) GO TO 60
C
      DO 50 K1=1,N,2
      K2=MIN0(N,K1+1)
      WRITE(ICOUT,1002) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 50 I = 1, M
      WRITE(ICOUT,1006) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N
      K2 = K1
      WRITE(ICOUT,1003) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 70 I = 1, M
      WRITE(ICOUT,1007) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 86
C
      DO 85 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(ICOUT,1000) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 85 I = 1, M
      WRITE(ICOUT,1009) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   85 CONTINUE
C
86    IF (NDIGIT.GT.6) GO TO 100
C
      DO 90 K1=1,N,8
      K2 = MIN0(N,K1+7)
      WRITE(ICOUT,1000) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 90 I = 1, M
      WRITE(ICOUT,1004) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.14) GO TO 120
C
      DO 110 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(ICOUT,1001) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 110 I = 1, M
      WRITE(ICOUT,1005) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.20) GO TO 140
C
      DO 130 K1=1,N,4
      K2 = MIN0(N,K1+3)
      WRITE(ICOUT,1002) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 130 I = 1, M
      WRITE(ICOUT,1006) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,3
      K2 = MIN0(N,K1+2)
      WRITE(ICOUT,1003) (ICOL,I,I = K1, K2)
      CALL DPWRST('XXX','BUG ')
      DO 150 I = 1, M
      WRITE(ICOUT,1007) I,(A(I,J),J = K1, K2)
      CALL DPWRST('XXX','BUG ')
  150 CONTINUE
      RETURN
 1000 FORMAT(10X,8(5X,A,I4,2X))
 1001 FORMAT(10X,5(9X,A,I4,6X))
 1002 FORMAT(10X,4(12X,A,I4,9X))
 1003 FORMAT(10X,3(16X,A,I4,13X))
 1004 FORMAT(1X,3HROW,I4,2X,1P8D14.5)
 1005 FORMAT(1X,3HROW,I4,2X,1P5D22.13)
 1006 FORMAT(1X,3HROW,I4,2X,1P4D28.19)
 1007 FORMAT(1X,3HROW,I4,2X,1P3D36.27)
 1009 FORMAT(1X,3HROW,I4,2X,1P10D12.3)
 1010 FORMAT(10X,10(4X,A,I4,1X))
      END
      SUBROUTINE IVOUT(N,IX,IFMT,IDIGIT)
C***BEGIN PROLOGUE  IVOUT
C***REFER TO  SPLP
C     REVISED FEB. 27, 1981.
C
C     INTEGER VECTOR OUTPUT ROUTINE.
C
C  INPUT..
C
C  N,IX(*) PRINT THE INTEGER ARRAY IX(I),I=1,...,N, ON OUTPUT
C          UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT
C          STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST
C          STEP. THE COMPONENTS IX(I) ARE INDEXED, ON OUTPUT,
C          IN A PLEASANT FORMAT.
C  IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT
C          UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT
C                WRITE(ICOUT,IFMT)
C  IDIGIT  PRINT UP TO IABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C          THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14
C          WHICH WILL PRINT AT LEAST IABS(IDIGIT) NUMBER OF
C          PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED
C          TO WRITE EACH LINE OF OUTPUT OF THE ARRAY IX(*). (THIS
C          CAN BE USED ON MOST TIME-SHARING TERMINALS). IF
C          IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN
C          BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DIMENSION ICOSTS(100)
C     N = 100
C     IDIGIT = -6
C     CALL IVOUT(N,ICOSTS,'(''1COSTS OF PURCHASES'')',IDIGIT)
C
C
C
C     AUTHORS    JOHN A. WISNIEWSKI   SANDIA LABS ALBUQUERQUE.
C                RICHARD J. HANSON    SANDIA LABS ALBUQUERQUE.
C     DATE       JULY 27,1978.
C***ROUTINES CALLED  I1MACH
C***END PROLOGUE  IVOUT
      DIMENSION IX(*)
      CHARACTER IFMT*(*)
C
C     GET THE UNIT NUMBER WHERE OUTPUTWILL BE WRITTEN.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT  IVOUT
      J=2
      LOUT=I1MACH(J)
      WRITE(ICOUT,IFMT)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 20
C
      DO 10 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(ICOUT,1000) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.6) GO TO 40
C
      DO 30 K1=1,N,7
      K2 = MIN0(N,K1+6)
      WRITE(ICOUT,1001) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.10) GO TO 60
C
      DO 50 K1=1,N,5
      K2=MIN0(N,K1+4)
      WRITE(ICOUT,1002) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N,3
      K2 = MIN0(N,K1+2)
      WRITE(ICOUT,1003) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 100
C
      DO 90 K1=1,N,20
      K2 = MIN0(N,K1+19)
      WRITE(ICOUT,1000) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.6) GO TO 120
C
      DO 110 K1=1,N,15
      K2 = MIN0(N,K1+14)
      WRITE(ICOUT,1001) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.10) GO TO 140
C
      DO 130 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(ICOUT,1002) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,7
      K2 = MIN0(N,K1+6)
      WRITE(ICOUT,1003) K1,K2,(IX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  150 CONTINUE
      RETURN
 1000 FORMAT(1X,I4,' - ',I4,20(1X,I5))
 1001 FORMAT(1X,I4,' - ',I4,15(1X,I7))
 1002 FORMAT(1X,I4,' - ',I4,10(1X,I11))
 1003 FORMAT(1X,I4,' - ',I4,7(1X,I15))
      END
      SUBROUTINE SVOUT(N,SX,IFMT,IDIGIT)
C***BEGIN PROLOGUE  SVOUT
C***REFER TO  SPLP
C     REVISED FEB. 27, 1981.
C
C     SINGLE PRECISION VECTOR OUTPUT ROUTINE.
C
C  INPUT..
C
C  N,SX(*) PRINT THE SINGLE PRECISION ARRAY SX(I),I=1,...,N, ON
C          OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT
C          STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST
C          STEP. THE COMPONENTS SX(I) ARE INDEXED, ON OUTPUT,
C          IN A PLEASANT FORMAT.
C  IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT
C          UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT
C                WRITE(ICOUT,IFMT)
C  IDIGIT  PRINT AT LEAST IABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C          THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14
C          WHICH WILL PRINT AT LEAST IABS(IDIGIT) NUMBER OF
C          PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE UTILIZED
C          TO WRITE EACH LINE OF OUTPUT OF THE ARRAY SX(*). (THIS
C          CAN BE USED ON MOST TIME-SHARING TERMINALS). IF
C          IDIGIT.GE.0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN
C          BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DIMENSION COSTS(100)
C     N = 100
C     IDIGIT = -6
C     CALL SVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT)
C
C
C
C     AUTHORS    JOHN A. WISNIEWSKI   SANDIA LABS ALBUQUERQUE.
C                RICHARD J. HANSON    SANDIA LABS ALBUQUERQUE.
C     DATE       JULY 27,1978.
C
C***ROUTINES CALLED  I1MACH
C***END PROLOGUE  SVOUT
      DIMENSION SX(*)
      CHARACTER IFMT*(*)
C
C     GET THE UNIT NUMBER WHERE OUTPUTWILL BE WRITTEN.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT  SVOUT
      J=2
      LOUT=I1MACH(J)
      WRITE(ICOUT,IFMT)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 20
C
      DO 10 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(ICOUT,1000) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.6) GO TO 40
C
      DO 30 K1=1,N,4
      K2 = MIN0(N,K1+3)
      WRITE(ICOUT,1001) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.10) GO TO 60
C
      DO 50 K1=1,N,3
      K2=MIN0(N,K1+2)
      WRITE(ICOUT,1002) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N,2
      K2 = MIN0(N,K1+1)
      WRITE(ICOUT,1003) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 100
C
      DO 90 K1=1,N,10
      K2 = MIN0(N,K1+9)
      WRITE(ICOUT,1000) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.6) GO TO 120
C
      DO 110 K1=1,N,8
      K2 = MIN0(N,K1+7)
      WRITE(ICOUT,1001) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.10) GO TO 140
C
      DO 130 K1=1,N,6
      K2 = MIN0(N,K1+5)
      WRITE(ICOUT,1002) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,5
      K2 = MIN0(N,K1+4)
      WRITE(ICOUT,1003) K1,K2,(SX(I),I=K1,K2)
      CALL DPWRST('XXX','BUG ')
  150 CONTINUE
      RETURN
 1000 FORMAT(1X,I4,' - ',I4,1P10E12.3)
 1001 FORMAT(1X,I4,' - ',I4,1X,1P8E14.5)
 1002 FORMAT(1X,I4,' - ',I4,1X,1P6E18.9)
 1003 FORMAT(1X,I4,' - ',I4,1X,1P5E24.13)
      END
      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
C                B L A S  Subprogram
C    Description of Parameters
C
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
C     --Output--
C    DASUM  double precision result (zero if N .LE. 0)
C
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
      DOUBLE PRECISION DX(1)
C***FIRST EXECUTABLE STATEMENT  DASUM
      DASUM = 0.D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I=1,NS,INCX
          DASUM = DASUM + DABS(DX(I))
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6.
C
   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
*DACCES
      SUBROUTINE DACCES
     +   (N,M,NP,NQ,LDWE,LD2WE,
     +   WORK,LWORK,IWORK,LIWORK,
     +   ACCESS,ISODR,
     +   JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +   NNZW,NPP,
     +   JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +   LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +   WSS,RVAR,IDF,
     +   TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +   RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)
C***BEGIN PROLOGUE  DACCES
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  ACCESS OR STORE VALUES IN THE WORK ARRAYS
C***END PROLOGUE  DACESS

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND,
     +   RNORMS,RVAR,SSTOL,TAU,TAUFAC
      INTEGER
     +   IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT,
     +   LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV,
     +   NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK6
      LOGICAL
     +   ACCESS,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   WORK(LWORK),WSS(3)
      INTEGER
     +   IWORK(LIWORK)

C...LOCAL SCALARS
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,
     +   DELTAI,DELTNI,DELTSI,DIFFI,EPSI,
     +   EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT,
     +   IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI,
     +   MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI,
     +   NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,
     +   VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DIWINF,DWINF

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACCESS:  THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 
C            ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN
C            THEM (ACCESS=FALSE).
C   ACTRS:   THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   EPSI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS.
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IDFI:    THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   INT2:    THE NUMBER OF INTERNAL DOUBLING STEPS.
C   INT2I:   THE LOCATION IN ARRAY IWORK OF VARIABLE INT2.
C   IPR1:    THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE INITIAL SUMMARY REPORT.
C   IPR2:    THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE ITERATION REPORTS.
C   IPR2F:   THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
C   IPR3:    THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FINAL SUMMARY REPORT.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE 
C            FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   JPVT:    THE PIVOT VECTOR.
C   JPVTI:   THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT.
C   LDTTI:   THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE. 
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE. 
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGB:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGD:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITER:   THE NUMBER OF ITERATIONS TAKEN.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE NITER.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.
C   OLMAVG:  THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 
C            ITERATION.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGA:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERS:   THE SAVED PREDICTED RELATIVE REDUCTION IN THE 
C            SUM-OF-SQUARES.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   QRAUX:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCOND.
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORMS:  THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS.
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVAR:    THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SCLB:    THE SCALING VALUES USED FOR BETA.
C   SCLD:    THE SCALING VALUES USED FOR DELTA.
C   SD:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-
C            CALL (SHORT=FALSE).
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   U:       THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCV:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WRK1:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSS:     THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS.
C   WSSI:    THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1).
C   WSSDEI:  THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2).
C   WSSEPI:  THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3).
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.


C***FIRST EXECUTABLE STATEMENT  DACCES


C  FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE

      CALL DIWINF(M,NP,NQ,
     +            MSGB,MSGD,JPVTI,ISTOPI,
     +            NNZWI,NPPI,IDFI,
     +            JOBI,IPRINI,LUNERI,LUNRPI,
     +            NROWI,NTOLI,NETAI,
     +            MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +            LIWKMN)

C  FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE

      CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +           DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
     +           RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +           OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +           PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +           BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +           FSI,FJACBI,WE1I,DIFFI,
     +           DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +           WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +           LWKMN)

      IF (ACCESS) THEN

C  SET STARTING LOCATIONS FOR WORK VECTORS

         JPVT   = JPVTI
         OMEGA  = OMEGAI
         QRAUX  = QRAUXI
         SD     = SDI
         VCV    = VCVI
         U      = UI
         WRK1   = WRK1I
         WRK2   = WRK2I
         WRK3   = WRK3I
         WRK4   = WRK4I
         WRK5   = WRK5I
         WRK6   = WRK6I

C  ACCESS VALUES FROM THE WORK VECTORS

         ACTRS  = WORK(ACTRSI)
         ALPHA  = WORK(ALPHAI)
         ETA    = WORK(ETAI)
         OLMAVG = WORK(OLMAVI)
         PARTOL = WORK(PARTLI)
         PNORM  = WORK(PNORMI)
         PRERS  = WORK(PRERSI)
         RCOND  = WORK(RCONDI)
         WSS(1) = WORK(WSSI)
         WSS(2) = WORK(WSSDEI)
         WSS(3) = WORK(WSSEPI)
         RVAR   = WORK(RVARI)
         RNORMS = WORK(RNORSI)
         SSTOL  = WORK(SSTOLI)
         TAU    = WORK(TAUI)
         TAUFAC = WORK(TAUFCI)
   
         NETA   = IWORK(NETAI)
         IRANK  = IWORK(IRANKI)
         JOB    = IWORK(JOBI)
         LUNRPT = IWORK(LUNRPI)
         MAXIT  = IWORK(MAXITI)
         NFEV   = IWORK(NFEVI)
         NITER  = IWORK(NITERI)
         NJEV   = IWORK(NJEVI)
         NNZW   = IWORK(NNZWI)
         NPP    = IWORK(NPPI)
         IDF    = IWORK(IDFI)
         INT2   = IWORK(INT2I)
       
C  SET UP PRINT CONTROL VARIABLES
 
         IPRINT = IWORK(IPRINI)
   
         IPR1   = MOD(IPRINT,10000)/1000
         IPR2   = MOD(IPRINT,1000)/100
         IPR2F  = MOD(IPRINT,100)/10
         IPR3   = MOD(IPRINT,10)
    
      ELSE

C  STORE VALUES INTO THE WORK VECTORS

         WORK(ACTRSI)  = ACTRS   
         WORK(ALPHAI)  = ALPHA   
         WORK(OLMAVI)  = OLMAVG  
         WORK(PARTLI)  = PARTOL  
         WORK(PNORMI)  = PNORM   
         WORK(PRERSI)  = PRERS   
         WORK(RCONDI)  = RCOND   
         WORK(WSSI)    = WSS(1)
         WORK(WSSDEI)  = WSS(2)
         WORK(WSSEPI)  = WSS(3)
         WORK(RVARI)   = RVAR
         WORK(RNORSI)  = RNORMS  
         WORK(SSTOLI)  = SSTOL   
         WORK(TAUI)    = TAU     

         IWORK(IRANKI) = IRANK   
         IWORK(ISTOPI) = ISTOP   
         IWORK(NFEVI)  = NFEV    
         IWORK(NITERI) = NITER   
         IWORK(NJEVI)  = NJEV    
         IWORK(IDFI)   = IDF    
         IWORK(INT2I)  = INT2    
      END IF

      RETURN
      END
*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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, 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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDS
C        THE LEADING DIMENSION OF ARRAY S.
      INTEGER LDSV
C        THE LEADING DIMENSION OF ARRAY SV.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(LDS,M)
C        THE SCALING ARRAY.
      DOUBLE PRECISION SV(LDSV,M)
C        THE INVERSE SCALED ARRAY.
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING SCALED.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGI
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      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
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, 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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDS
C        THE LEADING DIMENSION OF ARRAY S.
      INTEGER LDSV
C        THE LEADING DIMENSION OF ARRAY SV.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(LDS,M)
C        THE SCALING ARRAY.
      DOUBLE PRECISION SV(LDSV,M)
C        THE SCALED ARRAY.
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING SCALED.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      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
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, 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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER LDWV
C        THE LEADING DIMENSION OF ARRAY WV.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING WEIGHTED.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
      DOUBLE PRECISION WV(LDWV,M)
C        THE WEIGHTED ARRAY.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGW
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      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
C
      RETURN
      END
*DESUBI
      SUBROUTINE DESUBI
     +   (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E)
C***BEGIN PROLOGUE  DESUBI
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE E = WD + ALPHA*TT**2
C***END PROLOGUE  DESUBI

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA
      INTEGER
     +   LDTT,LDWD,LD2WD,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J,J1,J2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHA:  THE LEVENBERG-MARQUARDT PARAMETER.
C   E:      THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2
C   I:      AN INDEXING VARIABLE.
C   J:      AN INDEXING VARIABLE.
C   J1:     AN INDEXING VARIABLE.
C   J2:     AN INDEXING VARIABLE.
C   LDWD:   THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:  THE SECOND DIMENSION OF ARRAY WD.
C   M:      THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:      THE NUMBER OF OBSERVATIONS.
C   NP:     THE NUMBER OF RESPONSES PER OBSERVATION.
C   TT:     THE SCALING VALUES USED FOR DELTA.
C   WD:     THE SQUARED DELTA WEIGHTS, D**2.
C   ZERO:   THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DESUBI


C   N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE
C        OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS
C        OF THE MULTIPLY SUBSCRIPTED ARRAYS.

      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (WD(1,1,1).GE.ZERO) THEN
         IF (LDWD.GE.N) THEN
C  THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED

            IF (LD2WD.EQ.1) THEN
C  THE ARRAYS STORED IN WD ARE DIAGONAL
               CALL DZERO(M,M,E,M)
               DO 10 J=1,M
                  E(J,J) = WD(I,1,J)
   10          CONTINUE
            ELSE
C  THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES
               DO 30 J1=1,M
                  DO 20 J2=1,M
                     E(J1,J2) = WD(I,J1,J2)
   20             CONTINUE
   30          CONTINUE
            END IF

            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  DO 110 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(I,J)**2
  110             CONTINUE
               ELSE
                  DO 120 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(1,J)**2
  120             CONTINUE
               END IF
            ELSE
               DO 130 J=1,M
                  E(J,J) = E(J,J) + ALPHA*TT(1,1)**2
  130          CONTINUE
            END IF
         ELSE
C  WD IS AN M BY M MATRIX

            IF (LD2WD.EQ.1) THEN
C  THE ARRAY STORED IN WD IS DIAGONAL
               CALL DZERO(M,M,E,M)
               DO 140 J=1,M
                  E(J,J) = WD(1,1,J)
  140          CONTINUE
            ELSE
C  THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES
               DO 160 J1=1,M
                  DO 150 J2=1,M
                     E(J1,J2) = WD(1,J1,J2)
  150             CONTINUE
  160          CONTINUE
            END IF

            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  DO 210 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(I,J)**2
  210             CONTINUE
               ELSE
                  DO 220 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(1,J)**2
  220             CONTINUE
               END IF
            ELSE
               DO 230 J=1,M
                  E(J,J) = E(J,J) + ALPHA*TT(1,1)**2
  230          CONTINUE
            END IF
         END IF
      ELSE
C  WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1))
         CALL DZERO(M,M,E,M)
         IF (TT(1,1).GT.ZERO) THEN
            IF (LDTT.GE.N) THEN
               DO 310 J=1,M
                  E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2
  310          CONTINUE
            ELSE
               DO 320 J=1,M
                  E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2
  320          CONTINUE
            END IF
         ELSE
            DO 330 J=1,M
               E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2
  330       CONTINUE
         END IF
      END IF

      RETURN
      END
*DETAF
      SUBROUTINE DETAF
     +   (FCN,
     +   N,M,NP,NQ,
     +   XPLUSD,BETA,EPSMAC,NROW,
     +   PARTMP,PV0,
     +   IFIXB,IFIXX,LDIFX,
     +   ISTOP,NFEV,ETA,NETA,
     +   WRK1,WRK2,WRK6,WRK7)
C***BEGIN PROLOGUE  DETAF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS
C            (ADAPTED FROM STARPAC SUBROUTINE ETAFUN)
C***END PROLOGUE  DETAF

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSMAC,ETA
      INTEGER
     +   ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),PARTMP(NP),PV0(N,NQ),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO
      INTEGER
     +   J,K,L

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,INT,LOG10,MAX,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P1,P2,P5,ONE,TWO,HUNDRD
     +   /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:      THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       PARAMETERS OF THE LOCAL FIT.
C   B:       PARAMETERS OF THE LOCAL FIT.
C   BETA:    THE FUNCTION PARAMETERS.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE NOISE IN THE MODEL RESULTS.
C   FAC:     A FACTOR USED IN THE COMPUTATIONS.
C   HUNDRD:  THE VALUE 1.0D2.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEX VARIABLE.
C   K:       AN INDEX VARIABLE.
C   L:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   P1:      THE VALUE 0.1D0.
C   P2:      THE VALUE 0.2D0.
C   P5:      THE VALUE 0.5D0.
C   PARTMP:  THE MODEL PARAMETERS.
C   PV0:     THE ORIGINAL PREDICTED VALUES.
C   STP:     A SMALL VALUE USED TO PERTURB THE PARAMETERS.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   WRK7:    A WORK ARRAY OF (5 BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DETAF


      STP = HUNDRD*EPSMAC
      ETA = EPSMAC

      DO 40 J=-2,2
         IF (J.EQ.0) THEN
            DO 10 L=1,NQ
               WRK7(J,L) = PV0(NROW,L)
   10       CONTINUE
         ELSE
            DO 20 K=1,NP
               IF (IFIXB(1).LT.0) THEN
                  PARTMP(K) = BETA(K) + J*STP*BETA(K)
               ELSE IF (IFIXB(K).NE.0) THEN
                  PARTMP(K) = BETA(K) + J*STP*BETA(K)
               ELSE 
                  PARTMP(K) = BETA(K)
               END IF
   20       CONTINUE
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               PARTMP,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               003,WRK2,WRK6,WRK1,ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF
            DO 30 L=1,NQ
               WRK7(J,L) = WRK2(NROW,L)
   30       CONTINUE
         END IF
   40 CONTINUE

      DO 100 L=1,NQ
         A = ZERO
         B = ZERO
         DO 50 J=-2,2
            A = A + WRK7(J,L)
            B = B + J*WRK7(J,L)
   50    CONTINUE
         A = P2*A
         B = P1*B
         IF ((WRK7(0,L).NE.ZERO) .AND. 
     +       (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN
            FAC = ONE/ABS(WRK7(0,L))
         ELSE
            FAC = ONE
         END IF
         DO 60 J=-2,2
            WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC)
            ETA = MAX(WRK7(J,L),ETA)
   60    CONTINUE
  100 CONTINUE
      NETA = MAX(TWO,P5-LOG10(ETA))

      RETURN
      END
*DEVFUN
      SUBROUTINE DEVFUN
     +   (N,NP,M,BETAC,BETA,IFIXB,FUN,
     +   X,LDX,Y,DELTA,LDDELT,XPLUSD,LDXPD,
     +   W,F,NFEV,IFLAG)
C***BEGIN PROLOGUE  DEVFUN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DAXPY,DDIAGW,DUNPAC,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE THE WEIGHTED EPSILON'S FOR THE CURRENT POINT
C***END PROLOGUE  DEVFUN
C
C  EXTERNALS
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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION BETAC(NP)
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      DOUBLE PRECISION DELTA(LDDELT,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      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.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER LDDELT
C        THE LEADING DIMENSION OF ARRAY DELTA.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION NEGONE
C        THE VALUE -1.0D0.
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
C
C
      DATA NEGONE/-1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DEVFUN
C
C
C  INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA
C
      CALL DUNPAC(NP,BETAC,BETA,IFIXB)
C
C  COMPUTE XPLUSD = X + DELTA
C
      CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD)
C
C  EVALUATE THE PREDICTED VALUES OF THE FUNCTION FOR THE CURRENT POINT
C
      IFLAG = 1
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
C  INCREMENT COUNT OF NUMBER OF FUNCTION EVALUATIONS
C
      NFEV = NFEV + 1
C
C  COMPUTE WEIGHTED EPSILONS FOR CURRENT POINT AND STORE IN F
C
      CALL DAXPY(N,NEGONE,Y,1,F,1)
      CALL DDIAGW(N,1,W,F,N,F,N)
C
      RETURN
      END
*DEVJAC
      SUBROUTINE DEVJAC
     +   (FCN,
     +    ANAJAC,CDJAC, 
     +    N,M,NP,NQ,
     +    BETAC,BETA,STPB, 
     +    IFIXB,IFIXX,LDIFX,
     +    X,LDX,DELTA,XPLUSD,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,FN,
     +    STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +    NJEV,NFEV,ISTOP,INFO)
C***BEGIN PROLOGUE  DEVJAC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA
C***END PROLOGUE  DEVJAC

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE,
     +   M,N,NETA,NFEV,NJEV,NP,NQ
      LOGICAL
     +   ANAJAC,CDJAC,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),
     +   WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      INTEGER
     +   IDEVAL,J,K,K1,L
      DOUBLE PRECISION
     +   ZERO
      LOGICAL
     +   ERROR

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...DATA STATEMENTS
      DATA ZERO
     +   /0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAC:   THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   DELTA:   THE ESTIMATED VALUES OF DELTA.
C   ERROR:   THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO 
C            VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER 
C            THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION
C            BY COMPUTING FJACD IN THE OLS CASE.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT.
C   IDEVAL:  THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE
C            PERFORMED BY USER-SUPPLIED SUBROUTINE FCN.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISTOP:   THE VARIABLE DESIGNATING THAT THE USER WISHES THE 
C            COMPUTATIONS STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   K1:      AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWE:    THE LEADING DIMENSION OF ARRAYS WE AND WE1.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LD2WE:   THE SECOND DIMENSION OF ARRAYS WE AND WE1.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   SSF:     THE SCALE USED FOR THE BETA'S.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   WE1:     THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   X:       THE INDEPENDENT VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DEVJAC


C  INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA

      CALL DUNPAC(NP,BETAC,BETA,IFIXB)

C  COMPUTE XPLUSD = X + DELTA

      CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)

C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND
C          THE JACOBIAN WRT DELTA (FJACD)

      ISTOP = 0
      IF (ISODR) THEN
         IDEVAL = 110
      ELSE
         IDEVAL = 010
      END IF
      IF (ANAJAC) THEN
         CALL FCN(N,M,NP,NQ,
     +            N,M,NP,
     +            BETA,XPLUSD,
     +            IFIXB,IFIXX,LDIFX,
     +            IDEVAL,WRK2,FJACB,FJACD,
     +            ISTOP)
         IF (ISTOP.NE.0) THEN
            RETURN
         ELSE
            NJEV = NJEV+1
         END IF
C  MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO
         IF (ISODR) THEN
            DO 10 L=1,NQ
               CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N)
   10       CONTINUE
         END IF
      ELSE IF (CDJAC) THEN
         CALL DJACCD(FCN,
     +               N,M,NP,NQ,
     +               BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +               STPB,STPD,LDSTPD,
     +               SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6,
     +               FJACB,ISODR,FJACD,NFEV,ISTOP)
      ELSE 
         CALL DJACFD(FCN,
     +               N,M,NP,NQ,
     +               BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +               STPB,STPD,LDSTPD,
     +               SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6,
     +               FJACB,ISODR,FJACD,NFEV,ISTOP)
      END IF
      IF (ISTOP.LT.0) THEN
         RETURN
      ELSE IF (.NOT.ISODR) THEN
C  TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD 
C  WITHIN FCN IN THE OLS CASE
         ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO
         IF (ERROR) THEN
            INFO = 50300
            RETURN
         END IF
      END IF

C  WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS

      IF (IFIXB(1).LT.0) THEN
         DO 20 K=1,NP
            CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                 FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP)
   20    CONTINUE
      ELSE
         K1 = 0
         DO 30 K=1,NP
            IF (IFIXB(K).GE.1) THEN
               K1 = K1 + 1
               CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                   FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP)
            END IF
   30    CONTINUE
      END IF

C  WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE

      IF (ISODR) THEN
         DO 40 J=1,M
            CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                FJACD(1,J,1),N*M,FJACD(1,J,1),N*M)
   40    CONTINUE
      END IF

      RETURN
      END
*DFCTR
      SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO)
C***BEGIN PROLOGUE  DFCTR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDOT
C***DATE WRITTEN   910706   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A
C            MODIFIED CHOLESKY FACTORIZATION
C            (ADAPTED FROM LINPACK SUBROUTINE DPOFA)
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE  DFCTR

C...SCALAR ARGUMENTS
      INTEGER INFO,LDA,N
      LOGICAL OKSEMI

C...ARRAY ARGUMENTS
      DOUBLE PRECISION A(LDA,N)

C...LOCAL SCALARS
      DOUBLE PRECISION XI,S,T,TEN,ZERO
      INTEGER J,K

C...EXTERNAL FUNCTIONS
      EXTERNAL DMPREC,DDOT
      DOUBLE PRECISION DMPREC,DDOT
 
C...INTRINSIC FUNCTIONS
      INTRINSIC SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,TEN
     +   /0.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       THE ARRAY TO BE FACTORED.  UPON RETURN, A CONTAINS THE
C            UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
C            WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO
C            IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C   I:       AN INDEXING VARIABLE.
C   INFO:    AN IDICATOR VARIABLE, WHERE IF
C            INFO = 0  THEN FACTORIZATION WAS COMPLETED
C            INFO = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
C                      OF ORDER  K  IS NOT POSITIVE (SEMI)DEFINITE.
C   J:       AN INDEXING VARIABLE.
C   LDA:     THE LEADING DIMENSION OF ARRAY A.
C   N:       THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A.
C   OKSEMI:  THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE 
C            SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO
C            BE POSITIVE DEFINITE (OKSEMI=FALSE).
C   TEN:     THE VALUE 10.0D0.
C   XI:      A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DFCTR


C  SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS.
      XI = -TEN*DMPREC()

C  COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A
      DO 20 J=1,N
         INFO = J
         S = ZERO
         DO 10 K=1,J-1
            IF (A(K,K).EQ.ZERO) THEN
               T      = ZERO
            ELSE
               T      = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
               T      = T/A(K,K)
            END IF
            A(K,J) = T
            S      = S + T*T
   10    CONTINUE
         S = A(J,J) - S
C     ......EXIT
         IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN
            RETURN
         ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN
            RETURN
         ELSE IF (S.LE.ZERO) THEN
            A(J,J) = ZERO
         ELSE
            A(J,J) = SQRT(S)
         END IF
   20 CONTINUE
      INFO = 0

C  ZERO OUT LOWER PORTION OF A
      DO 40 J=2,N
         DO 30 K=1,J-1
            A(J,K) = ZERO
   30    CONTINUE
   40 CONTINUE

      RETURN
      END
*DFCTRW
      SUBROUTINE DFCTRW
     +   (N,M,NQ,NPP,
     +   ISODR,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   WRK0,WRK4,
     +   WE1,NNZW,INFO)
C***BEGIN PROLOGUE  DFCTRW
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFCTR
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING
C            NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE
C            ODRPACK REFERENCE GUIDE 
C***END PROLOGUE  DFCTRW

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDWD,LDWE,LD2WD,LD2WE,
     +   M,N,NNZW,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),
     +   WRK0(NQ,NQ),WRK4(M,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,INF,J,J1,J2,L,L1,L2
      LOGICAL
     +   NOTZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DFCTR

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   J1:      AN INDEXING VARIABLE.
C   J2:      AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   L1:      AN INDEXING VARIABLE.
C   L2:      AN INDEXING VARIABLE.
C   LAST:    THE LAST ROW OF THE ARRAY TO BE ACCESSED.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NOTZRO:  THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE 
C            WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) 
C            OR NOT (NOTZRO=TRUE).
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATIONS.
C   WE:      THE (SQUARED) EPSILON WEIGHTS.
C   WE1:     THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE.
C   WD:      THE (SQUARED) DELTA WEIGHTS.
C   WRK0:    A WORK ARRAY OF (NQ BY NQ) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DFCTRW


C  CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1

      IF (WE(1,1,1).LT.ZERO) THEN
C  WE CONTAINS A SCALAR
         WE1(1,1,1) = -SQRT(ABS(WE(1,1,1)))
         NNZW = N

      ELSE
         NNZW = 0

         IF (LDWE.EQ.1) THEN

            IF (LD2WE.EQ.1) THEN
C  WE CONTAINS A DIAGONAL MATRIX
               DO 110 L=1,NQ
                  IF (WE(1,1,L).GT.ZERO) THEN
                     NNZW = N
                     WE1(1,1,L) = SQRT(WE(1,1,L))
                  ELSE IF (WE(1,1,L).LT.ZERO) THEN
                     INFO = 30010
                     GO TO 300
                  END IF
  110          CONTINUE
            ELSE

C  WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX 
               DO 130 L1=1,NQ
                  DO 120 L2=L1,NQ
                     WRK0(L1,L2) = WE(1,L1,L2)
  120             CONTINUE
  130          CONTINUE
               CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF)
               IF (INF.NE.0) THEN
                  INFO = 30010
                  GO TO 300
               ELSE
                  DO 150 L1=1,NQ
                     DO 140 L2=1,NQ
                        WE1(1,L1,L2) = WRK0(L1,L2)
  140                CONTINUE
                     IF (WE1(1,L1,L1).NE.ZERO) THEN
                        NNZW = N
                     END IF
  150             CONTINUE
               END IF
            END IF

         ELSE

            IF (LD2WE.EQ.1) THEN
C  WE CONTAINS AN ARRAY OF  DIAGONAL MATRIX
               DO 220 I=1,N
                  NOTZRO = .FALSE.
                  DO 210 L=1,NQ
                     IF (WE(I,1,L).GT.ZERO) THEN
                        NOTZRO = .TRUE.
                        WE1(I,1,L) = SQRT(WE(I,1,L))
                     ELSE IF (WE(I,1,L).LT.ZERO) THEN
                        INFO = 30010
                        GO TO 300
                     END IF
  210             CONTINUE
                  IF (NOTZRO) THEN
                     NNZW = NNZW + 1
                  END IF
  220          CONTINUE
            ELSE

C  WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES 
               DO 270 I=1,N
                  DO 240 L1=1,NQ
                     DO 230 L2=L1,NQ
                        WRK0(L1,L2) = WE(I,L1,L2)
  230                CONTINUE
  240             CONTINUE
                  CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF)
                  IF (INF.NE.0) THEN
                     INFO = 30010
                     GO TO 300
                  ELSE
                     NOTZRO = .FALSE.
                     DO 260 L1=1,NQ
                        DO 250 L2=1,NQ
                           WE1(I,L1,L2) = WRK0(L1,L2)
  250                   CONTINUE
                        IF (WE1(I,L1,L1).NE.ZERO) THEN
                           NOTZRO = .TRUE.
                        END IF
  260                CONTINUE
                  END IF
                  IF (NOTZRO) THEN
                     NNZW = NNZW + 1
                  END IF
  270          CONTINUE
            END IF
         END IF
      END IF

C  CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS

      IF (NNZW.LT.NPP) THEN
         INFO = 30020
      END IF


C  CHECK DELTA WEIGHTS

  300 CONTINUE
      IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN
C  PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR
         RETURN

      ELSE

         IF (LDWD.EQ.1) THEN

            IF (LD2WD.EQ.1) THEN
C  WD CONTAINS A DIAGONAL MATRIX
               DO 310 J=1,M
                  IF (WD(1,1,J).LE.ZERO) THEN
                     INFO = MAX(30001,INFO+1)
                     RETURN
                  END IF
  310          CONTINUE
            ELSE

C  WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX 
               DO 330 J1=1,M
                  DO 320 J2=J1,M
                     WRK4(J1,J2) = WD(1,J1,J2)
  320             CONTINUE
  330          CONTINUE
               CALL DFCTR(.FALSE.,WRK4,M,M,INF)
               IF (INF.NE.0) THEN
                  INFO = MAX(30001,INFO+1)
                  RETURN
               END IF
            END IF

         ELSE

            IF (LD2WD.EQ.1) THEN
C  WD CONTAINS AN ARRAY OF DIAGONAL MATRICES
               DO 420 I=1,N
                  DO 410 J=1,M
                     IF (WD(I,1,J).LE.ZERO) THEN
                        INFO = MAX(30001,INFO+1)
                        RETURN
                     END IF
  410             CONTINUE
  420          CONTINUE
            ELSE

C  WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES 
               DO 470 I=1,N
                  DO 440 J1=1,M
                     DO 430 J2=J1,M
                        WRK4(J1,J2) = WD(I,J1,J2)
  430                CONTINUE
  440             CONTINUE
                  CALL DFCTR(.FALSE.,WRK4,M,M,INF)
                  IF (INF.NE.0) THEN
                     INFO = MAX(30001,INFO+1)
                     RETURN
                  END IF
  470          CONTINUE
            END IF
         END IF
      END IF

      RETURN
      END
*DFLAGS
      SUBROUTINE DFLAGS
     +   (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
C***BEGIN PROLOGUE  DFLAGS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB
C***END PROLOGUE  DFLAGS

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...LOCAL SCALARS
      INTEGER
     +   J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MOD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 
C            (CHKJAC=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF 
C            ARRAY WORK (INITD=FALSE).
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       THE VALUE OF A SPECIFIC DIGIT OF JOB.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).


C***FIRST EXECUTABLE STATEMENT  DFLAGS


      IF (JOB.GE.0) THEN

         RESTRT= JOB.GE.10000

         INITD = MOD(JOB,10000)/1000.EQ.0

         J = MOD(JOB,1000)/100
         IF (J.EQ.0) THEN
            DOVCV = .TRUE.
            REDOJ = .TRUE.
         ELSE IF (J.EQ.1) THEN
            DOVCV = .TRUE.
            REDOJ = .FALSE.
         ELSE
            DOVCV = .FALSE.
            REDOJ = .FALSE.
         END IF

         J = MOD(JOB,100)/10
         IF (J.EQ.0) THEN
            ANAJAC = .FALSE.
            CDJAC  = .FALSE.
            CHKJAC = .FALSE.
         ELSE IF (J.EQ.1) THEN
            ANAJAC = .FALSE.
            CDJAC  = .TRUE.
            CHKJAC = .FALSE.
         ELSE IF (J.EQ.2) THEN
            ANAJAC = .TRUE.
            CDJAC  = .FALSE.
            CHKJAC = .TRUE.
         ELSE
            ANAJAC = .TRUE.
            CDJAC  = .FALSE.
            CHKJAC = .FALSE.
         END IF

         J = MOD(JOB,10)
         IF (J.EQ.0) THEN
            ISODR  = .TRUE.
            IMPLCT = .FALSE.
         ELSE IF (J.EQ.1) THEN
            ISODR  = .TRUE.
            IMPLCT = .TRUE.
         ELSE 
            ISODR  = .FALSE.
            IMPLCT = .FALSE.
         END IF

      ELSE

         RESTRT  = .FALSE.
         INITD   = .TRUE.
         DOVCV   = .TRUE.
         REDOJ   = .TRUE.
         ANAJAC  = .FALSE.
         CDJAC   = .FALSE.
         CHKJAC  = .FALSE.
         ISODR   = .TRUE.
         IMPLCT  = .FALSE.

      END IF

      RETURN
      END
*DHSTEP
      DOUBLE PRECISION FUNCTION DHSTEP
     +   (ITYPE,NETA,I,J,STP,LDSTP)
C***BEGIN PROLOGUE  DHSTEP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES
C***END PROLOGUE  DHSTEP

C...SCALAR ARGUMENTS
      INTEGER
     +   I,ITYPE,J,LDSTP,NETA

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   STP(LDSTP,J)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEN,THREE,TWO,ZERO
 
C...DATA STATEMENTS
      DATA
     +   ZERO,TWO,THREE,TEN
     +   /0.0D0,2.0D0,3.0D0,10.0D0/
 
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES.
C   ITYPE:   THE FINITE DIFFERENCE METHOD BEING USED, WHERE
C            ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND
C            ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES.
C   J:       AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES.
C   LDSTP:   THE LEADING DIMENSION OF ARRAY STP.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TEN:     THE VALUE 10.0D0.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   ZERO:    THE VALUE 0.0D0.



C***FIRST EXECUTABLE STATEMENT  DHSTEP


C  SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE

      IF (STP(1,1).LE.ZERO) THEN

         IF (ITYPE.EQ.0) THEN
C  USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE
            DHSTEP = TEN**(-ABS(NETA)/TWO - TWO)

         ELSE
C  USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE
            DHSTEP = TEN**(-ABS(NETA)/THREE)
         END IF

      ELSE IF (LDSTP.EQ.1) THEN
         DHSTEP = STP(1,J)

      ELSE
         DHSTEP = STP(I,J)
      END IF

      RETURN
      END
*DIDTS
      SUBROUTINE DIDTS
     +   (N,M,W,RHO,LDRHO,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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, 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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
C  N.B.  THE LOCATIONS OF W, RHO 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.
      DOUBLE PRECISION DT
C        THE VALUE OF THE FACTOR DT = INV((W*D)**2+ALPHA*TT**2)
      DOUBLE PRECISION DTT(LDDTT,M)
C        THE ARRAY DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDDTT
C        THE LEADING DIMENSION OF ARRAY DTT.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDT
C        THE LEADING DIMENSION OF ARRAY T.
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION T(LDT,M)
C        THE STEP FOR THE ESTIMATED DELTA'S.
      DOUBLE PRECISION TERM1
C        THE VALUE OF THE TERM (W(I)*RHO(I,J))**2
      DOUBLE PRECISION TERM2
C        THE VALUE OF THE TERM ALPHA*TT(I,J)**2
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DIDTS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (W(1).GE.ZERO) THEN
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.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)*RHO(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)*RHO(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)*RHO(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)*RHO(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)*RHO(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)*RHO(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)*RHO(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)*RHO(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)*RHO(1,1))**2+TERM2)
                     ELSE
                        DTT(I,J) = ZERO
                     END IF
 1350             CONTINUE
 1360          CONTINUE
            END IF
         END IF
      ELSE
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.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)/
     +                                (RHO(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)/(RHO(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)/(RHO(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 = RHO(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/(RHO(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 = RHO(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 = RHO(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 = RHO(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/(RHO(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
C
      RETURN
      END
*DIFIX
      SUBROUTINE DIFIX
     +   (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX)
C***BEGIN PROLOGUE  DIFIX
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   910612   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX
C***END PROLOGUE  DIFIX

C...SCALAR ARGUMENTS
      INTEGER
     +   LDIFIX,LDT,LDTFIX,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),TFIX(LDTFIX,M)
      INTEGER
     +   IFIX(LDIFIX,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE
C            SET TO ZERO.
C   J:       AN INDEXING VARIABLE.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   LDIFIX:  THE LEADING DIMENSION OF ARRAY IFIX.
C   LDTFIX:  THE LEADING DIMENSION OF ARRAY TFIX.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE ARRAY.
C   N:       THE NUMBER OF ROWS OF DATA IN THE ARRAY.
C   T:       THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS 
C            OF IFIX.
C   TFIX:    THE RESULTING ARRAY.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DIFIX


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (IFIX(1,1).GE.ZERO) THEN
         IF (LDIFIX.GE.N) THEN
            DO 20 J=1,M
               DO 10 I=1,N
                  IF (IFIX(I,J).EQ.0) THEN
                     TFIX(I,J) = ZERO
                  ELSE
                     TFIX(I,J) = T(I,J)
                  END IF
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 100 J=1,M
               IF (IFIX(1,J).EQ.0) THEN
                  DO 30 I=1,N
                     TFIX(I,J) = ZERO
   30             CONTINUE
               ELSE
                  DO 90 I=1,N
                     TFIX(I,J) = T(I,J)
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
      END IF

      RETURN
      END
*DINIWK
      SUBROUTINE DINIWK
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +   BETA,SCLB,
     +   SSTOL,PARTOL,MAXIT,TAUFAC,
     +   JOB,IPRINT,LUNERR,LUNRPT,
     +   EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI,
     +   JOBI,IPRINI,LUNERI,LUNRPI,
     +   SSFI,TTI,LDTTI,DELTAI)
C***BEGIN PROLOGUE  DINIWK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DMPREC,DSCLB,DSCLD,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  INITIALIZE WORK VECTORS AS NECESSARY
C***END PROLOGUE  DINIWK

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX,
     +   LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M,
     +   MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M)
      INTEGER
     +   IFIXX(LDIFX,M),IWORK(LIWORK)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,THREE,TWO,ZERO
      INTEGER
     +   I,J 
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION 
     +   DMPREC
      EXTERNAL
     +   DMPREC

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY,DFLAGS,DSCLB,DSCLD,DZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TWO,THREE
     +   /0.0D0,1.0D0,2.0D0,3.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   I:       AN INDEXING VARIABLE.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 
C            AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   IWORK:   THE INTEGER WORK SPACE.
C   J:       AN INDEXING VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDTTI:   THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   THREE:   THE VALUE 3.0D0.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT.
C   TWO:     THE VALUE 2.0D0.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE INDEPENDENT VARIABLE.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DINIWK


      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)

C  STORE VALUE OF MACHINE PRECISION IN WORK VECTOR

      WORK(EPSMAI) = DMPREC()

C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  PARAMETERS  (SEE ALSO SUBPROGRAM DODCNT)

      IF (PARTOL.LT.ZERO) THEN
         WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE)
      ELSE
         WORK(PARTLI) = MIN(PARTOL, ONE)
      END IF

C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS

      IF (SSTOL.LT.ZERO) THEN
         WORK(SSTOLI) = SQRT(WORK(EPSMAI))
      ELSE
         WORK(SSTOLI) = MIN(SSTOL, ONE)
      END IF

C  SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION

      IF (TAUFAC.LE.ZERO) THEN
         WORK(TAUFCI) = ONE
      ELSE
         WORK(TAUFCI) = MIN(TAUFAC, ONE)
      END IF

C  SET MAXIMUM NUMBER OF ITERATIONS

      IF (MAXIT.LT.0) THEN
         IWORK(MAXITI) = 50
      ELSE
         IWORK(MAXITI) = MAXIT
      END IF

C  STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL
C  VARIABLE

      IF (JOB.LE.0) THEN
         IWORK(JOBI) = 0
      ELSE
         IWORK(JOBI) = JOB
      END IF

C  SET PRINT CONTROL

      IF (IPRINT.LT.0) THEN
         IWORK(IPRINI) = 2001
      ELSE
         IWORK(IPRINI) = IPRINT
      END IF

C  SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES

      IF (LUNERR.LT.0) THEN
         IWORK(LUNERI) = 6
      ELSE
         IWORK(LUNERI) = LUNERR
      END IF

C  SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS

      IF (LUNRPT.LT.0) THEN
         IWORK(LUNRPI) = 6
      ELSE
         IWORK(LUNRPI) = LUNRPT
      END IF

C  COMPUTE SCALING FOR BETA'S AND DELTA'S

      IF (SCLB(1).LE.ZERO) THEN
         CALL DSCLB(NP,BETA,WORK(SSFI))
      ELSE
         CALL DCOPY(NP,SCLB,1,WORK(SSFI),1)
      END IF
      IF (ISODR) THEN
         IF (SCLD(1,1).LE.ZERO) THEN
            IWORK(LDTTI) = N
            CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI))
         ELSE
            IF (LDSCLD.EQ.1) THEN
               IWORK(LDTTI) = 1
               CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1)
            ELSE
               IWORK(LDTTI) = N
               DO 10 J=1,M
                  CALL DCOPY(N,SCLD(1,J),1,
     +                        WORK(TTI+(J-1)*IWORK(LDTTI)),1)
   10          CONTINUE
            END IF
         END IF
      END IF

C  INITIALIZE DELTA'S AS NECESSARY

      IF (ISODR) THEN
         IF (INITD) THEN
            CALL DZERO(N,M,WORK(DELTAI),N)
         ELSE
            IF (IFIXX(1,1).GE.0) THEN
               IF (LDIFX.EQ.1) THEN
                  DO 20 J=1,M
                     IF (IFIXX(1,J).EQ.0) THEN
                        CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N)
                     END IF
   20             CONTINUE
               ELSE
                  DO 40 J=1,M
                     DO 30 I=1,N
                        IF (IFIXX(I,J).EQ.0) THEN
                           WORK(DELTAI-1+I+(J-1)*N) = ZERO
                        END IF
   30                CONTINUE
   40             CONTINUE
               END IF
            END IF
         END IF
      ELSE
         CALL DZERO(N,M,WORK(DELTAI),N)
      END IF

      RETURN
      END
*DIWINF
      SUBROUTINE DIWINF
     +   (M,NP,NQ,
     +   MSGBI,MSGDI,IFIX2I,ISTOPI,
     +   NNZWI,NPPI,IDFI,
     +   JOBI,IPRINI,LUNERI,LUNRPI,
     +   NROWI,NTOLI,NETAI,
     +   MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +   LIWKMN)
C***BEGIN PROLOGUE  DIWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE
C***END PROLOGUE  DIWINF

C...SCALAR ARGUMENTS
      INTEGER
     +   IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN,
     +   LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI,
     +   NNZWI,NP,NPPI,NQ,NROWI,NTOLI

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   IDFI:    THE LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   IFIX2I:  THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2.
C   INT2I:   THE LOCATION IN ARRAY IWORK OF VARIABLE INT2.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   LDTTI:   THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGBI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGDI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABEL NITER.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.


C***FIRST EXECUTABLE STATEMENT  DIWINF


      IF (NP.GE.1 .AND. M.GE.1) THEN
         MSGBI  = 1
         MSGDI  = MSGBI  + NQ*NP+1
         IFIX2I = MSGDI  + NQ*M+1
         ISTOPI = IFIX2I + NP
         NNZWI  = ISTOPI + 1
         NPPI   = NNZWI  + 1
         IDFI   = NPPI   + 1
         JOBI   = IDFI   + 1
         IPRINI = JOBI   + 1
         LUNERI = IPRINI + 1
         LUNRPI = LUNERI + 1
         NROWI  = LUNRPI + 1
         NTOLI  = NROWI  + 1
         NETAI  = NTOLI  + 1
         MAXITI = NETAI  + 1
         NITERI = MAXITI + 1
         NFEVI  = NITERI + 1
         NJEVI  = NFEVI  + 1
         INT2I  = NJEVI  + 1
         IRANKI = INT2I  + 1
         LDTTI  = IRANKI + 1
         LIWKMN = LDTTI
      ELSE
         MSGBI  = 1
         MSGDI  = 1
         IFIX2I = 1
         ISTOPI = 1
         NNZWI  = 1
         NPPI   = 1
         IDFI   = 1
         JOBI   = 1
         IPRINI = 1
         LUNERI = 1
         LUNRPI = 1
         NROWI  = 1
         NTOLI  = 1
         NETAI  = 1
         MAXITI = 1
         NITERI = 1
         NFEVI  = 1
         NJEVI  = 1
         INT2I  = 1
         IRANKI = 1
         LDTTI  = 1
         LIWKMN = 1
      END IF

      RETURN
      END
*DJACCD
      SUBROUTINE DJACCD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,NFEV,ISTOP)
C***BEGIN PROLOGUE  DJACCD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE
C            JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS
C***END PROLOGUE  DJACCD

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ),
     +   X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAK,ONE,TYPJ,ZERO
      INTEGER
     +   I,J,K,L
      LOGICAL
     +   DOIT,SETZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAK:   THE K-TH FUNCTION PARAMETER.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOIT:    THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN
C            BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT 
C            (DOIT=FALSE).
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 
C            AT THEIR INPUT VALUES OR NOT.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SETZRO:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 
C            DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT
C            (SETZRO=FALSE).
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJACCD


C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS

      DO 60 K=1,NP
         IF (IFIXB(1).GE.0) THEN
            IF (IFIXB(K).EQ.0) THEN
               DOIT = .FALSE.
            ELSE
               DOIT = .TRUE.
            END IF
         ELSE
            DOIT = .TRUE.
         END IF
         IF (.NOT.DOIT) THEN
            DO 10 L=1,NQ
               CALL DZERO(N,1,FJACB(1,K,L),N)
   10       CONTINUE
         ELSE
            BETAK = BETA(K)
            IF (BETAK.EQ.ZERO) THEN
               IF (SSF(1).LT.ZERO) THEN
                  TYPJ = ONE/ABS(SSF(1))
               ELSE
                  TYPJ = ONE/SSF(K)
               END IF
            ELSE
               TYPJ = ABS(BETAK)
            END IF
            WRK3(K) = BETAK 
     +                + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1)
            WRK3(K) = WRK3(K) - BETAK

            BETA(K) = BETAK + WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
               DO 30 L=1,NQ
                  DO 20 I=1,N
                     FJACB(I,K,L) = WRK2(I,L)
   20             CONTINUE
   30          CONTINUE
            END IF

            BETA(K) = BETAK - WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF

            DO 50 L=1,NQ
               DO 40 I=1,N
                  FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K))
   40          CONTINUE
   50       CONTINUE
            BETA(K) = BETAK
         END IF
   60 CONTINUE

C  COMPUTE THE JACOBIAN WRT THE X'S

      IF (ISODR) THEN
         DO 220 J=1,M
            IF (IFIXX(1,1).LT.0) THEN
               DOIT = .TRUE.
               SETZRO = .FALSE.
            ELSE IF (LDIFX.EQ.1) THEN
               IF (IFIXX(1,J).EQ.0) THEN
                  DOIT = .FALSE.
               ELSE
                  DOIT = .TRUE.
               END IF
               SETZRO = .FALSE.
            ELSE
               DOIT = .FALSE.
               SETZRO = .FALSE.
               DO 100 I=1,N
                  IF (IFIXX(I,J).NE.0) THEN
                     DOIT = .TRUE.
                  ELSE
                     SETZRO = .TRUE.
                  END IF
  100          CONTINUE
            END IF
            IF (.NOT.DOIT) THEN
               DO 110 L=1,NQ
                  CALL DZERO(N,1,FJACD(1,J,L),N)
  110          CONTINUE
            ELSE
               DO 120 I=1,N
                  IF (XPLUSD(I,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(I,J)
                     END IF
                  ELSE
                     TYPJ = ABS(XPLUSD(I,J))
                  END IF
                  STP(I) = XPLUSD(I,J)
     +                     + SIGN(ONE,XPLUSD(I,J))
     +                       *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD)
                  STP(I) = STP(I) - XPLUSD(I,J)
                  XPLUSD(I,J) = XPLUSD(I,J) + STP(I)
  120          CONTINUE
               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
                  DO 140 L=1,NQ
                     DO 130 I=1,N
                        FJACD(I,J,L) = WRK2(I,L)
  130                CONTINUE
  140             CONTINUE
               END IF

               DO 150 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I)
  150          CONTINUE
               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
               END IF

               IF (SETZRO) THEN
                  DO 180 I=1,N
                     IF (IFIXX(I,J).EQ.0) THEN
                        DO 160 L=1,NQ
                           FJACD(I,J,L) = ZERO
  160                   CONTINUE
                     ELSE
                        DO 170 L=1,NQ
                           FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/
     +                                    (2*STP(I))
  170                   CONTINUE
                     END IF
  180             CONTINUE
               ELSE
                  DO 200 L=1,NQ
                     DO 190 I=1,N
                        FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/
     +                                 (2*STP(I))
  190                CONTINUE
  200             CONTINUE
               END IF
               DO 210 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J)
  210          CONTINUE
            END IF
  220    CONTINUE
      END IF

      RETURN
      END
*DJACFD
      SUBROUTINE DJACFD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,NFEV,ISTOP)
C***BEGIN PROLOGUE  DJACFD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE
C            JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS
C***END PROLOGUE  DJACFD

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),
     +   SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ),
     +   X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAK,ONE,TYPJ,ZERO
      INTEGER
     +   I,J,K,L
      LOGICAL
     +   DOIT,SETZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAK:   THE K-TH FUNCTION PARAMETER.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOIT:    THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A 
C            GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE)
C            OR NOT (DOIT=FALSE).
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE NEW PREDICTED VALUES FROM THE FUNCTION.
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SETZRO:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 
C            DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT
C            (SETZRO=FALSE).
C   SSF:     THE SCALE USED FOR THE BETA'S.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJACFD


C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS

      DO 40 K=1,NP
         IF (IFIXB(1).GE.0) THEN
            IF (IFIXB(K).EQ.0) THEN
               DOIT = .FALSE.
            ELSE
               DOIT = .TRUE.
            END IF
         ELSE
            DOIT = .TRUE.
         END IF
         IF (.NOT.DOIT) THEN
            DO 10 L=1,NQ
               CALL DZERO(N,1,FJACB(1,K,L),N)
   10       CONTINUE
         ELSE
            BETAK = BETA(K)
            IF (BETAK.EQ.ZERO) THEN
               IF (SSF(1).LT.ZERO) THEN
                  TYPJ = ONE/ABS(SSF(1))
               ELSE   
                  TYPJ = ONE/SSF(K)
               END IF 
            ELSE
               TYPJ = ABS(BETAK)
            END IF
            WRK3(K) = BETAK 
     +                + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1)
            WRK3(K) = WRK3(K) - BETAK
            BETA(K) = BETAK + WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF
            DO 30 L=1,NQ
               DO 20 I=1,N
                  FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K)
   20          CONTINUE
   30       CONTINUE
            BETA(K) = BETAK
         END IF
   40 CONTINUE

C  COMPUTE THE JACOBIAN WRT THE X'S

      IF (ISODR) THEN
         DO 220 J=1,M
            IF (IFIXX(1,1).LT.0) THEN
               DOIT = .TRUE.
               SETZRO = .FALSE.
            ELSE IF (LDIFX.EQ.1) THEN
               IF (IFIXX(1,J).EQ.0) THEN
                  DOIT = .FALSE.
               ELSE
                  DOIT = .TRUE.
               END IF
               SETZRO = .FALSE.
            ELSE
               DOIT = .FALSE.
               SETZRO = .FALSE.
               DO 100 I=1,N
                  IF (IFIXX(I,J).NE.0) THEN
                     DOIT = .TRUE.
                  ELSE
                     SETZRO = .TRUE.
                  END IF
  100          CONTINUE
            END IF
            IF (.NOT.DOIT) THEN
               DO 110 L=1,NQ
                  CALL DZERO(N,1,FJACD(1,J,L),N)
  110          CONTINUE
            ELSE
               DO 120 I=1,N
                  IF (XPLUSD(I,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(I,J)
                     END IF
                  ELSE
                     TYPJ = ABS(XPLUSD(I,J))
                  END IF

                  STP(I) = XPLUSD(I,J)
     +                     + SIGN(ONE,XPLUSD(I,J))
     +                       *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD)
                  STP(I) = STP(I) - XPLUSD(I,J)
                  XPLUSD(I,J) = XPLUSD(I,J) + STP(I)
  120          CONTINUE

               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
                  DO 140 L=1,NQ
                     DO 130 I=1,N
                        FJACD(I,J,L) = WRK2(I,L)
  130                CONTINUE
  140             CONTINUE

               END IF

               IF (SETZRO) THEN
                  DO 180 I=1,N
                     IF (IFIXX(I,J).EQ.0) THEN
                        DO 160 L=1,NQ
                           FJACD(I,J,L) = ZERO
  160                   CONTINUE
                     ELSE
                        DO 170 L=1,NQ
                           FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I)
  170                   CONTINUE
                     END IF
  180             CONTINUE
               ELSE
                  DO 200 L=1,NQ
                     DO 190 I=1,N
                        FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I)
  190                CONTINUE
  200             CONTINUE
               END IF
               DO 210 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J)
  210          CONTINUE
            END IF
  220    CONTINUE
      END IF

      RETURN
      END
*DJCK
      SUBROUTINE DJCK
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,
     +    IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,
     +    ETA,NETA,NTOL,NROW,ISODR,EPSMAC,
     +    PV0,FJACB,FJACD,
     +    MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DJCKM
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS
C            (ADAPTED FROM STARPAC SUBROUTINE DCKCNT)
C***END PROLOGUE  DJCK

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSMAC,ETA
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,
     +   M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO
      INTEGER
     +   IDEVAL,J,LQ,MSGB1,MSGD1
      LOGICAL
     +   ISFIXD,ISWRTB

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKM

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,INT,LOG10

C...DATA STATEMENTS
      DATA
     +   ZERO,P5,ONE
     +   /0.0D0,0.5D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   H0:      THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   HC0:     THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   IDEVAL:  THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE 
C            PERFORMED BY USER SUPPLIED SUBROUTINE FCN.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISFIXD:  THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED
C            (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER
C            SET BY THE USER OR COMPUTED BY DETAF.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
C   ONE:     THE VALUE 1.0D0.
C   P5:      THE VALUE 0.5D0.
C   PV:      THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C            ROW   NROW   IS STORED.
C   PV0:     THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   STPB:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA.
C   STPD:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCK


C  SET TOLERANCE FOR CHECKING DERIVATIVES

      TOL  = ETA**(0.25D0)
      NTOL = MAX(ONE,P5-LOG10(TOL))


C  COMPUTE USER SUPPLIED DERIVATIVE VALUES

      ISTOP = 0
      IF (ISODR) THEN
         IDEVAL = 110
      ELSE
         IDEVAL = 010
      END IF
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         IDEVAL,WRK2,FJACB,FJACD,
     +         ISTOP)
      IF (ISTOP.NE.0) THEN
         RETURN
      ELSE
         NJEV = NJEV + 1
      END IF

C  CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW

      MSGB1 = 0
      MSGD1 = 0

      DO 30 LQ=1,NQ

C  SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES
         PV = PV0(NROW,LQ)

         ISWRTB = .TRUE.
         DO 10 J=1,NP

            IF (IFIXB(1).LT.0) THEN
               ISFIXD = .FALSE.
            ELSE IF (IFIXB(J).EQ.0) THEN
               ISFIXD = .TRUE.
            ELSE
               ISFIXD = .FALSE.
            END IF

            IF (ISFIXD) THEN
               MSGB(1+LQ+(J-1)*NQ) = -1
            ELSE
               IF (BETA(J).EQ.ZERO) THEN
                  IF (SSF(1).LT.ZERO) THEN
                     TYPJ = ONE/ABS(SSF(1))
                  ELSE
                     TYPJ = ONE/SSF(J)
                  END IF
               ELSE
                  TYPJ = ABS(BETA(J))
               END IF
   
               H0  = DHSTEP(0,NETA,1,J,STPB,1)
               HC0 = H0

C  CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW

               CALL DJCKM(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,
     +                    IFIXB,IFIXX,LDIFX,
     +                    ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +                    ISWRTB,PV,FJACB(NROW,J,LQ),
     +                    DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
               IF (ISTOP.NE.0) THEN
                  MSGB(1) = -1
                  RETURN
               ELSE
                  DIFF(LQ,J) = DIFFJ
               END IF
            END IF

   10    CONTINUE

C  CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW

         IF (ISODR) THEN
            ISWRTB = .FALSE.
            DO 20 J=1,M

               IF (IFIXX(1,1).LT.0) THEN
                  ISFIXD = .FALSE.
               ELSE IF (LDIFX.EQ.1) THEN
                  IF (IFIXX(1,J).EQ.0) THEN
                     ISFIXD = .TRUE.
                  ELSE
                     ISFIXD = .FALSE.
                  END IF
               ELSE
                  ISFIXD = .FALSE.
               END IF

               IF (ISFIXD) THEN
                  MSGD(1+LQ+(J-1)*NQ) = -1
               ELSE

                  IF (XPLUSD(NROW,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(NROW,J)
                     END IF
                  ELSE  
                     TYPJ = ABS(XPLUSD(NROW,J))
                  END IF
 
                  H0  = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD)
                  HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD)

C  CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW

                  CALL DJCKM(FCN,
     +                       N,M,NP,NQ,
     +                       BETA,XPLUSD,
     +                       IFIXB,IFIXX,LDIFX,
     +                       ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +                       ISWRTB,PV,FJACD(NROW,J,LQ),
     +                       DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV,
     +                       WRK1,WRK2,WRK6)
                  IF (ISTOP.NE.0) THEN
                     MSGD(1) = -1
                     RETURN
               ELSE
                  DIFF(LQ,NP+J) = DIFFJ
                  END IF
               END IF

   20       CONTINUE
         END IF
   30 CONTINUE
      MSGB(1) = MSGB1
      MSGD(1) = MSGD1

      RETURN
      END
*DJCKC
      SUBROUTINE DJCKC
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB,
     +    FD,TYPJ,PVPSTP,STP0,
     +    PV,D,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKF,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE
C            DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKCRV)
C***END PROLOGUE  DJCKC

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKF,DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SIGN

C...DATA STATEMENTS
      DATA
     +   P01,ONE,TWO,TEN
     +   /0.01D0,1.0D0,2.0D0,10.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CURVE:   A MEASURE OF THE CURVATURE IN THE MODEL.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE MODEL
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   HC:      THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE OF THE MODEL FOR ROW   NROW   .
C   PVMCRV:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV.
C   PVPCRV:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV.
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P01:     THE VALUE 0.01D0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   STP:     A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   STPCRV:  THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL.
C   TEN:     THE VALUE 10.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TWO:     THE VALUE 2.0D0.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DJCKC


      IF (ISWRTB) THEN

C  PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA

         STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STPCRV,
     +             ISTOP,NFEV,PVPCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STPCRV,
     +             ISTOP,NFEV,PVMCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      ELSE

C  PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA

         STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - 
     +            XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STPCRV,
     +             ISTOP,NFEV,PVPCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STPCRV,
     +             ISTOP,NFEV,PVMCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      END IF

C  ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL

      CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV)
      CURVE = CURVE + 
     +        ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2)


C  CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT.
      CALL DJCKF(FCN,
     +           N,M,NP,NQ,
     +           BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +           ETA,TOL,NROW,J,LQ,ISWRTB,
     +           FD,TYPJ,PVPSTP,STP0,CURVE,PV,D,
     +           DIFFJ,MSG,ISTOP,NFEV,
     +           WRK1,WRK2,WRK6)
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF
      IF (MSG(LQ,J).EQ.0) THEN
         RETURN
      END IF

C  CHECK IF HIGH CURVATURE COULD BE THE PROBLEM.

      STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC)
      IF (STP.LT.ABS(TEN*STP0)) THEN
         STP = MIN(STP,P01*ABS(STP0))
      END IF


      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
         STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
         STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - 
     +         XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      END IF

C  COMPUTE THE NEW NUMERICAL DERIVATIVE

      FD = (PVPSTP-PV)/STP
      DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D))

C  CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK
      IF (ABS(FD-D).LE.TOL*ABS(D)) THEN
         MSG(LQ,J) = 0

C  CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2)
      ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP))
     +                                + CURVE*(EPSMAC*TYPJ)**2) THEN
         MSG(LQ,J) = 5
      END IF

      RETURN
      END
*DJCKF
      SUBROUTINE DJCKF
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,J,LQ,ISWRTB,
     +    FD,TYPJ,PVPSTP,STP0,CURVE,PV,D,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE
C            CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKFPA)
C***END PROLOGUE  DJCKF

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   HUNDRD,ONE,P1,STP,TWO
      LOGICAL
     +   LARGE

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SIGN

C...DATA STATEMENTS
      DATA
     +   P1,ONE,TWO,HUNDRD
     +   /0.1D0,1.0D0,2.0D0,100.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CURVE:   A MEASURE OF THE CURVATURE IN THE MODEL.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   ETA:     THE RELATIVE NOISE IN THE MODEL
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   HUNDRD:  THE VALUE 100.0D0.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LARGE:   THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN 
C            THE STEP SIZE WOULD BE GREATER THAN TYPJ.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FOR ROW   NROW   .
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P1:      THE VALUE 0.1D0.
C   STP0:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TWO:     THE VALUE 2.0D0.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DJCKF


C  FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM.
C  TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR

      STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D))
      IF (STP.GT.ABS(P1*STP0)) THEN
         STP = MAX(STP,HUNDRD*ABS(STP0))
      END IF
      IF (STP.GT.TYPJ) THEN
         STP = TYPJ
         LARGE = .TRUE.
      ELSE
         LARGE = .FALSE.
      END IF
 
      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
         STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
         STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) -
     +         XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
      END IF
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF

      FD = (PVPSTP-PV)/STP
      DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D))

C  CHECK FOR AGREEMENT

      IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN
C  FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE.
         MSG(LQ,J) = 0

      ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN
C  CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2)
         IF (LARGE) THEN
            MSG(LQ,J) = 4
         ELSE
            MSG(LQ,J) = 5
         END IF
      END IF

      RETURN
      END
*DJCKM
      SUBROUTINE DJCKM
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +    ISWRTB,PV,D,
     +    DIFFJ,MSG1,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKC,DJCKZ,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL
C            DERIVATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKMN)
C***END PROLOGUE  DJCKM

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0,
     +   TEN,THREE,TOL2,TWO,ZERO
      INTEGER
     +   I

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKC,DJCKZ,DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD
     +   /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/
      DATA
     +   BIG,TOL2
     +   /1.0D19,5.0D-2/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BIG:     A BIG VALUE, USED TO INITIALIZE DIFFJ.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   H:       THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   H0:      THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   H1:      THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   HC:      THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HC0:     THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HC1:     THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HUNDRD:  THE VALUE 100.0D0.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   MSG1:    THE ERROR CHECKING RESULTS SUMMARY.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FROM THE MODEL FOR ROW   NROW   .
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH 
C            PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P01:     THE VALUE 0.01D0.
C   P1:      THE VALUE 0.1D0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TEN:     THE VALUE 10.0D0.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TOL2:    A MINIMUM AGREEMENT TOLERANCE.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCKM


C  CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE
C  QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES

      H1  = SQRT(ETA)
      HC1 = ETA**(ONE/THREE)

      MSG(LQ,J) = 7
      DIFFJ = BIG

      DO 10 I=1,3

         IF (I.EQ.1) THEN
C  TRY INITIAL RELATIVE STEP SIZE
            H  = H0
            HC = HC0

         ELSE IF (I.EQ.2) THEN
C  TRY LARGER RELATIVE STEP SIZE
            H  = MAX(TEN*H1, MIN(HUNDRD*H0, ONE))
            HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE))

         ELSE IF (I.EQ.3) THEN
C  TRY SMALLER RELATIVE STEP SIZE
            H  = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC))
            HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC))
         END IF

         IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA

            STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
            CALL DPVB(FCN,
     +                N,M,NP,NQ,
     +                BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                NROW,J,LQ,STP0,
     +                ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
         ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA

            STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J))
     +            - XPLUSD(NROW,J)
            CALL DPVD(FCN,
     +                N,M,NP,NQ,
     +                BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                NROW,J,LQ,STP0,
     +                ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
         END IF
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF

         FD = (PVPSTP-PV)/STP0

C  CHECK FOR AGREEMENT

         IF (ABS(FD-D).LE.TOL*ABS(D)) THEN
C  NUMERICAL AND ANALYTIC DERIVATIVES AGREE

C  SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT
            IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN
               DIFFJ = ABS(FD-D)
            ELSE
               DIFFJ = ABS(FD-D)/ABS(D)
            END IF

C  SET MSG FLAG.
            IF (D.EQ.ZERO) THEN

C  JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO.
               MSG(LQ,J) = 1

            ELSE
C  JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO.
               MSG(LQ,J) = 0
            END IF

         ELSE

C  NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE.  CHECK WHY
            IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN
               CALL DJCKZ(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                    NROW,EPSMAC,J,LQ,ISWRTB,
     +                    TOL,D,FD,TYPJ,PVPSTP,STP0,PV,
     +                    DIFFJ,MSG,ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
            ELSE
               CALL DJCKC(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                    ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB,
     +                    FD,TYPJ,PVPSTP,STP0,PV,D,
     +                    DIFFJ,MSG,ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
            END IF
            IF (MSG(LQ,J).LE.2) THEN
               GO TO 20
            END IF
         END IF
   10 CONTINUE

C  SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS
   20 CONTINUE
      IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6
      IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN
         MSG1 = MAX(MSG1,1)
      ELSE IF (MSG(LQ,J).GE.7) THEN
         MSG1 = 2
      END IF

      RETURN
      END
*DJCKZ
      SUBROUTINE DJCKZ
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,EPSMAC,J,LQ,ISWRTB,
     +    TOL,D,FD,TYPJ,PVPSTP,STP0,PV,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKZ
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE
C            DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC
C            DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO
C            (ADAPTED FROM STARPAC SUBROUTINE DCKZRO)
C***END PROLOGUE  DJCKZ

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CD,ONE,PVMSTP,THREE,TWO,ZERO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TWO,THREE
     +   /0.0D0,1.0D0,2.0D0,3.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CD:      THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FROM THE MODEL FOR ROW   NROW   .
C   PVMSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0.
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCKZ


C  RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP
C  SIZE OF 2*STP0

      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA

         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STP0,
     +             ISTOP,NFEV,PVMSTP,
     +             WRK1,WRK2,WRK6)
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA

         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STP0,
     +             ISTOP,NFEV,PVMSTP,
     +             WRK1,WRK2,WRK6)
      END IF
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF

      CD = (PVPSTP-PVMSTP)/(TWO*STP0)
      DIFFJ = MIN(ABS(CD-D),ABS(FD-D))

C  CHECK FOR AGREEMENT

      IF (DIFFJ.LE.TOL*ABS(D)) THEN

C  FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE.
         IF (D.EQ.ZERO) THEN
            MSG(LQ,J) = 1
         ELSE
            MSG(LQ,J) = 0
         END IF

      ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN
C  DERIVATIVES ARE BOTH CLOSE TO ZERO
         MSG(LQ,J) = 2

      ELSE
C  DERIVATIVES ARE NOT BOTH CLOSE TO ZERO
         MSG(LQ,J) = 3
      END IF

      RETURN
      END
*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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  DETERMIND 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,
C                  0 .LT. X(1), AND EMIN .LE. E .LE. EMAX.
C***END PROLOGUE  DPREC
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION B
C        THE BASE OF THE TARGET MACHINE.
C        (MAY BE DEFINED USING I1MACH(10).)
      INTEGER TD
C        THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
C        (MAY BE DEFINED USING I1MACH(14).)
      INTEGER TS
C        THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
C        (MAY BE DEFINED USING I1MACH(11).)
C
C
CCCCC FOR DATAPLOT, USE I1MACH
       INCLUDE 'DPCOMC.INC'
CCCCC
C  TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
C  THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C  REMOVING THE C FROM COLUMN 1.
C
C
C  MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  60 /
C
C  MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM AND
C                        THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA B  /   8 /
C     DATA TS /  13 /
C     DATA TD /  26 /
C
C  MACHINE CONSTANTS FOR THE CDC 6000/7000 AND
C                        THE CYBER 170/180/200 SERIES.
C
C     DATA B  /   2 /
C     DATA TS /  48 /
C     DATA TD /  96 /
C
C  MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA B  /   2 /
C     DATA TS /  47 /
C     DATA TD /  94 /
C
C  MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7
C
C     DATA B  /   2 /
C     DATA TS /  23 /
C     DATA TD /  38 /
C
C  MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  63 /
C
C  MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86.
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE IBM PC USING PROFORT.
C
C     DATA B  /   2 /
C     DATA TS /  23 /
C     DATA TD /  52 /
C
C  MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE INTERDATA 8/32 WITH THE UNIX SYSTEM
C     FORTRAN 77 COMPILER.
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  54 /
C
C  MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  62 /
C
C  MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGER ARITHMETIC.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  60 /
C
C  MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS
C     COMPILER AND FOR THE VAX/VMS VERSION 2.2
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE VAX/VMS V4 SYSTEM USING D_FLOATING
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE VAX/VMS V4 SYSTEM USING G_FLOATING
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  53 /
C
C
C***FIRST EXECUTABLE STATEMENT  DPREC
C
C
      B = I1MACH(10)
      TD = I1MACH(14)
      TS = I1MACH(11)
C
CCCCC APRIL 2001.  NOTE THAT ALTHOUGH DATAPLOT USES THE DOUBLE
CCCCC PRECISION VERSION OF ODRPACK, DATAPLOT FUNCTION EVALUATION
CCCCC IS PERFORMED IN SINGLE PRECISION.  FOR THIS REASON, WE
CCCCC UTILIZE THE SINGLE PRECISION VERSION OF THIS CONSTANT.
C
CCCCC DMPREC = B ** (1-TD)
      DMPREC = B ** (1-TS)
C
      RETURN
C
      END
*DODCHK
      SUBROUTINE DODCHK
     +   (N,M,NP,NQ,
     +   ISODR,ANAJAC,IMPLCT,
     +   IFIXB,
     +   LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LDY,
     +   LWORK,LWKMN,LIWORK,LIWKMN,
     +   SCLB,SCLD,STPB,STPD,
     +   INFO)
C***BEGIN PROLOGUE  DODCHK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING
C            NONZERO VALUES OF ARGUMENT INFO 
C***END PROLOGUE  DODCHK

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ
      LOGICAL
     +   ANAJAC,IMPLCT,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M)
      INTEGER
     +   IFIXB(NP)

C...LOCAL SCALARS
      INTEGER
     +   I,J,K,LAST,NPP

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   LAST:    THE LAST ROW OF THE ARRAY TO BE ACCESSED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY X.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATIONS.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUE FOR DELTA.
C   STPB:    THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA.
C   STPD:    THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA.


C***FIRST EXECUTABLE STATEMENT  DODCHK


C  FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED

      IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN
         NPP = NP
      ELSE
         NPP = 0
         DO 10 K=1,NP
            IF (IFIXB(K).NE.0) THEN
               NPP = NPP + 1
            END IF
   10    CONTINUE
      END IF

C  CHECK PROBLEM SPECIFICATION PARAMETERS

      IF (N.LE.0 .OR. 
     +    M.LE.0 .OR. 
     +    (NPP.LE.0 .OR. NPP.GT.N) .OR.
     +    (NQ.LE.0)) THEN

         INFO = 10000
         IF (N.LE.0) THEN
            INFO = INFO + 1000
         END IF
         IF (M.LE.0) THEN
            INFO = INFO + 100
         END IF
         IF (NPP.LE.0 .OR. NPP.GT.N) THEN
            INFO = INFO + 10
         END IF
         IF (NQ.LE.0) THEN
            INFO = INFO + 1
         END IF

         RETURN

      END IF

C  CHECK DIMENSION SPECIFICATION PARAMETERS

      IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR.
     +    (LDX.LT.N) .OR.
     +    (LDWE.NE.1 .AND. LDWE.LT.N) .OR.
     +    (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR.
     +    (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR.
     +    (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR.
     +    (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR.
     +    (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR.
     +    (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR.
     +    (LWORK.LT.LWKMN) .OR. 
     +    (LIWORK.LT.LIWKMN)) THEN

         INFO = 20000
         IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN
            INFO = INFO + 1000
         END IF
         IF (LDX.LT.N) THEN
            INFO = INFO + 2000
         END IF

         IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR.
     +       (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN
            INFO = INFO + 100
         END IF
         IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. 
     +                    (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN
            INFO = INFO + 200
         END IF

         IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN
            INFO = INFO + 10
         END IF
         IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN
            INFO = INFO + 20
         END IF
         IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN
            INFO = INFO + 40
         END IF

         IF (LWORK.LT.LWKMN) THEN
            INFO = INFO + 1
         END IF
         IF (LIWORK.LT.LIWKMN) THEN
            INFO = INFO + 2
         END IF
         RETURN

      END IF

C  CHECK DELTA SCALING

      IF (ISODR .AND. SCLD(1,1).GT.0) THEN
         IF (LDSCLD.GE.N) THEN
            LAST = N
         ELSE
            LAST = 1
         END IF
         DO 120 J=1,M
            DO 110 I=1,LAST
               IF (SCLD(I,J).LE.0) THEN
                  INFO = 30200
                  GO TO 130
               END IF
  110       CONTINUE
  120    CONTINUE
      END IF
  130 CONTINUE

C  CHECK BETA SCALING

      IF (SCLB(1).GT.0) THEN
         DO 210 K=1,NP
            IF (SCLB(K).LE.0) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 30100
               ELSE
                  INFO = INFO + 100
               END IF
               GO TO 220
            END IF
  210    CONTINUE
      END IF
  220 CONTINUE

C  CHECK DELTA FINITE DIFFERENCE STEP SIZES

      IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN
         IF (LDSTPD.GE.N) THEN
            LAST = N
         ELSE
            LAST = 1
         END IF
         DO 320 J=1,M
            DO 310 I=1,LAST
               IF (STPD(I,J).LE.0) THEN
                  IF (INFO.EQ.0) THEN
                     INFO = 32000
                  ELSE
                     INFO = INFO + 2000
                  END IF
                  GO TO 330
               END IF
  310       CONTINUE
  320    CONTINUE
      END IF
  330 CONTINUE

C  CHECK BETA FINITE DIFFERENCE STEP SIZES

      IF (ANAJAC .AND. STPB(1).GT.0) THEN
         DO 410 K=1,NP
            IF (STPB(K).LE.0) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 31000
               ELSE
                  INFO = INFO + 1000
               END IF
               GO TO 420
            END IF
  410    CONTINUE
      END IF
  420 CONTINUE

      RETURN
      END
*DODCNT
      SUBROUTINE DODCNT
     +   (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODCNT
C***REFER TO   DODR,DODRC
C***ROUTINES CALLED  DODDRV
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 
C            SQUARES (OLS) SOLUTION
C***END PROLOGUE  DODCNT

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ
      LOGICAL
     +   SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO
      INTEGER
     +   IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5,
     +   MAXITI,MAXIT1
      LOGICAL
     +   DONE,FSTITR,HEAD,IMPLCT,PRTPEN

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   PNLTY(1,1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODDRV

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DMPREC
      EXTERNAL
     +   DMPREC

C...DATA STATEMENTS
      DATA
     +   PCHECK,PSTART,PFAC,ZERO,ONE,THREE
     +   /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CNVTOL:  THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS.
C   DONE:    THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS 
C            BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE).
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLES.
C   IPRNTI:  THE PRINT CONTROL VARIABLES.
C   IPR1:    THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR2:    THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR3:    THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR4:    THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOB1:    THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB2:    THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB3:    THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB4:    THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB5:    THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR
C            THE CURRENT PENALTY PARAMETER VALUE.
C   MAXIT1:  FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR
C            THE NEXT PENALTY PARAMETER VALUE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   ONE:     THE VALUE 1.0D0.
C   PARTOL:  THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PCHECK:  THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED
C            BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED.
C   PFAC:    THE FACTOR FOR INCREASING THE PENALTY PARAMETER.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PRTPEN:  THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE
C            PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT
C            (PRTPEN=FALSE).
C   PSTART:  THE FACTOR FOR INCREASING THE PENALTY PARAMETER.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   THREE:   THE VALUE 3.0D0.
C   TSTIMP:  THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL
C            VALUES AND THE SOLUTION.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE INDEPENDENT VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODCNT


      IMPLCT = MOD(JOB,10).EQ.1
      FSTITR = .TRUE.
      HEAD   = .TRUE.
      PRTPEN = .FALSE.
 
      IF (IMPLCT) THEN 

C  SET UP FOR IMPLICIT PROBLEM

         IF (IPRINT.GE.0) THEN
            IPR1   = MOD(IPRINT,10000)/1000
            IPR2   = MOD(IPRINT,1000)/100
            IPR2F  = MOD(IPRINT,100)/10
            IPR3   = MOD(IPRINT,10)
         ELSE
            IPR1   = 2
            IPR2   = 0
            IPR2F  = 0
            IPR3   = 1
         END IF
         IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 

         JOB5   = MOD(JOB,100000)/10000
         JOB4   = MOD(JOB,10000)/1000
         JOB3   = MOD(JOB,1000)/100
         JOB2   = MOD(JOB,100)/10
         JOB1   = MOD(JOB,10)
         JOBI   = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1

         IF (WE(1,1,1).LE.ZERO) THEN
            PNLTY(1,1,1)  = -PSTART
         ELSE
            PNLTY(1,1,1)  = -WE(1,1,1)
         END IF

         IF (PARTOL.LT.ZERO) THEN
            CNVTOL = DMPREC()**(ONE/THREE)
         ELSE
            CNVTOL = MIN(PARTOL,ONE)
         END IF

         IF (MAXIT.GE.1) THEN
            MAXITI = MAXIT
         ELSE
            MAXITI = 100
         END IF

         DONE   = MAXITI.EQ.0
         PRTPEN = .TRUE.

   10    CONTINUE
            CALL DODDRV   
     +           (SHORT,HEAD,FSTITR,PRTPEN, 
     +           FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +           PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +           JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI,
     +           IPRNTI,LUNERR,LUNRPT,
     +           STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +           WORK,LWORK,IWORK,LIWORK,
     +           MAXIT1,TSTIMP, INFO) 

            IF (DONE) THEN
               RETURN
            ELSE
               DONE = MAXIT1.LE.0 .OR.
     +                (ABS(PNLTY(1,1,1)).GE.PCHECK .AND.  
     +                 TSTIMP.LE.CNVTOL)
            END IF

            IF (DONE) THEN
               IF (TSTIMP.LE.CNVTOL) THEN
                  INFO = (INFO/10)*10 + 2
               ELSE
                  INFO = (INFO/10)*10 + 4
               END IF
               JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1
               MAXITI = 0
               IPRNTI = IPR3
            ELSE
               PRTPEN = .TRUE.
               PNLTY(1,1,1) = PFAC*PNLTY(1,1,1)
               JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1
               MAXITI = MAXIT1
               IPRNTI = 0000 + IPR2*100 + IPR2F*10 
            END IF
         GO TO 10
      ELSE        
         CALL DODDRV
     +        (SHORT,HEAD,FSTITR,PRTPEN, 
     +        FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        MAXIT1,TSTIMP, INFO)
      END IF

      RETURN

      END
*DODDRV
      SUBROUTINE DODDRV
     +   (SHORT,HEAD,FSTITR,PRTPEN, 
     +   FCN,  N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   MAXIT1,TSTIMP, INFO)
C***BEGIN PROLOGUE  DODDRV
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS,
C                    DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN,
C                    DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN
C            PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION
C            (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS)
C***END PROLOGUE  DODDRV

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC,TSTIMP
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1,
     +   N,NDIGIT,NP,NQ
      LOGICAL
     +   FSTITR,HEAD,PRTPEN,SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   EPSMAC,ETA,P5,ONE,TEN,ZERO
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI,
     +   DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI,
     +   IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN,
     +   LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI,
     +   NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI,
     +   NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,
     +   VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK,
     +   DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY

C...DATA STATEMENTS
      DATA
     +   ZERO,P5,ONE,TEN
     +   /0.0D0,0.5D0,1.0D0,10.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY F.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   I:       AN INDEX VARIABLE.
C   IDFI:    THE LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   INT2I:   THE IN ARRAY IWORK OF VARIABLE INT2.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   JPVTI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT.
C   K:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDTTI:   THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXIT1:  FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT 
C            PENALTY PARAMETER VALUE.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGB:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGD:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE NITER.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZW:    THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES,
C            SET BY DJCK.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   ONE:     THE VALUE 1.0D0.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS 
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   P5:      THE VALUE 0.5D0.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCOND.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL 
C            (SHORT=FALSE).
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   STPB:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA.
C   STPD:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TEN:     THE VALUE 10.0D0.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TSTIMP:  THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL
C            VALUES AND THE SOLUTION.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WRK:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK,
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSSI:    THE LOCATION IN ARRAY WORK OF VARIABLE WSS.
C   WSSDEI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL.
C   WSSEPI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODDRV


C  INITIALIZE NECESSARY VARIABLES

      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)

C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C  (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF)

      CALL DIWINF(M,NP,NQ,
     +            MSGB,MSGD,JPVTI,ISTOPI,
     +            NNZWI,NPPI,IDFI,
     +            JOBI,IPRINI,LUNERI,LUNRPI,
     +            NROWI,NTOLI,NETAI,
     +            MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +            LIWKMN)

C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C  (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE 
C  ARE HANDLED REASONABLY BY DWINF)

      CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +           DELTAI,FI,XPLUSI,FNI,SDI,VCVI,
     +           RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +           OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +           PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +           BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +           FSI,FJACBI,WE1I,DIFFI,
     +           DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +           WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +           LWKMN)
      IF (ISODR) THEN
         WRK = WRK1I
         LWRK = N*M*NQ + N*NQ
      ELSE
         WRK = WRK2I
         LWRK = N*NQ
      END IF

C  UPDATE THE PENALTY PARAMETERS 
C  (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE)
      IF (RESTRT .AND. IMPLCT) THEN
         WE(1,1,1)  = MAX(WORK(WE1I)**2,ABS(WE(1,1,1)))
         WORK(WE1I) = -SQRT(ABS(WE(1,1,1)))
      END IF

      IF (RESTRT) THEN

C  RESET MAXIMUM NUMBER OF ITERATIONS

         IF (MAXIT.GE.0) THEN
            IWORK(MAXITI) = IWORK(NITERI) + MAXIT
         ELSE
            IWORK(MAXITI) = IWORK(NITERI) + 10
         END IF

         IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN
            INFO = 0
         END IF

         IF (JOB.GE.0) IWORK(JOBI) = JOB
         IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT
         IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL
         IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL

         WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI)

         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
         ELSE
            CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
         END IF
         CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N)
         WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1)
         WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI)

      ELSE

C  PERFORM ERROR CHECKING

         INFO = 0

         CALL DODCHK(N,M,NP,NQ,
     +               ISODR,ANAJAC,IMPLCT,
     +               IFIXB,
     +               LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +               LDY,
     +               LWORK,LWKMN,LIWORK,LIWKMN,
     +               SCLB,SCLD,STPB,STPD,
     +               INFO)
         IF (INFO.GT.0) THEN
            GO TO 50
         END IF

C  INITIALIZE WORK VECTORS AS NECESSARY

         DO 10 I=N*M+N*NQ+1,LWORK
            WORK(I) = ZERO
   10    CONTINUE
         DO 20 I=1,LIWORK
            IWORK(I) = 0
   20    CONTINUE

         CALL DINIWK(N,M,NP,
     +               WORK,LWORK,IWORK,LIWORK,
     +               X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +               BETA,SCLB,
     +               SSTOL,PARTOL,MAXIT,TAUFAC,
     +               JOB,IPRINT,LUNERR,LUNRPT,
     +               EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI,
     +               JOBI,IPRINI,LUNERI,LUNRPI,
     +               SSFI,TTI,LDTTI,DELTAI)

         IWORK(MSGB) = -1
         IWORK(MSGD) = -1
         WORK(TAUI)   = -WORK(TAUFCI)

C  SET UP FOR PARAMETER ESTIMATION -
C  PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES
C  AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY

         CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB)
         CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB)
         NPP = IWORK(NPPI)

C  CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, 
C  SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS

         CALL DFCTRW(N,M,NQ,NPP,
     +               ISODR,
     +               WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +               WORK(WRK2I),WORK(WRK4I),
     +               WORK(WE1I),NNZW,INFO)
         IWORK(NNZWI) = NNZW

         IF (INFO.NE.0) THEN
            GO TO 50
         END IF

C  EVALUATE THE PREDICTED VALUES AND
C               WEIGHTED EPSILONS AT THE STARTING POINT
 
         CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB)
         CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N)
         ISTOP = 0
         CALL FCN(N,M,NP,NQ,
     +            N,M,NP,
     +            BETA,WORK(XPLUSI),
     +            IFIXB,IFIXX,LDIFX,
     +            002,WORK(FNI),WORK(WRK6I),WORK(WRK1I),
     +            ISTOP)
         IWORK(ISTOPI) = ISTOP
         IF (ISTOP.EQ.0) THEN
            IWORK(NFEVI) = IWORK(NFEVI) + 1
            IF (IMPLCT) THEN
               CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
            ELSE
               CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
            END IF
            CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N)
         ELSE 
            INFO = 52000
            GO TO 50
         END IF

C  COMPUTE NORM OF THE INITIAL ESTIMATES

         CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP,
     +              WORK(WRK),NPP)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N,
     +                 WORK(WRK+NPP),N)
            WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1)
         ELSE
            WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1)
         END IF
 
C  COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS
 
         WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N)
            WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1)
         ELSE
            WORK(WSSDEI) = ZERO
         END IF
         WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI)

C  SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS

         NROW = -1
         CALL DSETN(N,M,WORK(XPLUSI),N,NROW)
         IWORK(NROWI) = NROW

C  SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS

         EPSMAC = WORK(EPSMAI)
         IF (NDIGIT.LT.2) THEN
            IWORK(NETAI) = -1
            NFEV = IWORK(NFEVI)
            CALL DETAF(FCN,
     +                 N,M,NP,NQ,
     +                 WORK(XPLUSI),BETA,EPSMAC,NROW,
     +                 WORK(BETANI),WORK(FNI),
     +                 IFIXB,IFIXX,LDIFX,
     +                 ISTOP,NFEV,ETA,NETA,
     +                 WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I))
            IWORK(ISTOPI) = ISTOP
            IWORK(NFEVI) = NFEV
            IF (ISTOP.NE.0) THEN
               INFO = 53000
               IWORK(NETAI) = 0
               WORK(ETAI) = ZERO
               GO TO 50
            ELSE
               IWORK(NETAI) = -NETA
               WORK(ETAI) = ETA
            END IF
         ELSE
            IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC)))
            WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT))
         END IF

C  CHECK DERIVATIVES IF NECESSARY

         IF (CHKJAC .AND. ANAJAC) THEN
            NTOL = -1
            NFEV = IWORK(NFEVI)
            NJEV = IWORK(NJEVI)
            NETA = IWORK(NETAI)
            LDTT = IWORK(LDTTI)
            ETA = WORK(ETAI)
            EPSMAC = WORK(EPSMAI)
            CALL DJCK(FCN,
     +                N,M,NP,NQ,
     +                BETA,WORK(XPLUSI),
     +                IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD,
     +                WORK(SSFI),WORK(TTI),LDTT,
     +                ETA,NETA,NTOL,NROW,ISODR,EPSMAC,
     +                WORK(FNI),WORK(FJACBI),WORK(FJACDI),
     +                IWORK(MSGB),IWORK(MSGD),WORK(DIFFI),
     +                ISTOP,NFEV,NJEV,
     +                WORK(WRK1I),WORK(WRK2I),WORK(WRK6I))
            IWORK(ISTOPI) = ISTOP
            IWORK(NFEVI) = NFEV
            IWORK(NJEVI) = NJEV
            IWORK(NTOLI) = NTOL
            IF (ISTOP.NE.0) THEN
               INFO = 54000
            ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN
               INFO = 40000
            END IF
         ELSE

C  INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED
            IWORK(MSGB) = -1
            IWORK(MSGD) = -1
         END IF

C  PRINT APPROPRIATE ERROR MESSAGES

   50    IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN
            IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN
               CALL DODPER
     +            (INFO,LUNERR,SHORT,
     +            N,M,NP,NQ,
     +            LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +            LWKMN,LIWKMN,
     +            WORK(FJACBI),WORK(FJACDI),
     +            WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD),
     +            WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI))
            END IF

C  SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS

            IF (INFO.EQ.40000) THEN
               IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN
                  IF (IWORK(MSGB).EQ.2) THEN
                     INFO = INFO + 1000
                  END IF
                  IF (IWORK(MSGD).EQ.2) THEN
                     INFO = INFO + 100
                  END IF
               ELSE 
                  INFO = 0
               END IF
            END IF
            IF (INFO.NE.0) THEN
               RETURN
            END IF
         END IF
      END IF

C  SAVE THE INITIAL VALUES OF BETA
      CALL DCOPY(NP,BETA,1,WORK(BETA0I),1)

C  FIND LEAST SQUARES SOLUTION

      CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1)
      LDTT = IWORK(LDTTI)
      CALL DODMN(HEAD,FSTITR,PRTPEN,
     +           FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX,
     +           WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD,
     +           IFIXB,IFIXX,LDIFX,
     +           WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI),
     +           WORK(DELTAI),WORK(DELTNI),WORK(DELTSI),
     +           WORK(TI),WORK(FI),WORK(FNI),WORK(FSI),
     +           WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD),
     +           WORK(SSFI),WORK(SSI),WORK(TTI),LDTT,
     +           STPB,STPD,LDSTPD,
     +           WORK(XPLUSI),WORK(WRK),LWRK,
     +           WORK,LWORK,IWORK,LIWORK,INFO)
      MAXIT1 = IWORK(MAXITI) - IWORK(NITERI)
      TSTIMP = ZERO
      DO 100 K=1,NP
         IF (BETA(K).EQ.ZERO) THEN
            TSTIMP = MAX(TSTIMP,
     +                   ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K))
         ELSE
            TSTIMP = MAX(TSTIMP,
     +                   ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K)))
         END IF
  100 CONTINUE

      RETURN

      END
*DODLM
      SUBROUTINE DODLM
     +   (N,M,NP,NQ,NPP,
     +   F,FJACB,FJACD,
     +   WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +   ALPHA2,TAU,EPSFCN,ISODR,
     +   TFJACB,OMEGA,U,QRAUX,JPVT,
     +   S,T,NLMS,RCOND,IRANK,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODLM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDOT,DNRM2,DODSTP,DSCALE,DWGHT
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T
C            USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT
C            ALGORITHM
C***END PROLOGUE  DODLM

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA2,EPSFCN,RCOND,TAU
      INTEGER
     +   IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP),
     +   T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M),
     +   WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M)
      INTEGER
     +   JPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO
      INTEGER
     +   I,IWRK,J,K,L
      LOGICAL
     +   FORVCV

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODSTP,DSCALE,DWGHT

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P001,P1
     +   /0.0D0,0.001D0,0.1D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHAN:  THE NEW LEVENBERG-MARQUARDT PARAMETER.
C   ALPHA1:  THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER.
C   ALPHA2:  THE CURRENT LEVENBERG-MARQUARDT PARAMETER.
C   BOT:     THE LOWER LIMIT FOR SETTING ALPHA.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN 
C            SUBROUTINE DODSTP.
C   IWRK:    AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   JPVT:    THE PIVOT VECTOR.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NLMS:    THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OMEGA:   THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2)  WHERE
C            P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   P001:    THE VALUE 0.001D0
C   P1:      THE VALUE 0.1D0
C   PHI1:    THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   PHI2:    THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
C   S:       THE STEP FOR BETA.
C   SA:      THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2).
C   SS:      THE SCALING VALUES USED FOR THE UNFIXED BETAS.
C   T:       THE STEP FOR DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TFJACB:  THE ARRAY OMEGA*FJACB.
C   TOP:     THE UPPER LIMIT FOR SETTING ALPHA.
C   TT:      THE SCALE USED FOR THE DELTA'S.
C   U:       THE APPROXIMATE NULL VECTOR FOR TFJACB.
C   WD:      THE DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS, 
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODLM

      FORVCV = .FALSE.
      ISTOPC = 0

C  COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0)

      ALPHA1 = ZERO
      CALL DODSTP(N,M,NP,NQ,NPP,
     +            F,FJACB,FJACD,
     +            WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +            ALPHA1,EPSFCN,ISODR,
     +            TFJACB,OMEGA,U,QRAUX,JPVT,
     +            S,T,PHI1,IRANK,RCOND,FORVCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
      IF (ISTOPC.NE.0) THEN
         RETURN
      END IF

C  INITIALIZE TAU IF NECESSARY

      IF (TAU.LT.ZERO) THEN
         TAU = ABS(TAU)*PHI1
      END IF

C  CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL

      IF ((PHI1-TAU).LE.P1*TAU) THEN
         NLMS = 1
         ALPHA2 = ZERO
         RETURN
      END IF

C  FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION -
C  FIND LOCALLY CONSTRAINED OPTIMAL STEP

      PHI1 = PHI1 - TAU

C  INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA

      BOT = ZERO

      DO 30 K=1,NPP
         DO 20 L=1,NQ
            DO 10 I=1,N
               TFJACB(I,L,K) = FJACB(I,K,L)
   10       CONTINUE
   20    CONTINUE
         WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1)
   30 CONTINUE
      CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP)

      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N)
         IWRK = NPP
         DO 50 J=1,M
            DO 40 I=1,N
               IWRK = IWRK + 1
               WRK(IWRK) = WRK(IWRK) + 
     +                     DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N)
   40       CONTINUE
   50    CONTINUE
         CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N)
         TOP = DNRM2(NPP+N*M,WRK,1)/TAU
      ELSE
         TOP = DNRM2(NPP,WRK,1)/TAU
      END IF

      IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN
         ALPHA2 = P001*TOP
      END IF

C  MAIN LOOP

      DO 60 I=1,10

C  COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR
C  CURRENT VALUE OF ALPHA

         CALL DODSTP(N,M,NP,NQ,NPP,
     +               F,FJACB,FJACD,
     +               WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +               ALPHA2,EPSFCN,ISODR,
     +               TFJACB,OMEGA,U,QRAUX,JPVT,
     +               S,T,PHI2,IRANK,RCOND,FORVCV,
     +               WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
         IF (ISTOPC.NE.0) THEN
            RETURN
         END IF
         PHI2 = PHI2-TAU

C  CHECK WHETHER CURRENT STEP IS OPTIMAL

         IF (ABS(PHI2).LE.P1*TAU .OR.
     +      (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN
            NLMS = I+1
            RETURN
         END IF

C  CURRENT STEP IS NOT OPTIMAL

C  UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA

         IF (PHI1-PHI2.EQ.ZERO) THEN
            NLMS = 12
            RETURN
         END IF
         SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2)
         IF (PHI2.LT.ZERO) THEN
            TOP = MIN(TOP,ALPHA2)
         ELSE
            BOT = MAX(BOT,ALPHA2)
         END IF
         IF (PHI1*PHI2.GT.ZERO) THEN
            BOT = MAX(BOT,ALPHA2-SA)
         ELSE
            TOP = MIN(TOP,ALPHA2-SA)
         END IF

         ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU
         IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN
            ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT))
         END IF

C  GET READY FOR NEXT ITERATION

         ALPHA1 = ALPHA2
         ALPHA2 = ALPHAN
         PHI1 = PHI2
   60 CONTINUE

C  SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS

      NLMS = 12

      RETURN
      END
*DODMN
      SUBROUTINE DODMN
     +   (HEAD,FSTITR,PRTPEN, 
     +   FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX,
     +   WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS,
     +   T,F,FN,FS,FJACB,MSGB,FJACD,MSGD,
     +   SSF,SS,TT,LDTT,STPB,STPD,LDSTPD,
     +   XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO)
C***BEGIN PROLOGUE  DODMN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM,
C                    DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  ITERATIVELY COMPUTE LEAST SQUARES SOLUTION
C***END PROLOGUE  DODMN

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LIWORK,LWORK,LWRK,M,N,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP),
     +   DELTA(N,M),DELTAN(N,M),DELTAS(N,M),
     +   F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ),
     +   S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M),
     +   T(N,M),TT(LDTT,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),
     +   WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK),
     +   MSGB(NQ*NP+1),MSGD(NQ*M+1)
      LOGICAL
     +   FSTITR,HEAD,PRTPEN

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE,
     +   P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS,
     +   RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC,
     +   TEMP,TEMP1,TEMP2,TSNORM,ZERO
      INTEGER
     +   I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK,
     +   ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT,
     +   MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX,
     +   SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6
      LOGICAL
     +   ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV,
     +   IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   WSS(3)

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DACCES,DCOPY,DEVJAC,DFLAGS,
     +   DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN,MOD,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P0001,P1,P25,P5,P75,ONE
     +   /0.0D0,0.00010D0,0.10D0,0.250D0,
     +   0.50D0,0.750D0,1.0D0/
      DATA
     +   LUDFLT
     +   /6/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACCESS:  THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 
C            ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN 
C            THEM (ACCESS=FALSE).
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ACTRS:   THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAC:   THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   BETAN:   THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   BETAS:   THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   CNVPAR:  THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS 
C            ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE).
C   CNVSS:   THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE
C            WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DELTAN:  THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DELTAS:  THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DIRDER:  THE DIRECTIONAL DERIVATIVE.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX
C            SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE NEW PREDICTED VALUES FROM THE FUNCTION.
C   FS:      THE SAVED PREDICTED VALUES FROM THE FUNCTION.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFLAG:   THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   INT2:    THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN.
C   INTDBL:  THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE 
C            USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE).
C   IPR:     THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT.
C   IPR1:    THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE INITIAL SUMMARY REPORT.
C   IPR2:    THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE ITERATION REPORT.
C   IPR2F:   THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
C   IPR3:    THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FINAL SUMMARY REPORT.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. 
C   IWORK:   THE INTEGER WORK SPACE.
C   IWRK:    AN INDEX VARIABLE.
C   J:       AN INDEX VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JPVT:    THE STARTING LOCATION IN IWORK OF ARRAY JPVT.
C   L:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE AND WE1.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE AND WE1.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LOOPED:  A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP
C            HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE
C            ENOUGH THE COMPUTATIONS WILL BE STOPPED.
C   LSTEP:   THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS 
C            BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE).
C   LUDFLT:  THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION
C            REPORTS TO THE SCREEN.
C   LUNR:    THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS TAKEN.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NLMS:    THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NPR:     THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OLMAVG:  THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 
C            ITERATION.
C   OMEGA:   THE STARTING LOCATION IN WORK OF ARRAY OMEGA.
C   ONE:     THE VALUE 1.0D0.
C   P0001:   THE VALUE 0.0001D0.
C   P1:      THE VALUE 0.1D0.
C   P25:     THE VALUE 0.25D0.
C   P5:      THE VALUE 0.5D0.
C   P75:     THE VALUE 0.75D0.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRERS:   THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO
C            BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   QRAUX:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RATIO:   THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED
C            RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORM:   THE NORM OF THE WEIGHTED ERRORS.
C   RNORMN:  THE NEW NORM OF THE WEIGHTED ERRORS.
C   RNORMS:  THE SAVED NORM OF THE WEIGHTED ERRORS.
C   RSS:     THE RESIDUAL SUM OF SQUARES.
C   RVAR:    THE RESIDUAL VARIANCE.
C   S:       THE STEP FOR BETA.
C   SD:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SS:      THE SCALING VALUES USED FOR THE UNFIXED BETAS.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   T:       THE STEP FOR DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TEMP:    A TEMPORARY STORAGE LOCATION.
C   TEMP1:   A TEMPORARY STORAGE LOCATION.
C   TEMP2:   A TEMPORARY STORAGE LOCATION.
C   TSNORM:  THE NORM OF THE SCALED STEP.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   U:       THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCV:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE:      THE EPSILON WEIGHTS.
C   WE1:     THE SQUARE ROOT OF THE EPSILON WEIGHTS.
C   WD:      THE DELTA WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   WRK:     A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2
C   WRK1:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODMN


C  INITIALIZE NECESSARY VARIABLES

      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
      ACCESS = .TRUE.
      CALL DACCES(N,M,NP,NQ,LDWE,LD2WE,
     +            WORK,LWORK,IWORK,LIWORK,
     +            ACCESS,ISODR,
     +            JPVT,OMEGA,U,QRAUX,SD,VCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +            NNZW,NPP,
     +            JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +            LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +            WSS,RVAR,IDF,
     +            TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +            RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)
      RNORM = SQRT(WSS(1))

      DIDVCV = .FALSE.
      INTDBL = .FALSE.
      LSTEP = .TRUE.

C  PRINT INITIAL SUMMARY IF DESIRED

      IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
         IFLAG = 1
         IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN
            NPR = 2
         ELSE
            NPR = 1
         END IF
         IF (IPR1.GE.6) THEN
            IPR = 2 
         ELSE
            IPR = 2 - MOD(IPR1,2)
         END IF
         LUNR = LUNRPT
         DO 10 I=1,NPR
            CALL DODPCR(IPR,LUNR, 
     +                   HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                   N,M,NP,NQ,NPP,NNZW,
     +                   MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                   IFIXB,IFIXX,LDIFX,
     +                   SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                   WSS,RVAR,IDF,WORK(SD),
     +                   NITER,NFEV,NJEV,ACTRED,PRERED,
     +                   TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
            IF (IPR1.GE.5) THEN
               IPR = 2
            ELSE
               IPR = 1
            END IF
            LUNR = LUDFLT
   10    CONTINUE

      END IF

C  STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION

      IF (RNORM.EQ.ZERO) THEN
         INFO = 1
         OLMAVG = ZERO
         ISTOP = 0
         GO TO 150
      END IF

C  STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED

      IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN
         ISTOP = 0
         GO TO 150
      ELSE IF (NITER.GE.MAXIT) THEN
         INFO = 4
         ISTOP = 0
         GO TO 150
      END IF

C  MAIN LOOP

  100 CONTINUE
 
      NITER = NITER + 1
      RNORMS = RNORM
      LOOPED = 0

C  EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS)

      IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN
         ISTOP = 0
      ELSE
         CALL DEVJAC(FCN,
     +               ANAJAC,CDJAC, 
     +               N,M,NP,NQ,
     +               BETAC,BETA,STPB, 
     +               IFIXB,IFIXX,LDIFX,
     +               X,LDX,DELTA,XPLUSD,STPD,LDSTPD, 
     +               SSF,TT,LDTT,NETA,FS,
     +               T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
     +               FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +               NJEV,NFEV,ISTOP,INFO)
      END IF
      IF (ISTOP.NE.0) THEN
         INFO = 51000
         GO TO 200
      ELSE IF (INFO.EQ.50300) THEN
         GO TO 200
      END IF

C  SUB LOOP FOR
C     INTERNAL DOUBLING OR
C     COMPUTING NEW STEP WHEN OLD FAILED

  110 CONTINUE

C  COMPUTE STEPS S AND T

      IF (LOOPED.GT.100) THEN
         INFO = 60000
         GO TO 200
      ELSE
         LOOPED = LOOPED + 1
         CALL DODLM(N,M,NP,NQ,NPP,
     +              F,FJACB,FJACD,
     +              WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +              ALPHA,TAU,ETA,ISODR,
     +              WORK(WRK6),WORK(OMEGA),
     +              WORK(U),WORK(QRAUX),IWORK(JPVT),
     +              S,T,NLMS,RCOND,IRANK,
     +              WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4),
     +              WORK(WRK5),WRK,LWRK,ISTOPC)
      END IF
      IF (ISTOPC.NE.0) THEN
         INFO = ISTOPC
         GO TO 200
      END IF
      OLMAVG = OLMAVG+NLMS

C  COMPUTE BETAN = BETAC + S
C          DELTAN = DELTA + T

      CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP)
      IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N)

C  COMPUTE NORM OF SCALED STEPS S AND T (TSNORM)

      CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
      IF (ISODR) THEN
         CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
         TSNORM = DNRM2(NPP+N*M,WRK,1)
      ELSE 
         TSNORM = DNRM2(NPP,WRK,1)
      END IF

C  COMPUTE SCALED PREDICTED REDUCTION

      IWRK = 0
      DO 130 L=1,NQ
         DO 120 I=1,N
           IWRK = IWRK + 1
           WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1)
           IF (ISODR) WRK(IWRK) = WRK(IWRK) + 
     +                            DDOT(M,FJACD(I,1,L),N,T(I,1),N)
  120    CONTINUE
  130 CONTINUE
      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N)
         TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1)
         TEMP1 = SQRT(TEMP1)/RNORM
      ELSE
         TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM
      END IF
      TEMP2 = SQRT(ALPHA)*TSNORM/RNORM
      PRERED = TEMP1**2+TEMP2**2/P5

      DIRDER = -(TEMP1**2+TEMP2**2)

C  EVALUATE PREDICTED VALUES AT NEW POINT

      CALL DUNPAC(NP,BETAN,BETA,IFIXB)
      CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N)
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         002,FN,WORK(WRK6),WORK(WRK1),
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      END IF

      IF (ISTOP.LT.0) THEN

C  SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN

         INFO = 51000
         GO TO 200
      ELSE IF (ISTOP.GT.0) THEN

C  SET NORM TO INDICATE STEP SHOULD BE REJECTED

         RNORMN = RNORM/(P1*P75)
      ELSE

C  COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN)

         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,FN,1,WRK,1)
         ELSE
            CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N)
         END IF
         CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N)
            RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + 
     +                    DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1))
         ELSE
            RNORMN = DNRM2(N*NQ,WRK,1)
         END IF
      END IF

C  COMPUTE SCALED ACTUAL REDUCTION

      IF (P1*RNORMN.LT.RNORM) THEN
         ACTRED = ONE - (RNORMN/RNORM)**2
      ELSE
         ACTRED = -ONE
      END IF

C  COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION

      IF(PRERED .EQ. ZERO) THEN
         RATIO = ZERO
      ELSE
         RATIO = ACTRED/PRERED
      END IF

C  CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE

      IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN
         ISTOP = 0
         TAU = TAU*P5
         ALPHA = ALPHA/P5
         CALL DCOPY(NPP,BETAS,1,BETAN,1)
         CALL DCOPY(N*M,DELTAS,1,DELTAN,1)
         CALL DCOPY(N*NQ,FS,1,FN,1)
         ACTRED = ACTRS
         PRERED = PRERS
         RNORMN = RNORMS
         RATIO = P5
      END IF

C  UPDATE STEP BOUND

      INTDBL = .FALSE.
      IF (RATIO.LT.P25) THEN
         IF (ACTRED.GE.ZERO) THEN
            TEMP = P5
         ELSE
            TEMP = P5*DIRDER/(DIRDER+P5*ACTRED)
         END IF
         IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN
            TEMP = P1
         END IF
         TAU = TEMP*MIN(TAU,TSNORM/P1)
         ALPHA = ALPHA/TEMP

      ELSE IF (ALPHA.EQ.ZERO) THEN
         TAU = TSNORM/P5

      ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN

C  STEP QUALIFIES FOR INTERNAL DOUBLING
C     - UPDATE TAU AND ALPHA
C     - SAVE INFORMATION FOR CURRENT POINT

         INTDBL = .TRUE.

         TAU = TSNORM/P5
         ALPHA = ALPHA*P5

         CALL DCOPY(NPP,BETAN,1,BETAS,1)
         CALL DCOPY(N*M,DELTAN,1,DELTAS,1)
         CALL DCOPY(N*NQ,FN,1,FS,1)
         ACTRS = ACTRED
         PRERS = PRERED
         RNORMS = RNORMN
      END IF

C  IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS

      IF (INTDBL .AND. TAU.GT.ZERO) THEN
         INT2 = INT2+1
         GO TO 110
      END IF

C  CHECK ACCEPTANCE

      IF (RATIO.GE.P0001) THEN
         CALL DCOPY(N*NQ,FN,1,FS,1)
         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,FS,1,F,1)
         ELSE
            CALL DXMY(N,NQ,FS,N,Y,LDY,F,N)
         END IF
         CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N)
         CALL DCOPY(NPP,BETAN,1,BETAC,1)
         CALL DCOPY(N*M,DELTAN,1,DELTA,1)
         RNORM = RNORMN
         CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP)
         IF (ISODR) THEN
            CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N)
            PNORM = DNRM2(NPP+N*M,WRK,1)
         ELSE
            PNORM = DNRM2(NPP,WRK,1)
         END IF
         LSTEP = .TRUE.
      ELSE
         LSTEP = .FALSE.
      END IF

C  TEST CONVERGENCE

      INFO = 0
      CNVSS = RNORM.EQ.ZERO
     +        .OR.
     +        (ABS(ACTRED).LE.SSTOL .AND.
     +         PRERED.LE.SSTOL      .AND.
     +         P5*RATIO.LE.ONE)
      CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT)
      IF (CNVSS)                            INFO = 1
      IF (CNVPAR)                           INFO = 2
      IF (CNVSS .AND. CNVPAR)               INFO = 3

C  PRINT ITERATION REPORT

      IF (INFO.NE.0 .OR. LSTEP) THEN
         IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN
            IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN
               IFLAG = 2
               CALL DUNPAC(NP,BETAC,BETA,IFIXB)
               WSS(1) = RNORM*RNORM
               IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN
                  NPR = 2
               ELSE
                  NPR = 1
               END IF
               IF (IPR2.GE.6) THEN
                  IPR = 2 
               ELSE
                  IPR = 2 - MOD(IPR2,2)
               END IF
               LUNR = LUNRPT
               DO 140 I=1,NPR
                  CALL DODPCR(IPR,LUNR,
     +                        HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                        N,M,NP,NQ,NPP,NNZW,
     +                        MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                        WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                        IFIXB,IFIXX,LDIFX,
     +                        SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                        JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                        WSS,RVAR,IDF,WORK(SD),
     +                        NITER,NFEV,NJEV,ACTRED,PRERED,
     +                        TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
                  IF (IPR2.GE.5) THEN
                     IPR = 2
                  ELSE
                     IPR = 1
                  END IF
                  LUNR = LUDFLT
  140          CONTINUE
               FSTITR = .FALSE.
               PRTPEN = .FALSE.
            END IF
         END IF
      END IF

C  CHECK IF FINISHED

      IF (INFO.EQ.0) THEN
         IF (LSTEP) THEN

C  BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET

            IF (NITER.GE.MAXIT) THEN
               INFO = 4
            ELSE
               GO TO 100
            END IF
         ELSE

C  STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET

            GO TO 110
         END IF
      END IF

  150 CONTINUE

      IF (ISTOP.GT.0) INFO = INFO + 100

C  STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER

      IF (IMPLCT) THEN
         CALL DCOPY(N*NQ,FS,1,F,1)
      ELSE
         CALL DXMY(N,NQ,FS,N,Y,LDY,F,N)
      END IF
      CALL DUNPAC(NP,BETAC,BETA,IFIXB)
      CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)

C  COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C  IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED

      IF (DOVCV .AND. ISTOP.EQ.0) THEN
            
C  RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
C  OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
C  TO COMPUTE COVARIANCE MATRIX

         IF (REDOJ) THEN
            CALL DEVJAC(FCN,
     +                   ANAJAC,CDJAC,
     +                   N,M,NP,NQ,
     +                   BETAC,BETA,STPB,
     +                   IFIXB,IFIXX,LDIFX,
     +                   X,LDX,DELTA,XPLUSD,STPD,LDSTPD,
     +                   SSF,TT,LDTT,NETA,FS,
     +                   T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
     +                   FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +                   NJEV,NFEV,ISTOP,INFO)


            IF (ISTOP.NE.0) THEN
               INFO = 51000
               GO TO 200
            ELSE IF (INFO.EQ.50300) THEN
               GO TO 200
            END IF
         END IF

         IF (IMPLCT) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
            RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
         ELSE
            RSS = RNORM*RNORM
         END IF
         IF (REDOJ .OR. NITER.GE.1) THEN
            CALL DODVCV(N,M,NP,NQ,NPP,
     +                  F,FJACB,FJACD,
     +                  WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA,
     +                  ETA,ISODR,
     +                  WORK(VCV),WORK(SD),
     +                  WORK(WRK6),WORK(OMEGA),
     +                  WORK(U),WORK(QRAUX),IWORK(JPVT),
     +                  S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB,
     +                  WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4),
     +                  WORK(WRK5),WRK,LWRK,ISTOPC)
            IF (ISTOPC.NE.0) THEN
               INFO = ISTOPC
               GO TO 200
            END IF
            DIDVCV = .TRUE.
         END IF

      END IF

C  SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS

  200 DO 210 I=0,NP-1
         WORK(WRK3+I) = IWORK(JPVT+I)
         IWORK(JPVT+I) = -2
  210 CONTINUE
      IF (REDOJ .OR. NITER.GE.1) THEN
         DO 220 I=0,NPP-1
            J = WORK(WRK3+I) - 1
            IF (I.LE.NPP-IRANK-1) THEN
               IWORK(JPVT+J) = 1
            ELSE 
               IWORK(JPVT+J) = -1
            END IF
  220    CONTINUE
         IF (NPP.LT.NP) THEN
            J = NPP-1
            DO 230 I=NP-1,0,-1
               IF (IFIXB(I+1).EQ.0) THEN
                  IWORK(JPVT+I) = 0
               ELSE
                  IWORK(JPVT+I) = IWORK(JPVT+J)
                  J = J - 1
               END IF
  230       CONTINUE
         END IF
      END IF

C  STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER

      IF (NITER.GE.1) THEN
         OLMAVG = OLMAVG/NITER
      ELSE
         OLMAVG = ZERO
      END IF

C  COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER

      CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N)
      WSS(3) = DDOT(N*NQ,WRK,1,WRK,1)
      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
         WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
      ELSE
         WSS(2) = ZERO
      END IF
      WSS(1) = WSS(2) + WSS(3)

      ACCESS = .FALSE.
      CALL DACCES(N,M,NP,NQ,LDWE,LD2WE,
     +            WORK,LWORK,IWORK,LIWORK,
     +            ACCESS,ISODR,
     +            JPVT,OMEGA,U,QRAUX,SD,VCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +            NNZW,NPP,
     +            JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +            LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +            WSS,RVAR,IDF,
     +            TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +            RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)

C  ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO

      IF (INFO.LE.9 .OR. INFO.GE.60000) THEN
         IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN
            INFO = INFO + 1000
         END IF
         IF (ISTOP.NE.0) THEN
            INFO = INFO + 100
         END IF
         IF (IRANK.GE.1) THEN
            IF (NPP.GT.IRANK) THEN
               INFO = INFO + 10
            ELSE
               INFO = INFO + 20
            END IF
         END IF
      END IF

C  PRINT FINAL SUMMARY

      IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN
         IFLAG = 3

         IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN
            NPR = 2
         ELSE
            NPR = 1
         END IF
         IF (IPR3.GE.6) THEN
            IPR = 2 
         ELSE
            IPR = 2 - MOD(IPR3,2)
         END IF
         LUNR = LUNRPT
         DO 240 I=1,NPR
            CALL DODPCR(IPR,LUNR, 
     +                  HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                  N,M,NP,NQ,NPP,NNZW,
     +                  MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                  WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                  IWORK(JPVT),IFIXX,LDIFX,
     +                  SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                  JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                  WSS,RVAR,IDF,WORK(SD),
     +                  NITER,NFEV,NJEV,ACTRED,PRERED,
     +                  TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
            IF (IPR3.GE.5) THEN
               IPR = 2
            ELSE
               IPR = 1
            END IF
            LUNR = LUDFLT
  240    CONTINUE
      END IF

      RETURN

      END
*DODPC1
      SUBROUTINE DODPC1
     +   (IPR,LUNRPT,
     +   ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ,
     +   MSGB1,MSGB,MSGD1,MSGD,
     +   N,M,NP,NQ,NPP,NNZW,
     +   X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD,
     +   Y,LDY,WE,LDWE,LD2WE,PNLTY,
     +   BETA,IFIXB,SSF,STPB,
     +   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   WSS,WSSDEL,WSSEPS)
C***BEGIN PROLOGUE  DODPC1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DHSTEP
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE INITIAL SUMMARY REPORT
C***END PROLOGUE  DODPC1

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS
      INTEGER
     +   IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M),
     +   TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M),
     +   Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP1,TEMP2,TEMP3,ZERO
      INTEGER
     +   I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L

C...LOCAL ARRAYS
      CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP


C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES 
C            (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 
C            (CHKJAC=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ITEMP:   A TEMPORARY INTEGER VALUE.
C   J:       AN INDEXING VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOB1:    THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB2:    THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB3:    THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB4:    THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB5:    THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C            A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY
C            ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED
C            BY THE USER.
C   NNZW:    THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   SSF:     THE SCALING VALUES FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TEMPC0:  A TEMPORARY CHARACTER*2 VALUE.
C   TEMPC1:  A TEMPORARY CHARACTER*5 VALUE.
C   TEMPC2:  A TEMPORARY CHARACTER*13 VALUE.
C   TEMP1:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TEMP2:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TEMP3:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TT:      THE SCALING VALUES FOR DELTA.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   WSSDEL:  THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS.
C   WSSEPS:  THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE RESPONSE VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODPC1


C  PRINT PROBLEM SIZE SPECIFICATION

CCCCC WRITE (ICOUT,1000) N,NNZW,NQ,M,NP,NPP
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1002)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1003) N
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1004) NNZW
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1005) NQ
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1006) M
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1008) NP
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1010) NPP
      CALL DPWRST('XXX','BUG')


C  PRINT CONTROL VALUES

      JOB1 = JOB/10000
      JOB2 = MOD(JOB,10000)/1000
      JOB3 = MOD(JOB,1000)/100
      JOB4 = MOD(JOB,100)/10
      JOB5 = MOD(JOB,10)
      WRITE (ICOUT,1100)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1101) JOB
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1102)
      CALL DPWRST('XXX','BUG')
      IF (RESTRT) THEN
         WRITE (ICOUT,1110) JOB1
         CALL DPWRST('XXX','BUG')
      ELSE
         WRITE (ICOUT,1111) JOB1
         CALL DPWRST('XXX','BUG')
      END IF
      IF (ISODR) THEN
         IF (INITD) THEN
            WRITE (ICOUT,1120) JOB2
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,1121) JOB2
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE
         WRITE (ICOUT,1122) JOB2,JOB5
         CALL DPWRST('XXX','BUG')
      END IF
      IF (DOVCV) THEN
         WRITE (ICOUT,1130) JOB3
         CALL DPWRST('XXX','BUG')
         IF (REDOJ) THEN
            WRITE (ICOUT,1131) 
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,1132)
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE
         WRITE (ICOUT,1133) JOB3
         CALL DPWRST('XXX','BUG')
      END IF
      IF (ANAJAC) THEN
         WRITE (ICOUT,1140) JOB4
         CALL DPWRST('XXX','BUG')
         IF (CHKJAC) THEN
            IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN
               WRITE (ICOUT,1141)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,11141)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,1142)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,11142)
               CALL DPWRST('XXX','BUG')
            END IF
         ELSE
            WRITE (ICOUT,1143)
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE IF (CDJAC) THEN
         WRITE (ICOUT,1144) JOB4
         CALL DPWRST('XXX','BUG')
      ELSE 
         WRITE (ICOUT,1145) JOB4
         CALL DPWRST('XXX','BUG')
      END IF
      IF (ISODR) THEN
         IF (IMPLCT) THEN
            WRITE (ICOUT,1150) JOB5
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,1151) JOB5
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE
         WRITE (ICOUT,1152) JOB5
         CALL DPWRST('XXX','BUG')
      END IF
      IF (NETA.LT.0) THEN
         WRITE (ICOUT,1200) -NETA
         CALL DPWRST('XXX','BUG')
      ELSE
         WRITE (ICOUT,1210) NETA
         CALL DPWRST('XXX','BUG')
      END IF
      WRITE (ICOUT,1300) TAUFAC
      CALL DPWRST('XXX','BUG')


C  PRINT STOPPING CRITERIA

      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1400)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1401) SSTOL
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1402) PARTOL
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1403) MAXIT
      CALL DPWRST('XXX','BUG')


C  PRINT INITIAL SUM OF SQUARES

      IF (IMPLCT) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1500) WSSDEL
         CALL DPWRST('XXX','BUG')
         IF (ISODR) THEN
            WRITE (ICOUT,1510) WSS
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1511) WSSEPS
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1512) PNLTY
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1600) WSS
         CALL DPWRST('XXX','BUG')
         IF (ISODR) THEN
            WRITE (ICOUT,1610) WSSDEL
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1611) WSSEPS
            CALL DPWRST('XXX','BUG')
         END IF
      END IF

 
      IF (IPR.GE.2) THEN


C  PRINT FUNCTION PARAMETER DATA

         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,4000)
         CALL DPWRST('XXX','BUG')
         IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,4110)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
         ELSE IF (ANAJAC) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,4120)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
         ELSE 
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,4200)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
         END IF 
         DO 130 J=1,NP
            IF (IFIXB(1).LT.0) THEN
               TEMPC1 = '   NO'
            ELSE
               IF (IFIXB(J).NE.0) THEN
                  TEMPC1 = '   NO'
               ELSE
                  TEMPC1 = '  YES'
               END IF
            END IF
            IF (ANAJAC) THEN
               IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
                  ITEMP = -1
                  DO 110 L=1,NQ
                     ITEMP = MAX(ITEMP,MSGB(L,J))
  110             CONTINUE
                  IF (ITEMP.LE.-1) THEN
                     TEMPC2 = '    UNCHECKED'
                  ELSE IF (ITEMP.EQ.0) THEN
                     TEMPC2 = '     VERIFIED'
                  ELSE IF (ITEMP.GE.1) THEN
                     TEMPC2 = ' QUESTIONABLE'
                  END IF
               ELSE
                  TEMPC2 = '             '
               END IF
            ELSE
               TEMPC2 = '             '
            END IF
            IF (SSF(1).LT.ZERO) THEN
               TEMP1 = ABS(SSF(1))
            ELSE
               TEMP1 = SSF(J)
            END IF
            IF (ANAJAC) THEN
               WRITE (ICOUT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2
               CALL DPWRST('XXX','BUG')
            ELSE
               IF (CDJAC) THEN 
                  TEMP2 = DHSTEP(1,NETA,1,J,STPB,1)
               ELSE
                  TEMP2 = DHSTEP(0,NETA,1,J,STPB,1)
               END IF
               WRITE (ICOUT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2
               CALL DPWRST('XXX','BUG')
            END IF
  130    CONTINUE

C  PRINT EXPLANATORY VARIABLE DATA

         IF (ISODR) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2010)
            CALL DPWRST('XXX','BUG')
            IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2110)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2111)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2112)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            ELSE IF (ANAJAC) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2120)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2121)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2122)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2130)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2131)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2132)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            END IF
         ELSE
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2020)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2140)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2141)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (ISODR) THEN
            DO 240 J = 1,M
               TEMPC0 = '1,'
               DO 230 I=1,N,N-1

                  IF (IFIXX(1,1).LT.0) THEN
                     TEMPC1 = '   NO'
                  ELSE
                     IF (LDIFX.EQ.1) THEN
                        IF (IFIXX(1,J).EQ.0) THEN
                           TEMPC1 = '  YES'
                        ELSE
                           TEMPC1 = '   NO'
                        END IF
                     ELSE
                        IF (IFIXX(I,J).EQ.0) THEN
                           TEMPC1 = '  YES'
                        ELSE
                           TEMPC1 = '   NO'
                        END IF
                     END IF
                  END IF

                  IF (TT(1,1).LT.ZERO) THEN
                     TEMP1 = ABS(TT(1,1))
                  ELSE
                     IF (LDTT.EQ.1) THEN
                        TEMP1 = TT(1,J)
                     ELSE
                        TEMP1 = TT(I,J)
                     END IF
                  END IF

                  IF (WD(1,1,1).LT.ZERO) THEN
                     TEMP2 = ABS(WD(1,1,1))
                  ELSE
                     IF (LDWD.EQ.1) THEN
                        IF (LD2WD.EQ.1) THEN
                           TEMP2 = WD(1,1,J)
                        ELSE
                           TEMP2 = WD(1,J,J)
                        END IF
                     ELSE
                        IF (LD2WD.EQ.1) THEN
                           TEMP2 = WD(I,1,J)
                        ELSE
                           TEMP2 = WD(I,J,J)
                        END IF
                     END IF
                  END IF

                  IF (ANAJAC) THEN
                     IF (CHKJAC .AND. 
     +                   (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND.
     +                    (I.EQ.1))) THEN
                        ITEMP = -1
                        DO 210 L=1,NQ
                           ITEMP = MAX(ITEMP,MSGD(L,J))
  210                   CONTINUE
                        IF (ITEMP.LE.-1) THEN
                           TEMPC2 = '    UNCHECKED'
                        ELSE IF (ITEMP.EQ.0) THEN
                           TEMPC2 = '     VERIFIED'
                        ELSE IF (ITEMP.GE.1) THEN
                           TEMPC2 = ' QUESTIONABLE'
                        END IF
                     ELSE
                        TEMPC2 = '             '
                     END IF
                     IF (M.LE.9) THEN
                        WRITE (ICOUT,5110) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2
                        CALL DPWRST('XXX','BUG')
                     ELSE
                        WRITE (ICOUT,5120) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2
                        CALL DPWRST('XXX','BUG')
                     END IF
                  ELSE
                     TEMPC2 = '             '  
                     IF (CDJAC) THEN 
                        TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD)
                     ELSE
                        TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD)
                     END IF
                     IF (M.LE.9) THEN
                        WRITE (ICOUT,5210) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3
                        CALL DPWRST('XXX','BUG')
                     ELSE
                        WRITE (ICOUT,5220) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3
                        CALL DPWRST('XXX','BUG')
                     END IF
                  END IF

                  TEMPC0 = 'N,'

  230          CONTINUE
               IF (J.LT.M) THEN
                 WRITE (ICOUT,6000)
                 CALL DPWRST('XXX','BUG')
                ENDIF
  240       CONTINUE
         ELSE

            DO 260 J = 1,M
               TEMPC0 = '1,'
               DO 250 I=1,N,N-1
                  IF (M.LE.9) THEN
                     WRITE (ICOUT,5110) 
     +                  TEMPC0,J,X(I,J)
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,5120) 
     +                  TEMPC0,J,X(I,J)
                     CALL DPWRST('XXX','BUG')
                  END IF
                  TEMPC0 = 'N,'
  250          CONTINUE
               IF (J.LT.M) THEN
                     WRITE (ICOUT,6000)
                     CALL DPWRST('XXX','BUG')
               ENDIF
  260       CONTINUE
         END IF

C  PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS

         IF (.NOT.IMPLCT) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,3000)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,3100)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            WRITE (ICOUT,3101)
            CALL DPWRST('XXX','BUG')
            CALL DPWRST('XXX','BUG')
            DO 310 L=1,NQ
               TEMPC0 = '1,'
               DO 300 I=1,N,N-1
                  IF (WE(1,1,1).LT.ZERO) THEN
                     TEMP1 = ABS(WE(1,1,1))
                  ELSE IF (LDWE.EQ.1) THEN
                     IF (LD2WE.EQ.1) THEN
                        TEMP1 = WE(1,1,L)
                     ELSE 
                        TEMP1 = WE(1,L,L)
                     END IF
                  ELSE 
                     IF (LD2WE.EQ.1) THEN
                        TEMP1 = WE(I,1,L)
                     ELSE 
                        TEMP1 = WE(I,L,L)
                     END IF
                  END IF
                  IF (NQ.LE.9) THEN
                     WRITE (ICOUT,5110) 
     +                  TEMPC0,L,Y(I,L),TEMP1
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,5120) 
     +                  TEMPC0,L,Y(I,L),TEMP1
                     CALL DPWRST('XXX','BUG')
                  END IF
                  TEMPC0 = 'N,'
  300          CONTINUE
               IF (L.LT.NQ) THEN
                  WRITE (ICOUT,6000)
                  CALL DPWRST('XXX','BUG')
               ENDIF
  310       CONTINUE
         END IF
      END IF
      RETURN
C  FORMAT STATEMENTS
C
  999 FORMAT(1X)
C
 1000 FORMAT
     +   (' --- PROBLEM SIZE:')
 1002 FORMAT
     +      (' -------------')
 1003 FORMAT
     +      ('      NUMBER OF OBSERVATIONS                  = ',I5)
 1004 FORMAT
     +      ('      NUMBER WITH NONZERO WEIGHT              = ',I5)
 1005 FORMAT
     +      ('      NUMBER OF RESPONSES PER OBSERVATION     = ',I5)
 1006 FORMAT
     +      ('      NUMBER OF INDEPENDENT VARIABLES         = ',I5)
 1008 FORMAT
     +      ('      NUMBER OF FUNCTION PARAMETERS           = ',I5)
 1010 FORMAT
     +      ('      NUMBER OF UNFIXED FUNCTION PARAMETERS   = ',I5)
C
 1100 FORMAT
     +  (' --- CONTROL VALUES:')
 1101 FORMAT
     +   ('          JOB = ',I5.5)
 1102 FORMAT
     +   ('              = ABCDE, WHERE')
 1110 FORMAT
     +   ('                       A=',I1,' ==> FIT IS A RESTART.')
 1111 FORMAT
     +   ('                       A=',I1,' ==> FIT IS NOT A RESTART.')
 1120 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE INITIALIZED',
     +                                     ' TO ZERO.')
 1121 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE INITIALIZED',
     +                                     ' BY USER.')
 1122 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE FIXED AT',
     +                                     ' ZERO SINCE E=',I1,'.')
 1130 FORMAT
     +   ('                       C=',I1,' ==> COVARIANCE MATRIX WILL',
     +                                     ' BE COMPUTED USING')
 1131 FORMAT
     +   ('                               DERIVATIVES RE-EVALUATED',
     +                                     ' AT THE SOLUTION.')
 1132 FORMAT
     +   ('                               DERIVATIVES FROM THE',
     +                                     ' LAST ITERATION.')
 1133 FORMAT
     +   ('                       C=',I1,' ==> COVARIANCE MATRIX WILL',
     +                                     ' NOT BE COMPUTED.')
 1140 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' SUPPLIED BY USER.')
 1141 FORMAT
     +   ('                               DERIVATIVES WERE CHECKED.')
11141 FORMAT
     +   ('                               RESULTS APPEAR QUESTIONABLE.')
 1142 FORMAT
     +   ('                               DERIVATIVES WERE CHECKED.')
11142 FORMAT
     +   ('                               RESULTS APPEAR CORRECT.')
 1143 FORMAT
     +   ('                               DERIVATIVES WERE NOT',
     +                                     ' CHECKED.')
 1144 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' ESTIMATED BY CENTRAL',
     +                                     ' DIFFERENCES.')
 1145 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' ESTIMATED BY FORWARD',
     +                                     ' DIFFERENCES.')
 1150 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS IMPLICIT ODR.')
 1151 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS EXPLICIT ODR.')
 1152 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS EXPLICIT OLS.')
 1200 FORMAT
     +   ('       NDIGIT = ',I5,'          (ESTIMATED BY ODRPACK)')
 1210 FORMAT
     +   ('       NDIGIT = ',I5,'          (SUPPLIED BY USER)')
 1300 FORMAT
     +   ('       TAUFAC = ',1P,D12.2)
 1400 FORMAT
     +   (' --- STOPPING CRITERIA:')
 1401 FORMAT
     +    ('        SSTOL = ',1P,D12.2,
     +                      '   (SUM OF SQUARES STOPPING TOLERANCE)')
 1402 FORMAT
     +    ('       PARTOL = ',1P,D12.2,
     +                      '   (PARAMETER STOPPING TOLERANCE)')
 1403 FORMAT
     +    ('        MAXIT = ',I5,
     +                      '          (MAXIMUM NUMBER OF ITERATIONS)')
 1500 FORMAT
     +   (' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =',
     +     17X,1P,D17.8)
 1510 FORMAT
     +   ( '         INITIAL PENALTY FUNCTION VALUE     =',1P,D17.8)
 1511 FORMAT
     +    ('                 PENALTY TERM               =',1P,D17.8)
 1512 FORMAT
     +    ('                 PENALTY PARAMETER          =',1P,D10.1)
 1600 FORMAT
     +   (' --- INITIAL WEIGHTED SUM OF SQUARES        =',
     +     17X,1P,D17.8)
 1610 FORMAT
     +   ( '         SUM OF SQUARED WEIGHTED DELTAS     =',1P,D17.8)
 1611 FORMAT
     +    ('         SUM OF SQUARED WEIGHTED EPSILONS   =',1P,D17.8)
 2010 FORMAT
     +   (' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:')
 2020 FORMAT
     +   (' --- EXPLANATORY VARIABLE SUMMARY:')
 2110 FORMAT
     +   ('       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT    DERIVATIVE')
 2111 FORMAT
     +    ('                                             ',
     +           '                        ASSESSMENT')
 2112 FORMAT
     +    ('       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)              ')
 2120 FORMAT
     +   ('       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT              ')
 2121 FORMAT
     +    ('                                             ',
     +           '                                  ')
 2122 FORMAT
     +    ('       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)              ')
 2130 FORMAT
     +   ('       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT    DERIVATIVE')
 2131 FORMAT
     +    ('                                             ',
     +           '                         STEP SIZE')
 2132 FORMAT
     +    ('       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)        (STPD)')
 2140 FORMAT
     +   ('       INDEX      X(I,J)')
 2141 FORMAT
     +    ('       (I,J)            ')
 3000 FORMAT
     +   (' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT',
     +   ' SUMMARY:')
 3100 FORMAT
     +   ('       INDEX      Y(I,L)      WEIGHT')
 3101 FORMAT
     +    ('       (I,L)                    (WE)')
 4000 FORMAT
     +   (' --- FUNCTION PARAMETER SUMMARY:')
 4110 FORMAT
     +   ('       INDEX         BETA(K)    FIXED           SCALE',
     +     '    DERIVATIVE')
 4111 FORMAT
     +    ('                                                     ',
     +     '    ASSESSMENT')
 4112 FORMAT
     +    ('         (K)                  (IFIXB)          (SCLB)',
     +     '              ')
 4120 FORMAT
     +   ('       INDEX         BETA(K)    FIXED           SCALE',
     +     '              ')
 4121 FORMAT
     +    ('                                                     ',
     +     '              ')
 4122 FORMAT
     +    ('         (K)                  (IFIXB)          (SCLB)',
     +     '              ')
 4200 FORMAT
     +   ('       INDEX         BETA(K)    FIXED           SCALE',
     +     '    DERIVATIVE')
 4201 FORMAT
     +    ('                                                     ',
     +     '     STEP SIZE')
 4202 FORMAT
     +    ('         (K)                  (IFIXB)          (SCLB)',
     +     '        (STPB)')
 4310 FORMAT
     +    (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13)
 4320 FORMAT
     +    (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5)
 5110 FORMAT
     +    (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13)
 5120 FORMAT
     +    (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13)
 5210 FORMAT
     +    (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5)
 5220 FORMAT
     +    (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5)
 6000 FORMAT
     +   (' ')
      END
*DODPC2
      SUBROUTINE DODPC2
     +   (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 
     +   PNLTY,
     +   NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA)
C***BEGIN PROLOGUE  DODPC2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  GENERATE ITERATION REPORTS
C***END PROLOGUE  DODPC2

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS
      INTEGER
     +   IPR,LUNRPT,NFEV,NITER,NP
      LOGICAL
     +   FSTITR,IMPLCT,PRTPEN

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   RATIO,ZERO
      INTEGER
     +   J,K,L
      CHARACTER GN*3

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN

C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   BETA:    THE FUNCTION PARAMETERS.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.).
C   GN:      THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON
C            STEP WAS TAKEN.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   RATIO:   THE RATIO OF TAU TO PNORM.
C   TAU:     THE TRUST REGION DIAMETER.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODPC2


      IF (FSTITR) THEN
         IF (IPR.EQ.1) THEN
            IF (IMPLCT) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1121)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2121)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,3121)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,4121)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1122)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2122)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,3122)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,4122)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            END IF
         ELSE
            IF (IMPLCT) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1131)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,2131)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,3131)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,4131)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1132)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF
      END IF
      IF (PRTPEN) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1133) PNLTY
         CALL DPWRST('XXX','BUG')
      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 (ICOUT,1141) NITER,NFEV,WSS,ACTRED,PRERED,
     +                       RATIO,GN
         CALL DPWRST('XXX','BUG')
      ELSE
         J = 1
         K = MIN(3,NP)
         IF (J.EQ.K) THEN
            WRITE (ICOUT,1141) NITER,NFEV,WSS,ACTRED,PRERED,
     +                          RATIO,GN,J,BETA(J)
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,1142) NITER,NFEV,WSS,ACTRED,PRERED,
     +                          RATIO,GN,J,K,(BETA(L),L=J,K)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (NP.GT.3) THEN
            DO 10 J=4,NP,3
               K = MIN(J+2,NP)
               IF (J.EQ.K) THEN
                  WRITE (ICOUT,1151) J,BETA(J)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,1152) J,K,(BETA(L),L=J,K)
                  CALL DPWRST('XXX','BUG')
               END IF
   10       CONTINUE
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1121 FORMAT
     +   (
     +    '         CUM.      PENALTY    ACT. REL.   PRED. REL.')
 2121 FORMAT
     +   (
     +    '  IT.  NO. FN     FUNCTION   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N')
 3121 FORMAT
     +   (
     +    ' NUM.   EVALS        VALUE    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP')
 4121 FORMAT
     +   (
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----')
 1122 FORMAT
     +   (
     +    '         CUM.                 ACT. REL.   PRED. REL.')
 2122 FORMAT
     +   (
     +    '  IT.  NO. FN     WEIGHTED   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N')
 3122 FORMAT
     +   (
     +    ' NUM.   EVALS   SUM-OF-SQS    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP')
 4122 FORMAT
     +   (
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----')
 1131 FORMAT
     +   (
     +    '         CUM.      PENALTY    ACT. REL.   PRED. REL.')
 2131 FORMAT
     +   (
     +    '  IT.  NO. FN     FUNCTION   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N      BETA -------------->')
 3131 FORMAT
     +   (
     +    ' NUM.   EVALS        VALUE    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP     INDEX           VALUE')
 4131 FORMAT
     +   (
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----     -----           -----')
 1132 FORMAT
     +   (
     +    '         CUM.                 ACT. REL.   PRED. REL.')
 2132 FORMAT
     +   (
     +    '  IT.  NO. FN     WEIGHTED   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N      BETA -------------->')
 3132 FORMAT
     +   (
     +    ' NUM.   EVALS   SUM-OF-SQS    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP     INDEX           VALUE')
 4132 FORMAT
     +   (
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----     -----           -----')
 1133 FORMAT
     +   (' PENALTY PARAMETER VALUE = ', 1P,E10.1)
 1141 FORMAT
     +   (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8)
 1142 FORMAT
     +   (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8)
 1151 FORMAT
     +   (76X,I3,1P,D16.8)
 1152 FORMAT
     +   (70X,I3,' TO',I3,1P,3D16.8)
      END
*DODPC3
      SUBROUTINE DODPC3
     +   (IPR,LUNRPT,
     +   ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC,
     +   N,M,NP,NQ,NPP,
     +   INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP,
     +   WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF,
     +   BETA,SDBETA,IFIXB2,F,DELTA)
C***BEGIN PROLOGUE  DODPC3
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPPT
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE FINAL SUMMARY REPORT
C***END PROLOGUE  DODPC3

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS
      INTEGER
     +   IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M,
     +   N,NFEV,NITER,NJEV,NP,NPP,NQ
      LOGICAL
     +   ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP)
      INTEGER
     +   IFIXB2(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TVAL
      INTEGER
     +   D1,D2,D3,D4,D5,I,J,K,L,NPLM1
      CHARACTER FMT1*90

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DPPT
      EXTERNAL
     +   DPPT

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN,MOD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   D1:      THE FIRST DIGIT OF INFO.
C   D2:      THE SECOND DIGIT OF INFO.
C   D3:      THE THIRD DIGIT OF INFO.
C   D4:      THE FOURTH DIGIT OF INFO.
C   D5:      THE FIFTH DIGIT OF INFO.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   F:       THE ESTIMATED VALUES OF EPSILON.
C   FMT1:    A CHARACTER*90 VARIABLE USED FOR FORMATS.
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB2:  THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE 
C            ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK 
C            DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1,
C            0, AND -1, RESPECTIVELY.  IF IFIXB2 IS -2, THEN NO ATTEMPT
C            WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPR:     THE VARIABLE INDICATING WHAT IS TO BE PRINTED.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPLM1:   THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS
C            TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE 
C            MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RVAR:    THE RESIDUAL VARIANCE.
C   SDBETA:  THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS.
C   TVAL:    THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C            T DISTRIBUTION.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   WSSDEL:  THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS.
C   WSSEPS:  THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.


C***FIRST EXECUTABLE STATEMENT  DODPC3


      D1 = INFO/10000
      D2 = MOD(INFO,10000)/1000
      D3 = MOD(INFO,1000)/100
      D4 = MOD(INFO,100)/10
      D5 = MOD(INFO,10)

C  PRINT STOPPING CONDITIONS

      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG')
      IF (INFO.LE.9) THEN
         IF (INFO.EQ.1) THEN
            WRITE (ICOUT,1011) INFO
            CALL DPWRST('XXX','BUG')
         ELSE IF (INFO.EQ.2) THEN
            WRITE (ICOUT,1012) INFO
            CALL DPWRST('XXX','BUG')
         ELSE IF (INFO.EQ.3) THEN
            WRITE (ICOUT,1013) INFO
            CALL DPWRST('XXX','BUG')
         ELSE IF (INFO.EQ.4) THEN
            WRITE (ICOUT,1014) INFO
            CALL DPWRST('XXX','BUG')
         ELSE IF (INFO.LE.9) THEN
            WRITE (ICOUT,1015) INFO
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1016)
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE IF (INFO.LE.9999) THEN

C  PRINT WARNING DIAGNOSTICS

         WRITE (ICOUT,1017) INFO
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1018)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1019)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1020)
         CALL DPWRST('XXX','BUG')
         IF (D2.EQ.1) THEN
            WRITE (ICOUT,1021)
            CALL DPWRST('XXX','BUG')
         ENDIF
         IF (D3.EQ.1) THEN
            WRITE (ICOUT,1022)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1027)
            CALL DPWRST('XXX','BUG')
         ENDIF
         IF (D4.EQ.1) THEN
            WRITE (ICOUT,1023)
            CALL DPWRST('XXX','BUG')
         ENDIF
         IF (D4.EQ.2) THEN
            WRITE (ICOUT,1024)
            CALL DPWRST('XXX','BUG')
         ENDIF
         IF (D5.EQ.1) THEN
            WRITE (ICOUT,1031)
            CALL DPWRST('XXX','BUG')
         ELSE IF (D5.EQ.2) THEN
            WRITE (ICOUT,1032)
            CALL DPWRST('XXX','BUG')
         ELSE IF (D5.EQ.3) THEN
            WRITE (ICOUT,1033)
            CALL DPWRST('XXX','BUG')
         ELSE IF (D5.EQ.4) THEN
            WRITE (ICOUT,1034)
            CALL DPWRST('XXX','BUG')
         ELSE IF (D5.LE.9) THEN
            WRITE (ICOUT,1035) D5
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1036)
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE

C  PRINT ERROR MESSAGES

         WRITE (ICOUT,1039) INFO
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1040)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1041)
         CALL DPWRST('XXX','BUG')
         IF (D1.EQ.5) THEN
            WRITE (ICOUT,1042)
            CALL DPWRST('XXX','BUG')
            IF (D2.NE.0) THEN
               WRITE (ICOUT,1043) D2
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,11043)
               CALL DPWRST('XXX','BUG')
            ENDIF
            IF (D3.EQ.3) THEN
               WRITE (ICOUT,1044) D3
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1047)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1048)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1049)
               CALL DPWRST('XXX','BUG')
            ELSE IF (D3.NE.0) THEN
               WRITE (ICOUT,1045) D3
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,1046)
               CALL DPWRST('XXX','BUG')
            END IF
         ELSE IF (D1.EQ.6) THEN
            WRITE (ICOUT,1050)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1051)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1052)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1053)
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,1060) D1
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1061)
            CALL DPWRST('XXX','BUG')
         END IF
      END IF

C  PRINT MISC. STOPPING INFO

      WRITE (ICOUT,1300) NITER
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1310) NFEV
      CALL DPWRST('XXX','BUG')
      IF (ANAJAC) THEN
         WRITE (ICOUT,1320) NJEV
         CALL DPWRST('XXX','BUG')
      ENDIF
      WRITE (ICOUT,1330) IRANK
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1340) RCOND
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1350) ISTOP
      CALL DPWRST('XXX','BUG')

C  PRINT FINAL SUM OF SQUARES

      IF (IMPLCT) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2000) WSSDEL
         CALL DPWRST('XXX','BUG')
         IF (ISODR) THEN
            WRITE (ICOUT,2010) WSS
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2011) WSSEPS
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2012) PNLTY
            CALL DPWRST('XXX','BUG')
         END IF
      ELSE
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2100) WSS
         CALL DPWRST('XXX','BUG')
         IF (ISODR) THEN
            WRITE (ICOUT,2110) WSSDEL
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,2111) WSSEPS
            CALL DPWRST('XXX','BUG')
         END IF
      END IF
      IF (DIDVCV) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2200) SQRT(RVAR)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2201) IDF
         CALL DPWRST('XXX','BUG')
      END IF

      NPLM1 = 3

C  PRINT ESTIMATED BETA'S, AND,
C  IF, FULL RANK, THEIR STANDARD ERRORS

      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,3000)
      CALL DPWRST('XXX','BUG')
      IF (DIDVCV) THEN
         WRITE (ICOUT,7300)
         CALL DPWRST('XXX','BUG')
         TVAL = DPPT(0.975D0,IDF)
         DO 10 J=1,NP
            IF (IFIXB2(J).GE.1) THEN
               WRITE (ICOUT,8400) J,BETA(J),SDBETA(J),
     +                             BETA(J)-TVAL*SDBETA(J),
     +                             BETA(J)+TVAL*SDBETA(J) 
               CALL DPWRST('XXX','BUG')
            ELSE IF (IFIXB2(J).EQ.0) THEN
               WRITE (ICOUT,8600) J,BETA(J)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,8700) J,BETA(J)
               CALL DPWRST('XXX','BUG')
            END IF
   10    CONTINUE
         IF (.NOT.REDOJ) THEN
            WRITE (ICOUT,7310)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,7311)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,7312)
            CALL DPWRST('XXX','BUG')
         ENDIF
      ELSE
         IF (DOVCV) THEN
            IF (D1.LE.5) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7410)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7411)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7412)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7413)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7414)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7420)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7421)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

         IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR.  NITER.EQ.0) THEN
            IF (NP.EQ.1) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7100)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,7200)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
            END IF
            DO 20 J=1,NP,NPLM1+1
               K = MIN(J+NPLM1,NP)
               IF (K.EQ.J) THEN
                  WRITE (ICOUT,8100) J,BETA(J)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,8200) J,K,(BETA(L),L=J,K)
                  CALL DPWRST('XXX','BUG')
               END IF
   20       CONTINUE
            IF (NITER.GE.1) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,8800)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,8801)
               CALL DPWRST('XXX','BUG')
            ELSE
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,8900)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,8901)
               CALL DPWRST('XXX','BUG')
            END IF
         ELSE
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,7500)
            CALL DPWRST('XXX','BUG')
            DO 30 J=1,NP
               IF (IFIXB2(J).GE.1) THEN
                  WRITE (ICOUT,8500) J,BETA(J)
                  CALL DPWRST('XXX','BUG')
               ELSE IF (IFIXB2(J).EQ.0) THEN
                  WRITE (ICOUT,8600) J,BETA(J)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,8700) J,BETA(J)
                  CALL DPWRST('XXX','BUG')
               END IF
   30       CONTINUE
         END IF
      END IF

      IF (IPR.EQ.1) RETURN


C  PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF
C  COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE.

      IF (IMPLCT .AND. (M.LE.4)) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,4100)
         CALL DPWRST('XXX','BUG')
         WRITE (FMT1,9110) M
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,FMT1) (J,J=1,M)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         DO 40 I=1,N
            WRITE (ICOUT,4130) I,(DELTA(I,J),J=1,M)
            CALL DPWRST('XXX','BUG')
   40    CONTINUE

      ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,4110)
         CALL DPWRST('XXX','BUG')
         WRITE (FMT1,9120) NQ,M
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,FMT1) (L,L=1,NQ),(J,J=1,M)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         DO 50 I=1,N
            WRITE (ICOUT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M)
            CALL DPWRST('XXX','BUG')
   50    CONTINUE

      ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,4120)
         CALL DPWRST('XXX','BUG')
         WRITE (FMT1,9130) NQ
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,FMT1) (L,L=1,NQ)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         DO 60 I=1,N
            WRITE (ICOUT,4130) I,(F(I,L),L=1,NQ)
            CALL DPWRST('XXX','BUG')
   60    CONTINUE
      ELSE

C  PRINT EPSILON'S AND DELTA'S SEPARATELY

         IF (.NOT.IMPLCT) THEN

C  PRINT EPSILON'S

            DO 80 J=1,NQ
               WRITE (ICOUT,4200) J
               CALL DPWRST('XXX','BUG')
               IF (N.EQ.1) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,7100)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,7200)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
               END IF
               DO 70 I=1,N,NPLM1+1
                  K = MIN(I+NPLM1,N)
                  IF (I.EQ.K) THEN
                     WRITE (ICOUT,8100) I,F(I,J)
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,8200) I,K,(F(L,J),L=I,K)
                     CALL DPWRST('XXX','BUG')
                  END IF
   70          CONTINUE
   80       CONTINUE
         END IF

C  PRINT DELTA'S

         IF (ISODR) THEN
            DO 100 J=1,M
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,4300) J
               CALL DPWRST('XXX','BUG')
               IF (N.EQ.1) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,7100)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,7200)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
               END IF
               DO 90 I=1,N,NPLM1+1
                  K = MIN(I+NPLM1,N)
                  IF (I.EQ.K) THEN
                     WRITE (ICOUT,8100) I,DELTA(I,J)
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,8200) I,K,(DELTA(L,J),L=I,K)
                     CALL DPWRST('XXX','BUG')
                  END IF
   90          CONTINUE
  100       CONTINUE
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1000 FORMAT
     + (' --- STOPPING CONDITIONS:')
 1011 FORMAT
     +  ('         INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.')
 1012 FORMAT
     +  ('         INFO = ',I5,' ==> PARAMETER CONVERGENCE.')
 1013 FORMAT
     +  ('         INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND',
     +                        ' PARAMETER CONVERGENCE.')
 1014 FORMAT
     +  ('         INFO = ',I5,' ==> ITERATION LIMIT REACHED.')
 1015 FORMAT
     +  ('         INFO = ',I5,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING')
 1016 FORMAT
     +  ('                           INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1017 FORMAT
     +  ('         INFO = ',I5.4)
 1018 FORMAT
     +  ('              =  ABCD, WHERE A NONZERO VALUE FOR DIGIT A,',
     +                         ' B, OR C INDICATES WHY')
 1019 FORMAT
     +  ('                       THE RESULTS MIGHT BE QUESTIONABLE,',
     +                         ' AND DIGIT D INDICATES')
 1020 FORMAT
     +  ('                       THE ACTUAL STOPPING CONDITION.')
 1021 FORMAT
     +  ('                       A=1 ==> DERIVATIVES ARE',
     +                                 ' QUESTIONABLE.')
 1022 FORMAT
     +  ('                       B=1 ==> USER SET ISTOP TO',
     +                                 ' NONZERO VALUE DURING LAST')
 1027 FORMAT
     +  ('                               CALL TO SUBROUTINE FCN.')
 1023 FORMAT
     +  ('                       C=1 ==> DERIVATIVES ARE NOT',
     +                                 ' FULL RANK AT THE SOLUTION.')
 1024 FORMAT
     +  ('                       C=2 ==> DERIVATIVES ARE ZERO',
     +                                 ' RANK AT THE SOLUTION.')
 1031 FORMAT
     +  ('                       D=1 ==> SUM OF SQUARES CONVERGENCE.')
 1032 FORMAT
     +  ('                       D=2 ==> PARAMETER CONVERGENCE.')
 1033 FORMAT
     +  ('                       D=3 ==> SUM OF SQUARES CONVERGENCE',
     +                                 ' AND PARAMETER CONVERGENCE.')
 1034 FORMAT
     +  ('                       D=4 ==> ITERATION LIMIT REACHED.')
 1035 FORMAT
     +  ('                       D=',I1,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING')
 1036 FORMAT
     +  ('                               INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1039 FORMAT
     +  ('         INFO = ',I5.5)
 1040 FORMAT
     +  ('              = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN',
     +                         ' DIGIT INDICATES AN')
 1041 FORMAT
     +  ('                       ABNORMAL STOPPING CONDITION.')
 1042 FORMAT
     +  ('                       A=5 ==> USER STOPPED COMPUTATIONS',
     +                                 ' IN SUBROUTINE FCN.')
 1043 FORMAT
     +  ('                       B=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED DURING THE')
11043 FORMAT
     +  ('                                    FUNCTION EVALUATION.')
 1044 FORMAT
     +  ('                       C=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED BECAUSE')
 1047 FORMAT
     +  ('                                    DERIVATIVES WITH',
     +                                 ' RESPECT TO DELTA WERE')
 1048 FORMAT
     +  ('                                    COMPUTED BY',
     +                                 ' SUBROUTINE FCN WHEN')
 1049 FORMAT
     +  ('                                    FIT IS OLS.')
 1045 FORMAT
     +  ('                       C=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED DURING THE')
 1046 FORMAT
     +  ('                                    JACOBIAN EVALUATION.')
 1050 FORMAT
     +  ('                       A=6 ==> NUMERICAL INSTABILITIES',
     +                                 ' HAVE BEEN DETECTED,')
 1051 FORMAT
     +  ('                               POSSIBLY INDICATING',
     +                                 ' A DISCONTINUITY IN THE')
 1052 FORMAT
     +  ('                               DERIVATIVES OR A POOR',
     +                                 ' POOR CHOICE OF PROBLEM')
 1053 FORMAT
     +  ('                               SCALE OR WEIGHTS.')
 1060 FORMAT
     +  ('                       A=',I1,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING')
 1061 FORMAT
     +  ('                               INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1300 FORMAT
     +  ('        NITER = ',I5,
     +                    '          (NUMBER OF ITERATIONS)')
 1310 FORMAT
     +  ('         NFEV = ',I5,
     +                    '          (NUMBER OF FUNCTION EVALUATIONS)')
 1320 FORMAT
     +  ('         NJEV = ',I5,
     +                    '          (NUMBER OF JACOBIAN EVALUATIONS)')
 1330 FORMAT
     +  ('        IRANK = ',I5,
     +                    '          (RANK DEFICIENCY)')
 1340 FORMAT
     +  ('        RCOND = ',1P,D12.2,
     +                           '   (INVERSE CONDITION NUMBER)')
*1341 FORMAT
*    +  ('                      ==> POSSIBLY FEWER THAN 2 SIGNIFICANT',
*    +                        ' DIGITS IN RESULTS;'/
*    +   '                          SEE ODRPACK REFERENCE',
*    +                        ' GUIDE, SECTION 4.C.')
 1350 FORMAT
     +  ('        ISTOP = ',I5,
     +                    '          (RETURNED BY USER FROM',
     +                        ' SUBROUTINE FCN)')
 2000 FORMAT
     + (' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ',
     +     17X,1P,D17.8)
 2010 FORMAT
     + ( '         FINAL PENALTY FUNCTION VALUE     = ',1P,D17.8)
 2011 FORMAT
     +  ('               PENALTY TERM               = ',1P,D17.8)
 2012 FORMAT
     +  ('               PENALTY PARAMETER          = ',1P,D10.1)
 2100 FORMAT
     + (' --- FINAL WEIGHTED SUMS OF SQUARES       = ',17X,1P,D17.8)
 2110 FORMAT
     + ( '         SUM OF SQUARED WEIGHTED DELTAS   = ',1P,D17.8)
 2111 FORMAT
     +  ('         SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8)
 2200 FORMAT
     + (' --- RESIDUAL STANDARD DEVIATION          = ',
     +     17X,1P,D17.8)
 2201 FORMAT
     +  ('         DEGREES OF FREEDOM               =',I5)
 3000 FORMAT
     + (' --- ESTIMATED BETA(J), J = 1, ..., NP:')
 4100 FORMAT
     + (' --- ESTIMATED DELTA(I,*), I = 1, ..., N:')
 4110 FORMAT
     + (' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:')
 4120 FORMAT
     + (' --- ESTIMATED EPSILON(I), I = 1, ..., N:')
 4130 FORMAT(5X,I5,1P,5D16.8)
 4200 FORMAT
     + (' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:')
 4300 FORMAT
     + (' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:')
 7100 FORMAT
     + ('           INDEX           VALUE')
 7200 FORMAT
     + ('           INDEX           VALUE -------------->')
 7300 FORMAT
     + ('                     BETA      S.D. BETA',
     +   '    ---- 95%  CONFIDENCE INTERVAL ----')
 7310 FORMAT
     + ('     N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE',
     +                ' COMPUTED USING')
 7311 FORMAT
     +  ('          DERIVATIVES CALCULATED AT THE BEGINNING',
     +                ' OF THE LAST ITERATION,')
 7312 FORMAT
     +  ('          AND NOT USING DERIVATIVES RE-EVALUATED AT THE',
     +                ' FINAL SOLUTION.')
 7410 FORMAT
     + ('     N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE',
     +                ' NOT COMPUTED BECAUSE')
 7411 FORMAT
     +  ('          THE DERIVATIVES WERE NOT AVAILABLE.  EITHER MAXIT',
     +                ' IS 0 AND THE THIRD')
 7412 FORMAT
     +  ('          DIGIT OF JOB IS GREATER THAN 1, OR THE MOST',
     +                ' RECENTLY TRIED VALUES OF')
 7413 FORMAT
     +  ('          BETA AND OR X+DELTA WERE IDENTIFIED AS',
     +                ' UNACCEPTABLE BY USER SUPPLIED')
 7414 FORMAT
     +  ('          SUBROUTINE FCN.')
 7420 FORMAT
     + ('     N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE',
     +                ' NOT COMPUTED.')
 7421 FORMAT
     +  ('          (SEE INFO ABOVE.)')
 7500 FORMAT
     + ('                     BETA         STATUS')
 8100 FORMAT
     +  (11X,I5,1P,D16.8)
 8200 FORMAT
     +  (3X,I5,' TO',I5,1P,7D16.8)
 8400 FORMAT
     +  (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8)
 8500 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'ESTIMATED')
 8600 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'    FIXED')
 8700 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'  DROPPED')
 8800 FORMAT
     + ('     N.B. NO PARAMETERS WERE FIXED BY THE USER OR',
     +                ' DROPPED AT THE LAST')
 8801 FORMAT
     +  ('          ITERATION BECAUSE THEY CAUSED THE MODEL TO BE',
     +                ' RANK DEFICIENT.')
 8900 FORMAT
     + ('     N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER',
     +                ' VALUES BECAUSE')
 8901 FORMAT
     +  ('          MAXIT=0.')
 9110 FORMAT
     +  ('( ''         I'',',
     +   I2,'(''      DELTA(I,'',I1,'')'') )')
 9120 FORMAT
     +  ('( ''         I'',',
     +   I2,'(''    EPSILON(I,'',I1,'')''),',
     +   I2,'(''      DELTA(I,'',I1,'')'') )')
 9130 FORMAT
     +  ('( ''         I'',',
     +   I2,'(''    EPSILON(I,'',I1,'')'') )')

      END
*DODPCR
      SUBROUTINE DODPCR
     +   (IPR,LUNRPT, 
     +   HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +   N,M,NP,NQ,NPP,NNZW,
     +   MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   WSS,RVAR,IDF,SDBETA,
     +   NITER,NFEV,NJEV,ACTRED,PRERED,
     +   TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
C***BEGIN PROLOGUE  DODPCR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE COMPUTATION REPORTS
C***END PROLOGUE  DODPCR

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR,
     +   SSTOL,TAU,TAUFAC
      INTEGER
     +   IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,
     +   LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV,
     +   NITER,NJEV,NNZW,NP,NPP,NQ
      LOGICAL
     +   DIDVCV,FSTITR,HEAD,PRTPEN

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP),
     +   STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   PNLTY
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT
      CHARACTER TYP*3

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFLAG:   THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT
C            (PRTPEN=FALSE).
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RVAR:    THE RESIDUAL VARIANCE.
C   SDBETA:  THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S.
C   SSF:     THE SCALING VALUES FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TT:      THE SCALING VALUES FOR DELTA.
C   TYP:     THE CHARACTER*3 STRING "ODR" OR "OLS".
C   WE:      THE EPSILON WEIGHTS.
C   WD:      THE DELTA WEIGHTS.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODPCR


      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
      PNLTY = ABS(WE(1,1,1))

      IF (HEAD) THEN
         CALL DODPHD(HEAD,LUNRPT)
      END IF
      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF

C  PRINT INITIAL SUMMARY

      IF (IFLAG.EQ.1) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1200) TYP
         CALL DPWRST('XXX','BUG')
         CALL DODPC1
     +      (IPR,LUNRPT,
     +      ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ,
     +      MSGB(1),MSGB(2),MSGD(1),MSGD(2),
     +      N,M,NP,NQ,NPP,NNZW,
     +      X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD,
     +      Y,LDY,WE,LDWE,LD2WE,PNLTY,
     +      BETA,IFIXB,SSF,STPB,
     +      JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +      WSS(1),WSS(2),WSS(3))

C  PRINT ITERATION REPORTS

      ELSE IF (IFLAG.EQ.2) THEN

         IF (FSTITR) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1300) TYP
            CALL DPWRST('XXX','BUG')
         END IF
         CALL DODPC2
     +      (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 
     +      PNLTY,
     +      NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA)

C  PRINT FINAL SUMMARY

      ELSE IF (IFLAG.EQ.3) THEN

         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,1400) TYP
         CALL DPWRST('XXX','BUG')
         CALL DODPC3
     +      (IPR,LUNRPT,
     +      ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC,
     +      N,M,NP,NQ,NPP,
     +      INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP,
     +      WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF,
     +      BETA,SDBETA,IFIXB,F,DELTA)
      END IF

      RETURN

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1200 FORMAT
     +   (' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***')
 1300 FORMAT
     +   (' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***')
 1400 FORMAT
     +   (' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***')

      END
*DODPE1
      SUBROUTINE DODPE1
     +   (UNIT,D1,D2,D3,D4,D5,
     +   N,M,NQ,
     +   LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LWKMN,LIWKMN)
C***BEGIN PROLOGUE  DODPE1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ERROR REPORTS
C***END PROLOGUE  DODPE1

C...SCALAR ARGUMENTS
      INTEGER
     +   D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,
     +   LIWKMN,LWKMN,M,N,NQ,UNIT
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D1:      THE 1ST DIGIT (FROM THE LEFT) OF INFO.
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   D4:      THE 4TH DIGIT (FROM THE LEFT) OF INFO.
C   D5:      THE 5TH DIGIT (FROM THE LEFT) OF INFO.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.


C***FIRST EXECUTABLE STATEMENT  DODPE1


C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION
C  PARAMETERS

      IF (D1.EQ.1) THEN
         IF (D2.NE.0) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE(ICOUT,1100)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (D3.NE.0) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE(ICOUT,1200)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (D4.NE.0) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE(ICOUT,1300)
            CALL DPWRST('XXX','BUG')
            WRITE(ICOUT,1301)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (D5.NE.0) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE(ICOUT,1400)
            CALL DPWRST('XXX','BUG')
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION
C  PARAMETERS

      ELSE IF (D1.EQ.2) THEN

         IF (D2.NE.0) THEN
            IF (D2.EQ.1 .OR. D2.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2110)
               CALL DPWRST('XXX','BUG')
            END IF
            IF (D2.EQ.2 .OR. D2.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2120)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

         IF (D3.NE.0) THEN
            IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2210)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2211)
               CALL DPWRST('XXX','BUG')
            END IF
            IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2220)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2221)
               CALL DPWRST('XXX','BUG')
            END IF
            IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2230)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2231)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

         IF (D4.NE.0) THEN
            IF (D4.EQ.1 .OR. D4.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2310)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2311)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2312)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2313)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2314)
               CALL DPWRST('XXX','BUG')
            END IF
            IF (D4.EQ.2 .OR. D4.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2320)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2321)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

         IF (D5.NE.0) THEN
            IF (D5.EQ.1 .OR. D5.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2410) LWKMN
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2411)
               CALL DPWRST('XXX','BUG')
            END IF
            IF (D5.EQ.2 .OR. D5.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2420) LIWKMN
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,2421)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

      ELSE IF (D1.EQ.3) THEN

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES

         IF (D2.NE.0) THEN
            IF (D2.EQ.1 .OR. D2.EQ.3) THEN
               IF (LDSCLD.GE.N) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3110)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3111)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3112)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3113)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3114)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3115)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3120)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3121)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3122)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3123)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3124)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3125)
                  CALL DPWRST('XXX','BUG')
               END IF
            END IF
            IF (D2.EQ.2 .OR. D2.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3130)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3131)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3132)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES

         IF (D3.NE.0) THEN
            IF (D3.EQ.1 .OR. D3.EQ.3) THEN
               IF (LDSTPD.GE.N) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3210)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3211)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3212)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3213)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3214)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3215)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3220)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3221)
                  CALL DPWRST('XXX','BUG')
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3222)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3223)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3224)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,3225)
                  CALL DPWRST('XXX','BUG')
               END IF
            END IF
            IF (D3.EQ.2 .OR. D3.EQ.3) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3230)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3231)
               CALL DPWRST('XXX','BUG')
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3232)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS

         IF (D4.NE.0) THEN
            IF (D4.EQ.1) THEN
               IF (LDWE.GE.N) THEN
                  IF (LD2WE.GE.NQ) THEN
                     WRITE (ICOUT,999)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3310)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3311)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3312)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3313)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3314)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3315)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3316)
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,999)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3320)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3321)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3322)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3323)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3324)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3325)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3326)
                     CALL DPWRST('XXX','BUG')
                  END IF
               ELSE
                  IF (LD2WE.GE.NQ) THEN
                     WRITE (ICOUT,999)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3410)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3411)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3412)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3413)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3414)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3415)
                     CALL DPWRST('XXX','BUG')
                  ELSE
                     WRITE (ICOUT,999)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3420)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3421)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3422)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3423)
                     CALL DPWRST('XXX','BUG')
                     WRITE(ICOUT,3424)
                     CALL DPWRST('XXX','BUG')
                  END IF
               END IF
            END IF
            IF (D4.EQ.2) THEN
               WRITE (ICOUT,999)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3500)
               CALL DPWRST('XXX','BUG')
               WRITE(ICOUT,3501)
               CALL DPWRST('XXX','BUG')
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS

         IF (D5.NE.0) THEN
            IF (LDWD.GE.N) THEN
               IF (LD2WD.GE.M) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4310)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4311)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4312)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4313)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4314)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4315)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4316)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4320)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4321)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4322)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4323)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4324)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4325)
                  CALL DPWRST('XXX','BUG')
               END IF
            ELSE
               IF (LD2WD.GE.M) THEN
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4410)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4411)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4412)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4413)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4414)
                  CALL DPWRST('XXX','BUG')
               ELSE
                  WRITE (ICOUT,999)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4420)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4421)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4422)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4423)
                  CALL DPWRST('XXX','BUG')
                  WRITE(ICOUT,4424)
                  CALL DPWRST('XXX','BUG')
               END IF
            END IF
         END IF

      END IF

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1100 FORMAT
     +    (' ERROR :  N IS LESS THAN ONE.')
 1200 FORMAT
     +    (' ERROR :  M IS LESS THAN ONE.')
 1300 FORMAT
     +    (' ERROR :  NP IS LESS THAN ONE')
 1301 FORMAT
     +    ('          OR NP IS GREATER THAN N.')
 1400 FORMAT
     +    (' ERROR :  NQ IS LESS THAN ONE.')
 2110 FORMAT
     +    (' ERROR :  LDX IS LESS THAN N.')
 2120 FORMAT
     +    (' ERROR :  LDY IS LESS THAN N.')
 2210 FORMAT
     +    (' ERROR :  LDIFX IS LESS THAN N')
 2211 FORMAT
     +    ('          AND LDIFX IS NOT EQUAL TO ONE.')
 2220 FORMAT
     +    (' ERROR :  LDSCLD IS LESS THAN N')
 2221 FORMAT
     +    ('          AND LDSCLD IS NOT EQUAL TO ONE.')
 2230 FORMAT
     +    (' ERROR :  LDSTPD IS LESS THAN N')
 2231 FORMAT
     +    ('          AND LDSTPD IS NOT EQUAL TO ONE.')
 2310 FORMAT
     +    (' ERROR :  LDWE IS LESS THAN N')
 2311 FORMAT
     +    ('          AND LDWE IS NOT EQUAL TO ONE OR')
 2312 FORMAT
     +    ('          OR')
 2313 FORMAT
     +    ('          LD2WE IS LESS THAN NQ')
 2314 FORMAT
     +    ('          AND LD2WE IS NOT EQUAL TO ONE.')
 2320 FORMAT
     +    (' ERROR :  LDWD IS LESS THAN N')
 2321 FORMAT
     +    ('          AND LDWD IS NOT EQUAL TO ONE.')
 2410 FORMAT
     +    (' ERROR :  LWORK IS LESS THAN ',I7, ',')
 2411 FORMAT
     +    ('          THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.')
 2420 FORMAT
     +    (' ERROR :  LIWORK IS LESS THAN ',I7, ',')
 2421 FORMAT
     +    ('          THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY',
     +              ' IWORK.')
 3110 FORMAT
     +    (' ERROR :  SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO')
 3111 FORMAT
     +    ('          FOR SOME I = 1, ..., N AND J = 1, ..., M.')
 3112 FORMAT
     +    ('          WHEN SCLD(1,1) IS GREATER THAN ZERO')
 3113 FORMAT
     +    ('          AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN')
 3114 FORMAT
     +    ('          EACH OF THE N BY M ELEMENTS OF')
 3115 FORMAT
     +    ('          SCLD MUST BE GREATER THAN ZERO.')
 3120 FORMAT
     +    (' ERROR :  SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO')
 3121 FORMAT
     +    ('          FOR SOME J = 1, ..., M.')
 3122 FORMAT
     +    ('          WHEN SCLD(1,1) IS GREATER THAN ZERO')
 3123 FORMAT
     +    ('          AND LDSCLD IS EQUAL TO ONE THEN')
 3124 FORMAT
     +    ('          EACH OF THE 1 BY M ELEMENTS OF')
 3125 FORMAT
     +    ('          SCLD MUST BE GREATER THAN ZERO.')
 3130 FORMAT
     +    (' ERROR :  SCLB(K) IS LESS THAN OR EQUAL TO ZERO')
 3131 FORMAT
     +    ('          FOR SOME K = 1, ..., NP.')
 3132 FORMAT
     +    ('          ALL NP ELEMENTS OF',
     +              ' SCLB MUST BE GREATER THAN ZERO.')
 3210 FORMAT
     +    (' ERROR :  STPD(I,J) IS LESS THAN OR EQUAL TO ZERO')
 3211 FORMAT
     +    ('          FOR SOME I = 1, ..., N AND J = 1, ..., M.')
 3212 FORMAT
     +    ('          WHEN STPD(1,1) IS GREATER THAN ZERO')
 3213 FORMAT
     +    ('          AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN')
 3214 FORMAT
     +    ('          EACH OF THE N BY M ELEMENTS OF')
 3215 FORMAT
     +    ('          STPD MUST BE GREATER THAN ZERO.')
 3220 FORMAT
     +    (' ERROR :  STPD(1,J) IS LESS THAN OR EQUAL TO ZERO')
 3221 FORMAT
     +    ('          FOR SOME J = 1, ..., M.')
 3222 FORMAT
     +    ('          WHEN STPD(1,1) IS GREATER THAN ZERO')
 3223 FORMAT
     +    ('          AND LDSTPD IS EQUAL TO ONE THEN')
 3224 FORMAT
     +    ('          EACH OF THE 1 BY M ELEMENTS OF')
 3225 FORMAT
     +    ('          STPD MUST BE GREATER THAN ZERO.')
 3230 FORMAT
     +    (' ERROR :  STPB(K) IS LESS THAN OR EQUAL TO ZERO')
 3231 FORMAT
     +    ('          FOR SOME K = 1, ..., NP.')
 3232 FORMAT
     +    ('          ALL NP ELEMENTS OF',
     +              ' STPB MUST BE GREATER THAN ZERO.')
 3310 FORMAT
     +    (' ERROR :  AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING')
 3311 FORMAT
     +    ('          IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE')
 3312 FORMAT
     +    ('          SEMIDEFINITE.  WHEN WE(1,1,1) IS GREATER THAN')
 3313 FORMAT
     +    ('          OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR')
 3314 FORMAT
     +    ('          EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL')
 3315 FORMAT
     +    ('          TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE')
 3316 FORMAT
     +    ('          MUST BE POSITIVE SEMIDEFINITE.')
 3320 FORMAT
     +    (' ERROR :  AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING')
 3321 FORMAT
     +    ('          IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE')
 3322 FORMAT
     +    ('          ELEMENT.  WHEN WE(1,1,1) IS GREATER THAN OR')
 3323 FORMAT
     +    ('          EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL')
 3324 FORMAT
     +    ('          TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE')
 3325 FORMAT
     +    ('          (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-')
 3326 FORMAT
     +    ('          NEGATIVE ELEMENTS.')
 3410 FORMAT
     +    (' ERROR :  THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS')
 3411 FORMAT
     +    ('          NOT POSITIVE SEMIDEFINITE.  WHEN WE(1,1,1) IS')
 3412 FORMAT
     +    ('          GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL')
 3413 FORMAT
     +    ('          TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,')
 3414 FORMAT
     +    ('          THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE')
 3415 FORMAT
     +    ('          SEMIDEFINITE.')
 3420 FORMAT
     +    (' ERROR :  THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS')
 3421 FORMAT
     +    ('          A NEGATIVE ELEMENT.  WHEN WE(1,1,1) IS GREATER')
 3422 FORMAT
     +    ('          THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,')
 3423 FORMAT
     +    ('          AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)')
 3424 FORMAT
     +    ('          ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.')
 3500 FORMAT
     +    (' ERROR :  THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS')
 3501 FORMAT
     +    ('          LESS THAN NP.')
 4310 FORMAT
     +    (' ERROR :  AT LEAST ONE OF THE (M BY M) ARRAYS STARTING')
 4311 FORMAT
     +    ('          IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE')
 4312 FORMAT
     +    ('          DEFINITE.  WHEN WD(1,1,1) IS GREATER THAN ZERO,')
 4313 FORMAT
     +    ('          AND LDWD IS GREATER THAN OR EQUAL TO N, AND')
 4314 FORMAT
     +    ('          LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH')
 4315 FORMAT
     +    ('          OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE')
 4316 FORMAT
     +    ('          DEFINITE.')
 4320 FORMAT
     +    (' ERROR :  AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING')
 4321 FORMAT
     +    ('          IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE')
 4322 FORMAT
     +    ('          ELEMENT.  WHEN WD(1,1,1) IS GREATER THAN ZERO,')
 4323 FORMAT
     +    ('          AND LDWD IS GREATER THAN OR EQUAL TO N, AND')
 4324 FORMAT
     +    ('          LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)')
 4325 FORMAT
     +    ('          ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.')
 4410 FORMAT
     +    (' ERROR :  THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS')
 4411 FORMAT
     +    ('          NOT POSITIVE DEFINITE.  WHEN WD(1,1,1) IS')
 4412 FORMAT
     +    ('          GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND')
 4413 FORMAT
     +    ('          LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE')
 4414 FORMAT
     +    ('          (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.')
 4420 FORMAT
     +    (' ERROR :  THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A')
 4421 FORMAT
     +    ('          NONPOSITIVE ELEMENT.  WHEN WD(1,1,1) IS GREATER')
 4422 FORMAT
     +    ('          THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS')
 4423 FORMAT
     +    ('          EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST')
 4424 FORMAT
     +    ('          HAVE ONLY POSITIVE ELEMENTS.')
      END
*DODPE2
      SUBROUTINE DODPE2
     +   (UNIT,
     +   N,M,NP,NQ,
     +   FJACB,FJACD,
     +   DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD,
     +   XPLUSD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPE2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE THE DERIVATIVE CHECKING REPORT
C***END PROLOGUE  DODPE2

C...SCALAR ARGUMENTS
      INTEGER
     +   M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M)
      INTEGER
     +   MSGB(NQ,NP),MSGD(NQ,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J,K,L
      CHARACTER FLAG*1,TYP*3

C...LOCAL ARRAYS
      LOGICAL
     +   FTNOTE(0:7)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FLAG:    THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS.
C   FTNOTE:  THE ARRAY CONTROLING FOOTNOTES.
C   I:       AN INDEX VARIABLE.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   J:       AN INDEX VARIABLE.
C   K:       AN INDEX VARIABLE.
C   L:       AN INDEX VARIABLE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES.
C   TYP:     THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DODPE2


C  SET UP FOR FOOTNOTES

      DO 10 I=0,7
         FTNOTE(I) = .FALSE.
   10 CONTINUE

      DO 40 L=1,NQ
         IF (MSGB1.GE.1) THEN
            DO 20 I=1,NP
               IF (MSGB(L,I).GE.1) THEN
                  FTNOTE(0) = .TRUE.
                  FTNOTE(MSGB(L,I)) = .TRUE.
               END IF
   20       CONTINUE
         END IF

         IF (MSGD1.GE.1) THEN
            DO 30 I=1,M
               IF (MSGD(L,I).GE.1) THEN
                  FTNOTE(0) = .TRUE.
                  FTNOTE(MSGD(L,I)) = .TRUE.
               END IF
   30       CONTINUE
         END IF
   40 CONTINUE

C     PRINT REPORT 

      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,1000) TYP
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')

      DO 70 L=1,NQ

         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2100) L,NROW
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2200)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2201)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,2202)
         CALL DPWRST('XXX','BUG')

         DO 50 I=1,NP
            K = MSGB(L,I)
            IF (K.GE.7) THEN
               FLAG = '*'
            ELSE
               FLAG = ' '
            END IF
            IF (K.LE.-1) THEN
               WRITE (ICOUT,3100) I
               CALL DPWRST('XXX','BUG')
            ELSE IF (K.EQ.0) THEN
               WRITE (ICOUT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG
               CALL DPWRST('XXX','BUG')
            ELSE IF (K.GE.1) THEN
               WRITE (ICOUT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K
               CALL DPWRST('XXX','BUG')
            END IF
   50    CONTINUE
         IF (ISODR) THEN
            DO 60 I=1,M
               K = MSGD(L,I)
               IF (K.GE.7) THEN
                  FLAG = '*'
               ELSE
                  FLAG = ' '
               END IF
               IF (K.LE.-1) THEN
                  WRITE (ICOUT,4100) NROW,I
                  CALL DPWRST('XXX','BUG')
               ELSE IF (K.EQ.0) THEN
                  WRITE (ICOUT,4200) NROW,I, 
     +                              FJACD(NROW,I,L),DIFF(L,NP+I),FLAG
                  CALL DPWRST('XXX','BUG')
               ELSE IF (K.GE.1) THEN
                  WRITE (ICOUT,4300) NROW,I, 
     +                              FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K
                  CALL DPWRST('XXX','BUG')
               END IF
   60       CONTINUE
         END IF
   70 CONTINUE

C     PRINT FOOTNOTES

      IF (FTNOTE(0)) THEN

         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,5000)
         CALL DPWRST('XXX','BUG')
         IF (FTNOTE(1)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5100)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5101)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(2)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5200)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5201)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5202)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(3)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5300)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5301)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5302)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(4)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5400)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5401)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5402)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5403)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(5)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5500)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5501)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5502)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(6)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5600)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5601)
            CALL DPWRST('XXX','BUG')
         END IF
         IF (FTNOTE(7)) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5700)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5701)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,5702)
            CALL DPWRST('XXX','BUG')
         END IF
      END IF

      IF (NETA.LT.0) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,6000) -NETA
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,6001)
         CALL DPWRST('XXX','BUG')
      ELSE
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,6100) NETA
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,6101)
         CALL DPWRST('XXX','BUG')
      END IF
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,7000)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,7001)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,7002) NTOL
      CALL DPWRST('XXX','BUG')

C  PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED.

      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,8100) NROW
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,8101)
      CALL DPWRST('XXX','BUG')
      WRITE (ICOUT,999)
      CALL DPWRST('XXX','BUG')

      DO 80 J=1,M
         WRITE (ICOUT,8110) NROW,J,XPLUSD(NROW,J)
         CALL DPWRST('XXX','BUG')
   80 CONTINUE

      RETURN

C     FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1000 FORMAT
     +   (' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3,
     +     ' ***')
 2100 FORMAT ('     FOR RESPONSE ',I2,' OF OBSERVATION ', I5)
 2200 FORMAT (
     +        '                      ','         USER',
     +           '               ','                ')
 2201 FORMAT (
     +        '                      ','     SUPPLIED',
     +           '     RELATIVE','    DERIVATIVE ')
 2202 FORMAT (
     +        '        DERIVATIVE WRT','        VALUE',
     +           '   DIFFERENCE','    ASSESSMENT '/)
 3100 FORMAT ('             BETA(',I3,')', '       ---   ',
     +            '       ---   ','    UNCHECKED')
 3200 FORMAT ('             BETA(',I3,')', 1P,2D13.2,3X,A1,
     +           'VERIFIED')
 3300 FORMAT ('             BETA(',I3,')', 1P,2D13.2,3X,A1,
     +           'QUESTIONABLE (SEE NOTE ',I1,')')
 4100 FORMAT ('          DELTA(',I2,',',I2,')', '       ---   ',
     +            '       ---   ','    UNCHECKED')
 4200 FORMAT ('          DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1,
     +           'VERIFIED')
 4300 FORMAT ('          DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1,
     +           'QUESTIONABLE (SEE NOTE ',I1,')')
 5000 FORMAT
     +   ('     NOTES:')
 5100 FORMAT
     +   ('      (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' AGREE, BUT')
 5101 FORMAT
     +    ('          RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.')
 5200 FORMAT
     +   ('      (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' AGREE, BUT')
 5201 FORMAT
     +    ('          RESULTS ARE QUESTIONABLE BECAUSE ONE IS',
     +                   ' IDENTICALLY ZERO')
 5202 FORMAT
     +    ('          AND THE OTHER IS ONLY APPROXIMATELY ZERO.')
 5300 FORMAT
     +   ('      (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT')
 5301 FORMAT
     +    ('          RESULTS ARE QUESTIONABLE BECAUSE ONE IS',
     +                   ' IDENTICALLY ZERO')
 5302 FORMAT
     +    ('          AND THE OTHER IS NOT.')
 5400 FORMAT
     +   ('      (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT')
 5401 FORMAT
     +    ('          FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE',
     +                   ' BECAUSE EITHER')
 5402 FORMAT
     +    ('          THE RATIO OF RELATIVE CURVATURE TO RELATIVE',
     +                   ' SLOPE IS TOO HIGH')
 5403 FORMAT
     +    ('          OR THE SCALE IS WRONG.')
 5500 FORMAT
     +   ('      (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT')
 5501 FORMAT
     +    ('          FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE',
     +                   ' BECAUSE THE')
 5502 FORMAT
     +    ('          RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS',
     +                   ' TOO HIGH.')
 5600 FORMAT
     +   ('      (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES')
 5601 FORMAT
     +   (               ' DISAGREE, BUT',
     +     '          HAVE AT LEAST 2 DIGITS IN COMMON.')
 5700 FORMAT
     +   ('      (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, AND')
 5701 FORMAT
     +    ('          HAVE FEWER THAN 2 DIGITS IN COMMON.  DERIVATIVE',
     +                   ' CHECKING MUST')
 5702 FORMAT
     +    ('          BE TURNED OFF IN ORDER TO PROCEED.')
 6000 FORMAT
     +   ('     NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS       ',
     +        I5)
 6001 FORMAT
     +    ('        (ESTIMATED BY ODRPACK)')
 6100 FORMAT
     +   ('     NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS       ',
     +        I5)
 6101 FORMAT
     +    ('        (SUPPLIED BY USER)')
 7000 FORMAT
     +   ('     NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN      ')
 7001 FORMAT
     +    ('     USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR  ')
 7002 FORMAT
     +    ('     USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED  ',
     +        I5)
 8100 FORMAT
     +   ('     ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED        ',
     +        I5)
 8101 FORMAT
     +    ('       -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW')
 8110 FORMAT
     +   (10X,'X(',I2,',',I2,')',1X,1P,3D16.8)
      END
*DODPE3
      SUBROUTINE DODPE3
     +   (UNIT,D2,D3)
C***BEGIN PROLOGUE  DODPE3
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE
C            STOPPED IN USER SUPPLIED SUBROUTINES FCN
C***END PROLOGUE  DODPE3

C...SCALAR ARGUMENTS
      INTEGER
     +   D2,D3,UNIT
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.


C***FIRST EXECUTABLE STATEMENT  DODPE3


C  PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE
C  STOPPED

      IF (D2.EQ.2) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1100)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1101)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1102)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1103)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1104)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1105)
         CALL DPWRST('XXX','BUG')
      ELSE IF (D2.EQ.3) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1200)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1201)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1202)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1203)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1204)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1205)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1206)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1207)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1208)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1209)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1210)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1211)
         CALL DPWRST('XXX','BUG')
      ELSE IF (D2.EQ.4) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1300)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1301)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1302)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1303)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1304)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1305)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1306)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1307)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1308)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1309)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1310)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1311)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1312)
         CALL DPWRST('XXX','BUG')
      END IF
      IF (D3.EQ.2) THEN
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1400)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1401)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1402)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1403)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1404)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1405)
         CALL DPWRST('XXX','BUG')
      END IF

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1100 FORMAT
     +   (  ' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  ')
 1101 FORMAT
     +     (' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE')
 1102 FORMAT
     +     (' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE     ')
 1103 FORMAT
     +     (' USER.  THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW  ')
 1104 FORMAT
     +     (' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE          ')
 1105 FORMAT
     +     (' REGRESSION PROCEDURE CAN CONTINUE.')
 1200 FORMAT
     +   (  ' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  ')
 1201 FORMAT
     +     (' FROM USER SUPPLIED SUBROUTINE FCN.  THIS OCCURRED DURING')
 1202 FORMAT
     +     (' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE ')
 1203 FORMAT
     +     (' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-')
 1204 FORMAT
     +     (' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),')
 1205 FORMAT
     +     (' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION),  ')
 1206 FORMAT
     +     (' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE')
 1207 FORMAT
     +     (' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT   ')
 1208 FORMAT
     +     (' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED.  THE      ')
 1209 FORMAT
     +     (' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER      ')
 1210 FORMAT
     +     (' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS  ')
 1211 FORMAT
     +     (' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.')
 1300 FORMAT
     +   (  ' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  ')
 1301 FORMAT
     +     (' FROM USER SUPPLIED SUBROUTINE FCN.  THIS OCCURRED DURING')
 1302 FORMAT
     +     (' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT      ')
 1303 FORMAT
     +     (' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS ')
 1304 FORMAT
     +     (' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR   ')
 1305 FORMAT
     +     (' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS             ')
 1306 FORMAT
     +     (' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA   ')
 1307 FORMAT
     +     (' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN       ')
 1308 FORMAT
     +     (' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN,      ')
 1309 FORMAT
     +     (' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED.   ')
 1310 FORMAT
     +     (' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER  ')
 1311 FORMAT
     +     (' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS  ')
 1312 FORMAT
     +     (' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.')
 1400 FORMAT
     +   (  ' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  ')
 1401 FORMAT
     +     (' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR ')
 1402 FORMAT
     +     (' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF ')
 1403 FORMAT
     +     (' BETA AND DELTA SUPPLIED BY THE USER.  THE INITIAL ')
 1404 FORMAT
     +     (' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION ')
 1405 FORMAT
     +     (' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN ')
 1406 FORMAT
     +     (' CONTINUE.')
      END
*DODPER
      SUBROUTINE DODPER
     +   (INFO,LUNERR,SHORT,
     +   N,M,NP,NQ,
     +   LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LWKMN,LIWKMN,
     +   FJACB,FJACD,
     +   DIFF,MSGB,ISODR,MSGD,
     +   XPLUSD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPER
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DODPE1,DODPE2,DODPE3,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS
C***END PROLOGUE  DODPER

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN,
     +   M,N,NETA,NP,NQ,NROW,NTOL
      LOGICAL
     +   ISODR,SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M)
      INTEGER
     +   MSGB(NQ*NP+1),MSGD(NQ*M+1)

C...LOCAL SCALARS
      INTEGER
     +   D1,D2,D3,D4,D5,UNIT
      LOGICAL
     +   HEAD

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODPE1,DODPE2,DODPE3,DODPHD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MOD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D1:      THE 1ST DIGIT (FROM THE LEFT) OF INFO.
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   D4:      THE 4TH DIGIT (FROM THE LEFT) OF INFO.
C   D5:      THE 5TH DIGIT (FROM THE LEFT) OF INFO.
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 
C            (SHORT=.FALSE.).
C   UNIT:    THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   XPLUSD:  THE VALUES X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DODPER


C  SET LOGICAL UNIT NUMBER FOR ERROR REPORT

      IF (LUNERR.EQ.0) THEN
         RETURN
      ELSE IF (LUNERR.LT.0) THEN
         UNIT = 6
      ELSE
         UNIT = LUNERR
      END IF

C  PRINT HEADING

      HEAD = .TRUE.
      CALL DODPHD(HEAD,UNIT)

C  EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO

      D1 = MOD(INFO,100000)/10000
      D2 = MOD(INFO,10000)/1000
      D3 = MOD(INFO,1000)/100
      D4 = MOD(INFO,100)/10
      D5 = MOD(INFO,10)

C  PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP

      IF (D1.GE.1 .AND. D1.LE.3) THEN

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN
C     PROBLEM SPECIFICATION PARAMETERS
C     DIMENSION SPECIFICATION PARAMETERS
C     NUMBER OF GOOD DIGITS IN X
C     WEIGHTS

         CALL DODPE1(UNIT,D1,D2,D3,D4,D5,
     +               N,M,NQ,
     +               LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +               LWKMN,LIWKMN)

      ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN

C  PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING

         CALL DODPE2(UNIT,
     +                N,M,NP,NQ,
     +                FJACB,FJACD,
     +                DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2),
     +                XPLUSD,NROW,NETA,NTOL)

      ELSE IF (D1.EQ.5) THEN

C  PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN

         CALL DODPE3(UNIT,D2,D3)

      END IF

C  PRINT CORRECT FORM OF CALL STATEMENT

      IF ((D1.GE.1 .AND. D1.LE.3) .OR.
     +    (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. 
     +    (D1.EQ.5)) THEN
         IF (SHORT) THEN
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1100)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1101)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1102)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1103)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1104)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1105)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1106)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1107)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1108)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1109)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1110)
            CALL DPWRST('XXX','BUG')
         ELSE
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1200)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,999)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1201)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1202)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1203)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1204)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1205)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1206)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1207)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1208)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1209)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1210)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1211)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1212)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1213)
            CALL DPWRST('XXX','BUG')
            WRITE (ICOUT,1214)
            CALL DPWRST('XXX','BUG')
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1100 FORMAT
     +   (  ' THE CORRECT FORM OF THE CALL STATEMENT IS ')
 1101 FORMAT
     +     ('       CALL DODR')
 1102 FORMAT
     +     ('      +     (FCN,')
 1103 FORMAT
     +     ('      +     N,M,NP,NQ,')
 1104 FORMAT
     +     ('      +     BETA,')
 1105 FORMAT
     +     ('      +     Y,LDY,X,LDX,')
 1106 FORMAT
     +     ('      +     WE,LDWE,LD2WE,WD,LDWD,LD2WD,')
 1107 FORMAT
     +     ('      +     JOB,')
 1108 FORMAT
     +     ('      +     IPRINT,LUNERR,LUNRPT,')
 1109 FORMAT
     +     ('      +     WORK,LWORK,IWORK,LIWORK,')
 1110 FORMAT
     +     ('      +     INFO)')
 1200 FORMAT
     +   (  ' THE CORRECT FORM OF THE CALL STATEMENT IS ')
 1201 FORMAT
     +     ('       CALL DODRC')
 1202 FORMAT
     +     ('      +     (FCN,')
 1203 FORMAT
     +     ('      +     N,M,NP,NQ,')
 1204 FORMAT
     +     ('      +     BETA,')
 1205 FORMAT
     +     ('      +     Y,LDY,X,LDX,')
 1206 FORMAT
     +     ('      +     WE,LDWE,LD2WE,WD,LDWD,LD2WD,')
 1207 FORMAT
     +     ('      +     IFIXB,IFIXX,LDIFX,')
 1208 FORMAT
     +     ('      +     JOB,NDIGIT,TAUFAC,')
 1209 FORMAT
     +     ('      +     SSTOL,PARTOL,MAXIT,')
 1210 FORMAT
     +     ('      +     IPRINT,LUNERR,LUNRPT,')
 1211 FORMAT
     +     ('      +     STPB,STPD,LDSTPD,')
 1212 FORMAT
     +     ('      +     SCLB,SCLD,LDSCLD,')
 1213 FORMAT
     +     ('      +     WORK,LWORK,IWORK,LIWORK,')
 1214 FORMAT
     +     ('      +     INFO)')

      END
*DODPHD
      SUBROUTINE DODPHD
     +   (HEAD,UNIT)
C***BEGIN PROLOGUE  DODPHD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ODRPACK HEADING
C***END PROLOGUE  DODPHD

C...SCALAR ARGUMENTS
      INTEGER
     +   UNIT
      LOGICAL
     +   HEAD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
C   UNIT:    THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN.


C***FIRST EXECUTABLE STATEMENT  DODPHD
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPRDP,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C

      IF (HEAD) THEN
         WRITE(ICOUT,1000)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1001)
         CALL DPWRST('XXX','BUG')
         WRITE(ICOUT,1002)
         CALL DPWRST('XXX','BUG')
         WRITE (ICOUT,999)
         CALL DPWRST('XXX','BUG')
         HEAD = .FALSE.
      END IF

      RETURN

C   FORMAT STATEMENTS

  999 FORMAT(1X)
C
 1000 FORMAT (
     +   ' ******************************************************* ')
 1001 FORMAT (
     +   ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * ')
 1002 FORMAT (
     +   ' ******************************************************* ')
      END
*DODR
      SUBROUTINE DODR
     +   (FCN,
     +   N,M,NP,NQ,
     +   BETA,
     +   Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   JOB,
     +   IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODR
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             MEASUREMENT ERROR MODELS,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           ROGERS, JANET E.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 
C            SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT)
C***DESCRIPTION
C   FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE.
C***REFERENCES  BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND
C                 R. B. SCHNABEL (1989),
C                 "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED 
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 ACM TRANS. MATH. SOFTWARE., 15(4):348-364. 
C               BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND
C                 R. B. SCHNABEL (1992),
C                 "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01,
C                 SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION,"
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 
C                 INTERNAL REPORT NUMBER 92-4834.
C               BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987),
C                 "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078.
C***ROUTINES CALLED  DODCNT
C***END PROLOGUE  DODR

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK,
     +   M,N,NDIGIT,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   NEGONE,PARTOL,SSTOL,TAUFAC,ZERO
      INTEGER
     +   IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT
      LOGICAL
     +   SHORT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1)
      INTEGER
     +   IFIXB(1),IFIXX(1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODCNT

C...DATA STATEMENTS
      DATA
     +   NEGONE,ZERO
     +   /-1.0D0,0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NEGONE:  THE VALUE -1.0D0.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   WD:      THE DELTA WEIGHTS.
C   WD1:     A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODR


C  INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES

      IFIXB(1) = -1
      IFIXX(1,1) = -1
      LDIFX = 1
      NDIGIT = -1
      TAUFAC = NEGONE
      SSTOL = NEGONE
      PARTOL = NEGONE
      MAXIT = -1
      STPB(1) = NEGONE
      STPD(1,1) = NEGONE
      LDSTPD = 1
      SCLB(1) = NEGONE
      SCLD(1,1) = NEGONE
      LDSCLD = 1

      SHORT = .TRUE.

      IF (WD(1,1,1).NE.ZERO) THEN
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO) 
      ELSE
         WD1(1,1,1) = NEGONE
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO) 
      END IF

      RETURN

      END
*DODRC
      SUBROUTINE DODRC
     +   (FCN,
     +   N,M,NP,NQ,
     +   BETA,
     +   Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC,
     +   SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD,
     +   SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODRC
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             MEASUREMENT ERROR MODELS,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           ROGERS, JANET E.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING 
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE  
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST  
C            SQUARES (OLS) SOLUTION (LONG CALL STATEMENT)
C***DESCRIPTION
C   FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE.
C***REFERENCES  BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND
C                 R. B. SCHNABEL (1989),
C                 "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 ACM TRANS. MATH. SOFTWARE., 15(4):348-364.
C               BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND
C                 R. B. SCHNABEL (1992),
C                 "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01,
C                 SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION,"
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 INTERNAL REPORT NUMBER 92-4834.
C               BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987),
C                 "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078.
C***ROUTINES CALLED  DODCNT
C***END PROLOGUE  DODRC

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   NEGONE,ZERO
      LOGICAL
     +   SHORT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   WD1(1,1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODCNT

C...DATA STATEMENTS
      DATA
     +   NEGONE,ZERO
     +   /-1.0D0,0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   WD:      THE DELTA WEIGHTS.
C   WD1:     A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODRC


      SHORT = .FALSE.

      IF (WD(1,1,1).NE.ZERO) THEN
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO)
      ELSE
         WD1(1,1,1) = NEGONE
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO)
      END IF

      RETURN

      END
*DODSTP
      SUBROUTINE DODSTP
     +   (N,M,NP,NQ,NPP,
     +   F,FJACB,FJACD,
     +   WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +   ALPHA,EPSFCN,ISODR,
     +   TFJACB,OMEGA,U,QRAUX,KPVT,
     +   S,T,PHI,IRANK,RCOND,FORVCV,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODSTP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT,
C                    DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA)
C***END PROLOGUE  DODSTP

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA,EPSFCN,PHI,RCOND
      INTEGER
     +   IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP),
     +   T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M),
     +   WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK)
      INTEGER
     +   KPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CO,ONE,SI,TEMP,ZERO
      INTEGER
     +   I,IMAX,INF,IPVT,J,K,K1,K2,KP,L
      LOGICAL
     +   ELIM,FORVCV

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   DUM(2)

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DNRM2
      INTEGER
     +   IDAMAX
      EXTERNAL
     +   DNRM2,IDAMAX

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG,
     +   DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   CO:      THE COSINE FROM THE PLANE ROTATION.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DUM:     A DUMMY ARRAY.
C   ELIM:    THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN 
C            WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT
C            (ELIM=FALSE).
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IMAX:    THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE
C            VALUE.
C   INF:     THE RETURN CODE FROM LINPACK ROUTINES.
C   IPVT:    THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 
C            STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   K1:      AN INDEXING VARIABLE.
C   K2:      AN INDEXING VARIABLE.
C   KP:      THE RANK OF THE JACOBIAN WRT BETA.
C   KPVT:    THE PIVOT VECTOR.
C   L:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   OMEGA:   THE ARRAY DEFINED S.T. 
C            OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD))
C                               = (I-FJACD*INV(P)*TRANS(FJACD)) 
C            WHERE E = D**2 + ALPHA*TT**2
C                  P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   ONE:     THE VALUE 1.0D0.
C   PHI:     THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB.
C   S:       THE STEP FOR BETA.
C   SI:      THE SINE FROM THE PLANE ROTATION.
C   SS:      THE SCALING VALUES FOR THE UNFIXED BETAS.
C   T:       THE STEP FOR DELTA.
C   TEMP:    A TEMPORARY STORAGE LOCATION.
C   TFJACB:  THE ARRAY OMEGA*FJACB.
C   TT:      THE SCALING VALUES FOR DELTA.
C   U:       THE APPROXIMATE NULL VECTOR FOR TFJACB.
C   WD:      THE (SQUARED) DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS, 
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODSTP


C  COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE

C  SET UP KPVT IF ALPHA = 0

      IF (ALPHA.EQ.ZERO) THEN
         KP = NPP
         DO 10 K=1,NP
            KPVT(K) = K
   10    CONTINUE
      ELSE
         IF (NPP.GE.1) THEN
            KP = NPP-IRANK
         ELSE
            KP = NPP
         END IF
      END IF

      IF (ISODR) THEN

C  T = WD * DELTA = D*G2
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N)

         DO 300 I=1,N

C  COMPUTE WRK4, SUCH THAT
C                TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2)
            CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
            CALL DFCTR(.FALSE.,WRK4,M,M,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE OMEGA, SUCH THAT
C                 TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD)
C                 INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD)
            CALL DVEVTR(M,NQ,I,
     +                   FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5)
            DO 110 L=1,NQ
               OMEGA(L,L) = ONE + OMEGA(L,L) 
  110       CONTINUE
            CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD))
C               = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA)
            DO 130 J=1,M
               DO 120 L=1,NQ
                  WRK1(I,L,J) = FJACD(I,J,L)
  120          CONTINUE
               CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4)
               CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2)
  130       CONTINUE

C  COMPUTE WRK5 = INV(E)*D*G2
            DO 140 J=1,M
               WRK5(J) = T(I,J)
  140       CONTINUE
            CALL DSOLVE(M,WRK4,M,WRK5,1,4)
            CALL DSOLVE(M,WRK4,M,WRK5,1,2)

C  COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB
            DO 170 K=1,KP
               DO 150 L=1,NQ
                  TFJACB(I,L,K) = FJACB(I,KPVT(K),L)
  150          CONTINUE
               CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4)
               DO 160 L=1,NQ
                  IF (SS(1).GT.ZERO) THEN
                     TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K))
                  ELSE
                     TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1))
                  END IF
  160          CONTINUE
  170       CONTINUE

C  COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1)
            DO 190 L=1,NQ
               WRK2(I,L) = ZERO
               DO 180 J=1,M
                  WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J)
  180          CONTINUE
               WRK2(I,L) = WRK2(I,L) - F(I,L)
  190       CONTINUE

C  COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1)
            CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4)
  300    CONTINUE

      ELSE
         DO 360 I=1,N
            DO 350 L=1,NQ
               DO 340 K=1,KP
                  TFJACB(I,L,K) = FJACB(I,KPVT(K),L)
                  IF (SS(1).GT.ZERO) THEN
                     TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K))
                  ELSE
                     TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1))
                  END IF
  340          CONTINUE
               WRK2(I,L) = -F(I,L)
  350       CONTINUE
  360    CONTINUE
      END IF

C  COMPUTE S

C  DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0)

      IF (ALPHA.EQ.ZERO) THEN
         IPVT = 1
         DO 410 K=1,NP
            KPVT(K) = 0
  410    CONTINUE
      ELSE
         IPVT = 0
      END IF

      CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT)
      CALL DQRSL(TFJACB,N*NQ,N*NQ,KP,
     +           QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF)
      IF (INF.NE.0) THEN
         ISTOPC = 60000
         RETURN
      END IF

C  ELIMINATE ALPHA PART USING GIVENS ROTATIONS

      IF (ALPHA.NE.ZERO) THEN
         CALL DZERO(NPP,1,S,NPP)
         DO 430 K1=1,KP
            CALL DZERO(KP,1,WRK3,KP)
            WRK3(K1) = SQRT(ALPHA)
            DO 420 K2=K1,KP
               CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI)
               IF (KP-K2.GE.1) THEN
                  CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ,
     +                      WRK3(K2+1),1,CO,SI)
               END IF
               TEMP       =  CO*WRK2(K2,1) + SI*S(KPVT(K1)) 
               S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1))
               WRK2(K2,1)      = TEMP
  420       CONTINUE
  430    CONTINUE
      END IF

C  COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY

      IF (NPP.GE.1) THEN
         IF (ALPHA.EQ.ZERO) THEN
            KP = NPP

C  ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR

  440       CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1)
            IF (RCOND.LE.EPSFCN) THEN
               ELIM = .TRUE.
               IMAX = IDAMAX(KP,U,1)

C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT

               IF (IMAX.NE.KP) THEN
                  CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1,
     +                       QRAUX,WRK3,2)
                  K = KPVT(IMAX)
                  DO 450 I=IMAX,KP-1
                     KPVT(I) = KPVT(I+1)
  450             CONTINUE
                  KPVT(KP) = K
               END IF
               KP = KP-1
            ELSE
               ELIM = .FALSE.
            END IF
            IF (ELIM .AND. KP.GE.1) THEN
               GO TO 440
            ELSE
               IRANK = NPP-KP
            END IF
         END IF
      END IF

      IF (FORVCV) RETURN

C  BACKSOLVE AND UNSCRAMBLE

      IF (NPP.GE.1) THEN
         DO 510 I=KP+1,NPP
            WRK2(I,1) = ZERO
  510    CONTINUE
         IF (KP.GE.1) THEN
            CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF
         END IF
         DO 520 I=1,NPP
            IF (SS(1).GT.ZERO) THEN
               S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I))
            ELSE
               S(KPVT(I)) = WRK2(I,1)/ABS(SS(1))
            END IF
  520    CONTINUE
      END IF

      IF (ISODR) THEN

C  NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE,
C        WHERE T    = WD * DELTA = D*G2
C              WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD))

         DO 670 I=1,N

C  COMPUTE WRK4, SUCH THAT
C                TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2)
            CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
            CALL DFCTR(.FALSE.,WRK4,M,M,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE WRK5 = INV(E)*D*G2
            DO 610 J=1,M
               WRK5(J) = T(I,J)
  610       CONTINUE
            CALL DSOLVE(M,WRK4,M,WRK5,1,4)
            CALL DSOLVE(M,WRK4,M,WRK5,1,2)

            DO 640 L=1,NQ
               WRK2(I,L) = F(I,L) 
               DO 620 K=1,NPP
                  WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K)
  620          CONTINUE
               DO 630 J=1,M
                  WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J)
  630          CONTINUE
  640       CONTINUE

            DO 660 J=1,M
               WRK5(J) = ZERO
               DO 650 L=1,NQ
                  WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L)
  650          CONTINUE
               T(I,J) = -(WRK5(J) + T(I,J))
  660       CONTINUE
            CALL DSOLVE(M,WRK4,M,T(I,1),N,4)
            CALL DSOLVE(M,WRK4,M,T(I,1),N,2)
  670    CONTINUE

      END IF

C  COMPUTE PHI(ALPHA) FROM SCALED S AND T

      CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
      IF (ISODR) THEN
         CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
         PHI = DNRM2(NPP+N*M,WRK,1)
      ELSE
         PHI = DNRM2(NPP,WRK,1)
      END IF

      RETURN
      END
*DODVCV
      SUBROUTINE DODVCV
     +   (N,M,NP,NQ,NPP,
     +    F,FJACB,FJACD,
     +    WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA,
     +    EPSFCN,ISODR,
     +    VCV,SD,
     +    WRK6,OMEGA,U,QRAUX,JPVT,
     +    S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB,
     +    WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODVCV
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPODI,DODSTP
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C***END PROLOGUE  DODVCV

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSFCN,RCOND,RSS,RVAR
      INTEGER
     +   IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
      LOGICAL 
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),
     +   FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP),
     +   T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M),
     +   WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),
     +   WRK6(N*NQ,NP),WRK(LWRK)
      INTEGER
     +   IFIXB(NP),JPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   I,IUNFIX,J,JUNFIX,KP,L
      LOGICAL
     +   FORVCV

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPODI,DODSTP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMAX:    THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE
C            VALUE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP.
C   IUNFIX:  THE INDEX OF THE NEXT UNFIXED PARAMETER.
C   J:       AN INDEXING VARIABLE.
C   JPVT:    THE PIVOT VECTOR.
C   JUNFIX:  THE INDEX OF THE NEXT UNFIXED PARAMETER.
C   KP:      THE RANK OF THE JACOBIAN WRT BETA.
C   L:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OMEGA:   THE ARRAY DEFINED S.T.
C            OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD))
C                               = (I-FJACD*INV(P)*TRANS(FJACD))
C            WHERE E = D**2 + ALPHA*TT**2
C                  P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   RSS:     THE RESIDUAL SUM OF SQUARES.
C   RVAR:    THE RESIDUAL VARIANCE.
C   S:       THE STEP FOR BETA.
C   SD:      THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS.
C   SS:      THE SCALING VALUES FOR THE UNFIXED BETAS.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   T:       THE STEP FOR DELTA.
C   TEMP:    A TEMPORARY STORAGE LOCATION
C   TT:      THE SCALING VALUES FOR DELTA.
C   U:       THE APPROXIMATE NULL VECTOR FOR FJACB.
C   VCV:     THE COVARIANCE MATRIX OF THE ESTIMATED BETAS.
C   WD:      THE DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS,
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N*NQ BY P) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODVCV


      FORVCV = .TRUE.
      ISTOPC = 0

      CALL DODSTP(N,M,NP,NQ,NPP,
     +            F,FJACB,FJACD,
     +            WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +            ZERO,EPSFCN,ISODR,
     +            WRK6,OMEGA,U,QRAUX,JPVT,
     +            S,T,TEMP,IRANK,RCOND,FORVCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
      IF (ISTOPC.NE.0) THEN
         RETURN
      END IF
      KP = NPP - IRANK
      CALL DPODI (WRK6,N*NQ,KP,WRK3,1)

      IDF = 0
      DO 150 I=1,N
         DO 120 J=1,NPP
            DO 110 L=1,NQ
               IF (FJACB(I,J,L).NE.ZERO) THEN
                  IDF = IDF + 1
                  GO TO 150
               END IF
  110       CONTINUE
  120    CONTINUE
         IF (ISODR) THEN
            DO 140 J=1,M
               DO 130 L=1,NQ
                  IF (FJACD(I,J,L).NE.ZERO) THEN
                     IDF = IDF + 1
                     GO TO 150
                  END IF
  130          CONTINUE
  140       CONTINUE
         END IF
  150 CONTINUE

      IF (IDF.GT.KP) THEN
         IDF = IDF - KP
         RVAR = RSS/IDF
      ELSE
         IDF = 0
         RVAR = RSS
      END IF

C  STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER

      DO 200 I=1,NP
         SD(I) = ZERO
  200 CONTINUE
      DO 210 I=1,KP
         SD(JPVT(I)) = WRK6(I,I)
  210 CONTINUE
      IF (NP.GT.NPP) THEN
         JUNFIX = NPP
         DO 220 J=NP,1,-1
            IF (IFIXB(J).EQ.0) THEN
               SD(J) = ZERO
            ELSE
               SD(J) = SD(JUNFIX)
               JUNFIX = JUNFIX - 1
            END IF
  220    CONTINUE
      END IF

C  STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER

      DO 310 I=1,NP
         DO 300 J=1,I
            VCV(I,J) = ZERO
  300    CONTINUE
  310 CONTINUE
      DO 330 I=1,KP
         DO 320 J=I+1,KP
            IF (JPVT(I).GT.JPVT(J)) THEN
               VCV(JPVT(I),JPVT(J))=WRK6(I,J)
            ELSE
               VCV(JPVT(J),JPVT(I))=WRK6(I,J)
            END IF
  320    CONTINUE
  330 CONTINUE
      IF (NP.GT.NPP) THEN
         IUNFIX = NPP
         DO 360 I=NP,1,-1
            IF (IFIXB(I).EQ.0) THEN
               DO 340 J=I,1,-1
                  VCV(I,J) = ZERO
  340          CONTINUE
            ELSE
               JUNFIX = NPP
               DO 350 J=NP,1,-1
                  IF (IFIXB(J).EQ.0) THEN
                     VCV(I,J) = ZERO
                  ELSE
                     VCV(I,J) = VCV(IUNFIX,JUNFIX)
                     JUNFIX = JUNFIX - 1
                  END IF
  350          CONTINUE
               IUNFIX = IUNFIX - 1
            END IF
  360    CONTINUE
      END IF

      DO 380 I=1,NP
         VCV(I,I) = SD(I)
         SD(I) = SQRT(RVAR*SD(I))
         DO 370 J=1,I
            VCV(J,I) = VCV(I,J)
  370    CONTINUE
  380 CONTINUE

C  UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX
      DO 410 I=1,NP
         IF (SSF(1).GT.ZERO) THEN
            SD(I) = SD(I)/SSF(I)
         ELSE
            SD(I) = SD(I)/ABS(SSF(1))
         END IF
         DO 400 J=1,NP
            IF (SSF(1).GT.ZERO) THEN
               VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J))
            ELSE
               VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1))
            END IF
  400    CONTINUE
  410 CONTINUE

      RETURN
      END
*DPACK
      SUBROUTINE DPACK
     +   (N2,N1,V1,V2,IFIX)
C***BEGIN PROLOGUE  DPACK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DCOPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1
C***END PROLOGUE  DPACK

C...SCALAR ARGUMENTS
      INTEGER
     +   N1,N2

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V1(N2),V2(N2)
      INTEGER
     +   IFIX(N2)

C...LOCAL SCALARS
      INTEGER
     +   I

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   N1:      THE NUMBER OF ITEMS IN V1.
C   N2:      THE NUMBER OF ITEMS IN V2.
C   V1:      THE VECTOR OF THE UNFIXED ITEMS FROM V2.
C   V2:      THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE
C            UNFIXED ELEMENTS ARE TO BE EXTRACTED.


C***FIRST EXECUTABLE STATEMENT  DPACK


      N1 = 0
      IF (IFIX(1).GE.0) THEN
         DO 10 I=1,N2
            IF (IFIX(I).NE.0) THEN
               N1 = N1+1
               V1(N1) = V2(I)
            END IF
   10    CONTINUE
      ELSE
         N1 = N2
         CALL DCOPY(N2,V2,1,V1,1)
      END IF

      RETURN
      END
*DPPNML
      DOUBLE PRECISION FUNCTION DPPNML
     +   (P)
C***BEGIN PROLOGUE  DPPNML
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***AUTHOR  FILLIBEN, JAMES J.,
C             STATISTICAL ENGINEERING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, D. C. 20234
C             (ORIGINAL VERSION--JUNE      1972.
C             (UPDATED         --SEPTEMBER 1975, 
C                                NOVEMBER  1975, AND
C                                OCTOBER   1976.
C***PURPOSE  COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE
C            NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD
C            DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION
C            F(X) = (1/SQRT(2*PI))*EXP(-X*X/2).
C            (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS
C            TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY)
C***DESCRIPTION
C               --THE CODING AS PRESENTED BELOW IS ESSENTIALLY 
C                 IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS
C                 AS ALGORTIHM 70 OF APPLIED STATISTICS.
C               --AS POINTED OUT BY ODEH AND EVANS IN APPLIED 
C                 STATISTICS, THEIR ALGORITHM REPRESENTES A
C                 SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED
C                 HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT 
C                 FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4)
C                 TO 1.5*(10**-8).
C***REFERENCES  ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL 
C                 DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, 
C                 PAGES 96-97.
C               EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND 
C                 RATIONAL APPROXIMATION, M. SC. THESIS, 1972, 
C                 UNIVERSITY OF VICTORIA, B. C., CANADA.
C               HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, 
C                 PAGES 113, 191, 192.
C               NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 933, FORMULA 26.2.23.
C               FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE 
C                 LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION 
C                 (UNPUBLISHED PH.D. DISSERTATION, PRINCETON 
C                 UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               FILLIBEN, "THE PERCENT POINT FUNCTION",
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS,
C                 VOLUME 1, 1970, PAGES 40-111.
C               KELLEY STATISTICAL TABLES, 1948.
C               OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16.
C               PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR 
C                 STATISTICIANS, VOLUME 1, 1954, PAGES 104-113.
C***END PROLOGUE  DPPNML

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC 
     +   LOG,SQRT

C...DATA STATEMENTS
      DATA 
     +   P0,P1,P2,P3,P4
     +   /-0.322232431088D0,-1.0D0,-0.342242088547D0,
     +    -0.204231210245D-1,-0.453642210148D-4/ 
      DATA 
     +   Q0,Q1,Q2,Q3,Q4
     +   /0.993484626060D-1,0.588581570495D0, 
     +    0.531103462366D0,0.103537752850D0,0.38560700634D-2/ 
      DATA 
     +   ZERO,HALF,ONE,TWO
     +   /0.0D0,0.5D0,1.0D0,2.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ADEN:    A VALUE USED IN THE APPROXIMATION.
C   ANUM:    A VALUE USED IN THE APPROXIMATION.
C   HALF:    THE VALUE 0.5D0.
C   ONE:     THE VALUE 1.0D0.
C   P:       THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE 
C            EVALUATED.  P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. 
C   P0:      A PARAMETER USED IN THE APPROXIMATION.
C   P1:      A PARAMETER USED IN THE APPROXIMATION.
C   P2:      A PARAMETER USED IN THE APPROXIMATION.
C   P3:      A PARAMETER USED IN THE APPROXIMATION.
C   P4:      A PARAMETER USED IN THE APPROXIMATION.
C   Q0:      A PARAMETER USED IN THE APPROXIMATION.
C   Q1:      A PARAMETER USED IN THE APPROXIMATION.
C   Q2:      A PARAMETER USED IN THE APPROXIMATION.
C   Q3:      A PARAMETER USED IN THE APPROXIMATION.
C   Q4:      A PARAMETER USED IN THE APPROXIMATION.
C   R:       THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED.
C   T:       A VALUE USED IN THE APPROXIMATION.
C   TWO:     THE VALUE 2.0D0.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DPPT


      IF (P.EQ.HALF) THEN
         DPPNML = ZERO

      ELSE
         R = P
         IF (P.GT.HALF) R = ONE - R 
         T = SQRT(-TWO*LOG(R)) 
         ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0)
         ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0)
         DPPNML = T + (ANUM/ADEN)

         IF (P.LT.HALF) DPPNML = -DPPNML
      END IF

      RETURN

      END
*DPPT
      DOUBLE PRECISION FUNCTION DPPT
     +   (P, IDF)
C***BEGIN PROLOGUE  DPPT
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPPNML
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***AUTHOR  FILLIBEN, JAMES J.,
C             STATISTICAL ENGINEERING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, D. C. 20234
C             (ORIGINAL VERSION--OCTOBER   1975.)
C             (UPDATED         --NOVEMBER  1975.)
C***PURPOSE  COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE
C            STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM.
C            (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS
C            TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY)
C***DESCRIPTION
C              --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION
C                FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM
C                AND SO THE COMPUTED PERCENT POINTS ARE EXACT.
C              --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION
C                IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO
C                IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1.
C***REFERENCES  NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 949, FORMULA 26.7.5.
C               JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS,
C                 VOLUME 2, 1970, PAGE 102, FORMULA 11.
C               FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS
C                 OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN
C                 STATISTICAL ASSOCIATION, 1969, PAGES 683-688.
C               HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A
C                 HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 120-123.
C***END PROLOGUE  DPPT

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P
      INTEGER
     +   IDF

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45,
     +   B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN,
     +   HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO,
     +   Z,ZERO
      INTEGER
     +   IPASS,MAXIT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DPPNML
      EXTERNAL 
     +   DPPNML

C...INTRINSIC FUNCTIONS
      INTRINSIC 
     +   ATAN,COS,SIN,SQRT

C...DATA STATEMENTS
      DATA 
     +   B21 
     +   /4.0D0/
      DATA 
     +   B31, B32, B33, B34 
     +   /96.0D0,5.0D0,16.0D0,3.0D0/
      DATA 
     +   B41, B42, B43, B44, B45
     +  /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ 
      DATA 
     +   B51,B52,B53,B54,B55,B56
     +   /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ 
      DATA 
     +   ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN
     +   /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ARG:    A VALUE USED IN THE APPROXIMATION.
C   B21:    A PARAMETER USED IN THE APPROXIMATION.
C   B31:    A PARAMETER USED IN THE APPROXIMATION.
C   B32:    A PARAMETER USED IN THE APPROXIMATION.
C   B33:    A PARAMETER USED IN THE APPROXIMATION.
C   B34:    A PARAMETER USED IN THE APPROXIMATION.
C   B41:    A PARAMETER USED IN THE APPROXIMATION.
C   B42:    A PARAMETER USED IN THE APPROXIMATION.
C   B43:    A PARAMETER USED IN THE APPROXIMATION.
C   B44:    A PARAMETER USED IN THE APPROXIMATION.
C   B45:    A PARAMETER USED IN THE APPROXIMATION.
C   B51:    A PARAMETER USED IN THE APPROXIMATION.
C   B52:    A PARAMETER USED IN THE APPROXIMATION.
C   B53:    A PARAMETER USED IN THE APPROXIMATION.
C   B54:    A PARAMETER USED IN THE APPROXIMATION.
C   B55:    A PARAMETER USED IN THE APPROXIMATION.
C   B56:    A PARAMETER USED IN THE APPROXIMATION.
C   C:      A VALUE USED IN THE APPROXIMATION.
C   CON:    A VALUE USED IN THE APPROXIMATION.
C   DF:     THE DEGREES OF FREEDOM.
C   D1:     A VALUE USED IN THE APPROXIMATION.
C   D3:     A VALUE USED IN THE APPROXIMATION.
C   D5:     A VALUE USED IN THE APPROXIMATION.
C   D7:     A VALUE USED IN THE APPROXIMATION.
C   D9:     A VALUE USED IN THE APPROXIMATION.
C   EIGHT:  THE VALUE 8.0D0.
C   FIFTN:  THE VALUE 15.0D0.
C   HALF:   THE VALUE 0.5D0.
C   IDF:    THE (POSITIVE INTEGER) DEGREES OF FREEDOM.
C   IPASS:  A VALUE USED IN THE APPROXIMATION.
C   MAXIT:  THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX.
C   ONE:    THE VALUE 1.0D0.
C   P:      THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE
C           EVALUATED.  P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE.
C   PI:     THE VALUE OF PI.
C   PPFN:   THE NORMAL PERCENT POINT VALUE.
C   S:      A VALUE USED IN THE APPROXIMATION.
C   TERM1:  A VALUE USED IN THE APPROXIMATION.
C   TERM2:  A VALUE USED IN THE APPROXIMATION.
C   TERM3:  A VALUE USED IN THE APPROXIMATION.
C   TERM4:  A VALUE USED IN THE APPROXIMATION.
C   TERM5:  A VALUE USED IN THE APPROXIMATION.
C   THREE:  THE VALUE 3.0D0.
C   TWO:    THE VALUE 2.0D0.
C   Z:      A VALUE USED IN THE APPROXIMATION.
C   ZERO:   THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DPPT


      PI = 3.141592653589793238462643383279D0
      DF = IDF
      MAXIT = 5

      IF (IDF.LE.0) THEN

C  TREAT THE IDF < 1 CASE
         DPPT = ZERO

      ELSE IF (IDF.EQ.1) THEN

C  TREAT THE IDF = 1 (CAUCHY) CASE
         ARG = PI*P
         DPPT = -COS(ARG)/SIN(ARG)

      ELSE IF (IDF.EQ.2) THEN

C  TREAT THE IDF = 2 CASE
         TERM1 = SQRT(TWO)/TWO
         TERM2 = TWO*P - ONE
         TERM3 = SQRT(P*(ONE-P)) 
         DPPT = TERM1*TERM2/TERM3

      ELSE IF (IDF.GE.3) THEN

C  TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE
         PPFN = DPPNML(P)
         D1 = PPFN
         D3 = PPFN**3
         D5 = PPFN**5
         D7 = PPFN**7
         D9 = PPFN**9
         TERM1 = D1
         TERM2 = (ONE/B21)*(D3+D1)/DF
         TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2)
         TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) 
         TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4)
         DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5

         IF (IDF.EQ.3) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 3 CASE
            CON = PI*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 70 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - (Z+S*C-CON)/(TWO*C**2)
   70       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.4) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 4 CASE
            CON = TWO*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 90 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3)
   90       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.5) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 5 CASE

            CON = PI*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 110 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/
     +                 ((EIGHT/THREE)*C**4) 
  110       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.6) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 6 CASE
            CON = TWO*(P-HALF) 
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 130 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/
     +                 ((FIFTN/EIGHT)*C**5)
  130       CONTINUE
            DPPT = SQRT(DF)*S/C
         END IF
      END IF

      RETURN

      END
*DPVB
      SUBROUTINE DPVB
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,J,LQ,STP,
     +    ISTOP,NFEV,PVB,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DPVB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP
C***END PROLOGUE  DPVB

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PVB,STP
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAJ

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAJ:   THE CURRENT ESTIMATE OF THE JTH PARAMETER.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   PVB:     THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DPVB


C  COMPUTE PREDICTED VALUES

      BETAJ = BETA(J)
      BETA(J) = BETA(J) + STP
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         003,WRK2,WRK6,WRK1,
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      ELSE
         RETURN
      END IF
      BETA(J) = BETAJ

      PVB = WRK2(NROW,LQ)

      RETURN
      END
*DPVD
      SUBROUTINE DPVD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,J,LQ,STP,
     +    ISTOP,NFEV,PVD,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DPVD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE NROW-TH FUNCTION VALUE USING
C            X(NROW,J) + DELTA(NROW,J) + STP
C***END PROLOGUE  DPVD

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PVD,STP
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   XPDJ

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   PVD:     THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   XPDJ:    THE (NROW,J)TH ELEMENT OF XPLUSD.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DPVD


C  COMPUTE PREDICTED VALUES

      XPDJ = XPLUSD(NROW,J)
      XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         003,WRK2,WRK6,WRK1,
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      ELSE
         RETURN
      END IF
      XPLUSD(NROW,J) = XPDJ

      PVD = WRK2(NROW,LQ)

      RETURN
      END
*DSCALE
      SUBROUTINE DSCALE
     +   (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT)
C***BEGIN PROLOGUE  DSCALE
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL
C***END PROLOGUE  DSCALE

C...SCALAR ARGUMENTS
      INTEGER
     +   LDT,LDSCL,LDSCLT,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,TEMP,ZERO
      INTEGER
     +   I,J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ONE,ZERO
     +   /1.0D0,0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDSCL:   THE LEADING DIMENSION OF ARRAY SCL.
C   LDSCLT:  THE LEADING DIMENSION OF ARRAY SCLT.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   M:       THE NUMBER OF COLUMNS OF DATA IN T.
C   N:       THE NUMBER OF ROWS OF DATA IN T.
C   ONE:     THE VALUE 1.0D0.
C   SCL:     THE SCALE VALUES.
C   SCLT:    THE INVERSELY SCALED MATRIX.
C   T:       THE ARRAY TO BE INVERSELY SCALED BY SCL.
C   TEMP:    A TEMPORARY SCALAR.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCALE


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (SCL(1,1).GE.ZERO) THEN
         IF (LDSCL.GE.N) THEN
            DO 80 J=1,M
               DO 70 I=1,N
                  SCLT(I,J) = T(I,J)/SCL(I,J)
   70          CONTINUE
   80       CONTINUE
         ELSE
            DO 100 J=1,M
               TEMP = ONE/SCL(1,J)
               DO 90 I=1,N
                  SCLT(I,J) = T(I,J)*TEMP
   90          CONTINUE
  100       CONTINUE
         END IF
      ELSE
         TEMP = ONE/ABS(SCL(1,1))
         DO 120 J=1,M
            DO 110 I=1,N
               SCLT(I,J) = T(I,J)*TEMP
  110       CONTINUE
  120    CONTINUE
      END IF

      RETURN
      END
*DSCLB
      SUBROUTINE DSCLB
     +   (NP,BETA,SSF)
C***BEGIN PROLOGUE  DSCLB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT SCALING VALUES FOR BETA ACCORDING TO THE
C            ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE
C***END PROLOGUE  DSCLB

C...SCALAR ARGUMENTS
      INTEGER
     +   NP

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SSF(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BMAX,BMIN,ONE,TEN,ZERO
      INTEGER
     +   K
      LOGICAL
     +   BIGDIF

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,LOG10,MAX,MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TEN
     +   /0.0D0,1.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BIGDIF:  THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 
C            DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF
C            BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
C   BMAX:    THE LARGEST NONZERO MAGNITUDE.
C   BMIN:    THE SMALLEST NONZERO MAGNITUDE.
C   K:       AN INDEXING VARIABLE.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SSF:     THE SCALING VALUES FOR BETA.
C   TEN:     THE VALUE 10.0D0.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCLB


      BMAX = ABS(BETA(1))
      DO 10 K=2,NP
         BMAX = MAX(BMAX,ABS(BETA(K)))
   10 CONTINUE

      IF (BMAX.EQ.ZERO) THEN

C  ALL INPUT VALUES OF BETA ARE ZERO

         DO 20 K=1,NP
            SSF(K) = ONE
   20    CONTINUE

      ELSE

C  SOME OF THE INPUT VALUES ARE NONZERO

         BMIN = BMAX
         DO 30 K=1,NP
            IF (BETA(K).NE.ZERO) THEN
               BMIN = MIN(BMIN,ABS(BETA(K)))
            END IF
   30    CONTINUE
         BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE
         DO 40 K=1,NP
            IF (BETA(K).EQ.ZERO) THEN
               SSF(K) =  TEN/BMIN
            ELSE
               IF (BIGDIF) THEN
                  SSF(K) = ONE/ABS(BETA(K))
               ELSE
                  SSF(K) = ONE/BMAX
               END IF
            END IF
   40    CONTINUE

      END IF

      RETURN
      END
*DSCLD
      SUBROUTINE DSCLD
     +   (N,M,X,LDX,TT,LDTT)
C***BEGIN PROLOGUE  DSCLD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT SCALING VALUES FOR DELTA ACCORDING TO THE 
C            ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE
C***END PROLOGUE  DSCLD

C...SCALAR ARGUMENTS
      INTEGER
     +   LDTT,LDX,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   TT(LDTT,M),X(LDX,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,TEN,XMAX,XMIN,ZERO
      INTEGER
     +   I,J
      LOGICAL
     +   BIGDIF

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,LOG10,MAX,MIN

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TEN
     +   /0.0D0,1.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BIGDIF:  THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 
C            DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF
C            X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   ONE:     THE VALUE 1.0D0.
C   TT:      THE SCALING VALUES FOR DELTA.
C   X:       THE INDEPENDENT VARIABLE.
C   XMAX:    THE LARGEST NONZERO MAGNITUDE.
C   XMIN:    THE SMALLEST NONZERO MAGNITUDE.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCLD


      DO 50 J=1,M
         XMAX = ABS(X(1,J))
         DO 10 I=2,N
            XMAX = MAX(XMAX,ABS(X(I,J)))
   10    CONTINUE

         IF (XMAX.EQ.ZERO) THEN

C  ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO

            DO 20 I=1,N
               TT(I,J) = ONE
   20       CONTINUE

         ELSE

C  SOME OF THE INPUT VALUES ARE NONZERO

            XMIN = XMAX
            DO 30 I=1,N
               IF (X(I,J).NE.ZERO) THEN
                  XMIN = MIN(XMIN,ABS(X(I,J)))
               END IF
   30       CONTINUE
            BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE
            DO 40 I=1,N
               IF (X(I,J).NE.ZERO) THEN
                  IF (BIGDIF) THEN
                     TT(I,J) = ONE/ABS(X(I,J))
                  ELSE
                     TT(I,J) = ONE/XMAX
                  END IF
               ELSE
                  TT(I,J) = TEN/XMIN
               END IF
   40       CONTINUE
         END IF
   50 CONTINUE

      RETURN
      END
*DSETN
      SUBROUTINE DSETN
     +   (N,M,X,LDX,NROW)
C***BEGIN PROLOGUE  DSETN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED
C***END PROLOGUE  DSETN

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,M,N,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEX VARIABLE.
C   J:       AN INDEX VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NROW:    THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE.
C   X:       THE INDEPENDENT VARIABLE.


C***FIRST EXECUTABLE STATEMENT  DSETN


      IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN

C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C     IF THERE IS ONE, OTHERWISE FIRST ROW IS USED.

      DO 20 I = 1, N
         DO 10 J = 1, M
            IF (X(I,J).EQ.0.0) GO TO 20
   10    CONTINUE
         NROW = I
         RETURN
   20 CONTINUE

      NROW = 1

      RETURN
      END
*DSOLVE
      SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB)
C***BEGIN PROLOGUE  DSOLVE
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  DAXPY,DDOT
C***DATE WRITTEN   920220   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  SOLVE SYSTEMS OF THE FORM
C                   T * X = B  OR  TRANS(T) * X = B
C            WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N,
C            AND THE SOLUTION X OVERWRITES THE RHS B.
C            (ADAPTED FROM LINPACK SUBROUTINE DTRSL)
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE  DSOLVE

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB,LDB,LDT,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   B(LDB,N),T(LDT,N)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   J1,J,JN

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   B:       ON INPUT:  THE RIGHT HAND SIDE;  ON EXIT:  THE SOLUTION
C   J1:      THE FIRST NONZERO ENTRY IN T.
C   J:       AN INDEXING VARIABLE.
C   JN:      THE LAST NONZERO ENTRY IN T.
C   JOB:     WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS
C            1   SOLVE T*X=B, T LOWER TRIANGULAR,
C            2   SOLVE T*X=B, T UPPER TRIANGULAR,
C            3   SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR,
C            4   SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR.
C   LDB:     THE LEADING DIMENSION OF ARRAY B.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   N:       THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T.
C   T:       THE UPPER OR LOWER TRIDIAGONAL SYSTEM.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSOLVE


C  FIND FIRST NONZERO DIAGONAL ENTRY IN T
         J1 = 0
         DO 10 J=1,N
            IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN
               J1 = J
            ELSE IF (T(J,J).EQ.ZERO) THEN
               B(1,J) = ZERO
            END IF
   10    CONTINUE
         IF (J1.EQ.0) RETURN

C  FIND LAST NONZERO DIAGONAL ENTRY IN T
         JN = 0
         DO 20 J=N,J1,-1
            IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN
               JN = J
            ELSE IF (T(J,J).EQ.ZERO) THEN
               B(1,J) = ZERO
            END IF
   20    CONTINUE

         IF (JOB.EQ.1) THEN

C  SOLVE T*X=B FOR T LOWER TRIANGULAR
            B(1,J1) = B(1,J1)/T(J1,J1)
            DO 30 J = J1+1, JN
               TEMP = -B(1,J-1)
               CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   30       CONTINUE

         ELSE IF (JOB.EQ.2) THEN

C  SOLVE T*X=B FOR T UPPER TRIANGULAR.
            B(1,JN) = B(1,JN)/T(JN,JN)
            DO 40 J = JN-1,J1,-1
               TEMP = -B(1,J+1)
               CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   40       CONTINUE

         ELSE IF (JOB.EQ.3) THEN

C  SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
            B(1,JN) = B(1,JN)/T(JN,JN)
            DO 50 J = JN-1,J1,-1
               B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   50       CONTINUE

         ELSE IF (JOB.EQ.4) THEN

C  SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
            B(1,J1) = B(1,J1)/T(J1,J1)
            DO 60 J = J1+1,JN
               B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   60       CONTINUE
         END IF

      RETURN
      END
*DUNPAC
      SUBROUTINE DUNPAC
     +   (N2,V1,V2,IFIX)
C***BEGIN PROLOGUE  DUNPAC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DCOPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE
C            UNFIXED
C***END PROLOGUE  DUNPAC

C...SCALAR ARGUMENTS
      INTEGER
     +   N2

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V1(N2),V2(N2)
      INTEGER
     +   IFIX(N2)

C...LOCAL SCALARS
      INTEGER
     +   I,N1

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C            ODRPACK REFERENCE GUIDE.)
C   N1:      THE NUMBER OF ITEMS IN V1.
C   N2:      THE NUMBER OF ITEMS IN V2.
C   V1:      THE VECTOR OF THE UNFIXED ITEMS.
C   V2:      THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE
C            ELEMENTS OF V1 ARE TO BE INSERTED.


C***FIRST EXECUTABLE STATEMENT  DUNPAC


      N1 = 0
      IF (IFIX(1).GE.0) THEN
         DO 10 I = 1,N2
            IF (IFIX(I).NE.0) THEN
               N1 = N1 + 1
               V2(I) = V1(N1)
            END IF
   10    CONTINUE
      ELSE
         N1 = N2
         CALL DCOPY(N2,V1,1,V2,1)
      END IF

      RETURN
      END
*DWDS
      SUBROUTINE DWDS
     +   (N,M,W,RHO,LDRHO,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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, 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
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDT
C        THE LEADING DIMENSION OF ARRAY T.
      INTEGER LDWDT
C        THE LEADING DIMENSION OF ARRAY WDT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION T(LDT,M)
C        THE ARRAY BEING SCALED BY W*D.
      DOUBLE PRECISION TEMP
C        A TEMPORARY STORAGE LOCATION.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WDT(LDWDT,M)
C        THE RESULTS OF SCALING ARRAY T BY W*D.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DWDS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (W(1).GE.ZERO) THEN
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               DO 20 J=1,M
                  DO 10 I=1,N
                     WDT(I,J) = W(I)*RHO(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)*RHO(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(RHO(1,1))*T(I,J)
   50          CONTINUE
   60       CONTINUE
         END IF
      ELSE
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               DO 80 J=1,M
                  DO 70 I=1,N
                     WDT(I,J) = RHO(I,J)*T(I,J)
   70             CONTINUE
   80          CONTINUE
            ELSE
               DO 100 J=1,M
                  TEMP = RHO(1,J)
                  DO 90 I=1,N
                     WDT(I,J) = TEMP*T(I,J)
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
            TEMP = ABS(RHO(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
C
      RETURN
      END
*DVEVTR
      SUBROUTINE DVEVTR
     +   (M,NQ,INDX, 
     +    V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV,
     +    WRK5)
C***BEGIN PROLOGUE  DVEVTR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DSOLVE
C***DATE WRITTEN   910613   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE  V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V
C***END PROLOGUE  DVEVTR

C...SCALAR ARGUMENTS
      INTEGER
     +   INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   J,L1,L2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DSOLVE

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   INDX:    THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED.
C   J:       AN INDEXING VARIABLE.
C   LDE:     THE LEADING DIMENSION OF ARRAY E.
C   LDV:     THE LEADING DIMENSION OF ARRAY V.
C   LDVE:    THE LEADING DIMENSION OF ARRAY VE.
C   LDVEV:   THE LEADING DIMENSION OF ARRAY VEV.
C   LD2V:    THE SECOND DIMENSION OF ARRAY V.
C   L1:      AN INDEXING VARIABLE.
C   L2:      AN INDEXING VARIABLE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   E:       THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2).
C   V:       AN ARRAY OF NQ BY M MATRICES.
C   VE:      THE NQ BY M ARRAY VE = V * INV(E)
C   VEV:     THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V).
C   WRK5:    AN M WORK VECTOR.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DVEVTR


      IF (NQ.EQ.0 .OR. M.EQ.0) RETURN

      DO 140 L1 = 1,NQ
         DO 110 J = 1,M
            WRK5(J) = V(INDX,J,L1)
  110    CONTINUE
         CALL DSOLVE(M,E,LDE,WRK5,1,4)
         DO 120 J = 1,M
            VE(INDX,L1,J) = WRK5(J)
  120    CONTINUE
  140 CONTINUE

      DO 230 L1 = 1,NQ
         DO 220 L2 = 1,L1
            VEV(L1,L2) = ZERO
            DO 210 J = 1,M
               VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J)
  210       CONTINUE
            VEV(L2,L1) = VEV(L1,L2)
  220    CONTINUE
  230 CONTINUE

      RETURN
      END
*DWGHT
      SUBROUTINE DWGHT
     +   (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT)
C***BEGIN PROLOGUE  DWGHT
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T
C***END PROLOGUE  DWGHT

C...SCALAR ARGUMENTS
      INTEGER
     +   LDT,LDWT,LDWTT,LD2WT,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   I,J,K

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   LDWT:    THE LEADING DIMENSION OF ARRAY WT.
C   LDWTT:   THE LEADING DIMENSION OF ARRAY WTT.
C   LD2WT:   THE SECOND DIMENSION OF ARRAY WT.
C   M:       THE NUMBER OF COLUMNS OF DATA IN T.
C   N:       THE NUMBER OF ROWS OF DATA IN T.
C   T:       THE ARRAY BEING SCALED BY WT.
C   TEMP:    A TEMPORARY SCALAR.
C   WT:      THE WEIGHTS.
C   WTT:     THE RESULTS OF WEIGHTING ARRAY T BY WT.
C            ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT 
C            ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DWGHT


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (WT(1,1,1).GE.ZERO) THEN
         IF (LDWT.GE.N) THEN
            IF (LD2WT.GE.M) THEN
C  WT IS AN N-ARRAY OF M BY M MATRICES
               DO 130 I=1,N
                  DO 120 J=1,M
                     TEMP = ZERO
                     DO 110 K=1,M
                        TEMP = TEMP + WT(I,J,K)*T(I,K)
  110                CONTINUE
                     WTT(I,J) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
C  WT IS AN N-ARRAY OF DIAGONAL MATRICES
               DO 230 I=1,N
                  DO 220 J=1,M
                     WTT(I,J) = WT(I,1,J)*T(I,J)
  220             CONTINUE
  230          CONTINUE
            END IF
         ELSE
            IF (LD2WT.GE.M) THEN
C  WT IS AN M BY M MATRIX
               DO 330 I=1,N
                  DO 320 J=1,M
                     TEMP = ZERO
                     DO 310 K=1,M
                        TEMP = TEMP + WT(1,J,K)*T(I,K)
  310                CONTINUE
                     WTT(I,J) = TEMP
  320             CONTINUE
  330          CONTINUE
            ELSE
C  WT IS A DIAGONAL MATRICE
               DO 430 I=1,N
                  DO 420 J=1,M
                     WTT(I,J) = WT(1,1,J)*T(I,J)
  420             CONTINUE
  430          CONTINUE
            END IF
         END IF
      ELSE
C  WT IS A SCALAR
         DO 520 J=1,M
            DO 510 I=1,N
               WTT(I,J) = ABS(WT(1,1,1))*T(I,J)
  510       CONTINUE
  520    CONTINUE
      END IF

      RETURN
      END
*DWINF
      SUBROUTINE DWINF
     +   (N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +   DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
     +   RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +   OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +   PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +   BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +   FSI,FJACBI,WE1I,DIFFI,
     +   DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +   WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   LWKMN)
C***BEGIN PROLOGUE  DWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C***END PROLOGUE  DWINF

C...SCALAR ARGUMENTS
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI,
     +   DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN,
     +   M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,
     +   WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
      LOGICAL 
     +   ISODR

C...LOCAL SCALARS
      INTEGER
     +   NEXT

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   EPSI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS.
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NEXT:    THE NEXT AVAILABLE LOCATION WITH WORK.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI.
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSSI:    THE LOCATION IN ARRAY WORK OF VARIABLE WSS.
C   WSSDEI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL.
C   WSSEPI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS.
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.


C***FIRST EXECUTABLE STATEMENT  DWINF


      IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. 
     +    LDWE.GE.1 .AND. LD2WE.GE.1) THEN

         DELTAI =          1
         EPSI   = DELTAI + N*M
         XPLUSI = EPSI   + N*NQ
         FNI    = XPLUSI + N*M
         SDI    = FNI    + N*NQ
         VCVI   = SDI    + NP
         RVARI  = VCVI   + NP*NP

         WSSI   = RVARI  + 1
         WSSDEI = WSSI   + 1
         WSSEPI = WSSDEI + 1
         RCONDI = WSSEPI + 1
         ETAI   = RCONDI + 1
         OLMAVI = ETAI   + 1

         TAUI   = OLMAVI + 1
         ALPHAI = TAUI   + 1
         ACTRSI = ALPHAI + 1
         PNORMI = ACTRSI + 1
         RNORSI = PNORMI + 1
         PRERSI = RNORSI + 1
         PARTLI = PRERSI + 1
         SSTOLI = PARTLI + 1
         TAUFCI = SSTOLI + 1
         EPSMAI = TAUFCI + 1
         BETA0I = EPSMAI + 1

         BETACI = BETA0I + NP
         BETASI = BETACI + NP
         BETANI = BETASI + NP
         SI     = BETANI + NP
         SSI    = SI     + NP
         SSFI   = SSI    + NP
         QRAUXI = SSFI   + NP
         UI     = QRAUXI + NP
         FSI    = UI     + NP

         FJACBI = FSI    + N*NQ

         WE1I   = FJACBI + N*NP*NQ

         DIFFI  = WE1I + LDWE*LD2WE*NQ

         NEXT   = DIFFI + NQ*(NP+M)

         IF (ISODR) THEN
            DELTSI = NEXT
            DELTNI = DELTSI + N*M
            TI     = DELTNI + N*M
            TTI    = TI     + N*M
            OMEGAI = TTI    + N*M
            FJACDI = OMEGAI + NQ*NQ
            WRK1I  = FJACDI + N*M*NQ
            NEXT   = WRK1I  + N*M*NQ
         ELSE
            DELTSI = DELTAI
            DELTNI = DELTAI
            TI     = DELTAI
            TTI    = DELTAI
            OMEGAI = DELTAI
            FJACDI = DELTAI
            WRK1I  = DELTAI
         END IF

         WRK2I  = NEXT
         WRK3I  = WRK2I + N*NQ
         WRK4I  = WRK3I + NP
         WRK5I  = WRK4I + M*M
         WRK6I  = WRK5I + M
         WRK7I  = WRK6I + N*NQ*NP
         NEXT   = WRK7I + 5*NQ

         LWKMN  = NEXT
      ELSE
         DELTAI = 1
         EPSI   = 1
         XPLUSI = 1
         FNI    = 1
         SDI    = 1
         VCVI   = 1
         RVARI  = 1
         WSSI   = 1
         WSSDEI = 1
         WSSEPI = 1
         RCONDI = 1
         ETAI   = 1
         OLMAVI = 1
         TAUI   = 1
         ALPHAI = 1
         ACTRSI = 1
         PNORMI = 1
         RNORSI = 1
         PRERSI = 1
         PARTLI = 1
         SSTOLI = 1
         TAUFCI = 1
         EPSMAI = 1
         BETA0I = 1
         BETACI = 1
         BETASI = 1
         BETANI = 1
         SI     = 1
         SSI    = 1
         SSFI   = 1
         QRAUXI = 1
         FSI    = 1
         UI     = 1
         FJACBI = 1
         WE1I   = 1
         DIFFI  = 1
         DELTSI = 1
         DELTNI = 1
         TI     = 1
         TTI    = 1
         FJACDI = 1
         OMEGAI = 1
         WRK1I  = 1
         WRK2I  = 1
         WRK3I  = 1
         WRK4I  = 1
         WRK5I  = 1
         WRK6I  = 1
         WRK7I  = 1
         LWKMN  = 1
      END IF

      RETURN
      END
*DXMY
      SUBROUTINE DXMY
     +   (N,M,X,LDX,Y,LDY,XMY,LDXMY)
C***BEGIN PROLOGUE  DXMY
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE XMY = X - Y
C***END PROLOGUE  DXMY

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,LDXMY,LDY,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M),XMY(LDXMY,M),Y(LDY,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDXMY:   THE LEADING DIMENSION OF ARRAY XMY.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   M:       THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y.
C   N:       THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y.
C   X:       THE FIRST OF THE TWO ARRAYS.
C   XMY:     THE VALUES OF X-Y.
C   Y:       THE SECOND OF THE TWO ARRAYS.


C***FIRST EXECUTABLE STATEMENT  DXMY


      DO 20 J=1,M
         DO 10 I=1,N
            XMY(I,J) = X(I,J) - Y(I,J)
   10    CONTINUE
   20 CONTINUE

      RETURN
      END
*DXPY
      SUBROUTINE DXPY
     +   (N,M,X,LDX,Y,LDY,XPY,LDXPY)
C***BEGIN PROLOGUE  DXPY
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE XPY = X + Y
C***END PROLOGUE  DXPY

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,LDXPY,LDY,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M),XPY(LDXPY,M),Y(LDY,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDXPY:   THE LEADING DIMENSION OF ARRAY XPY.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   M:       THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y.
C   N:       THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y.
C   X:       THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER.
C   XPY:     THE VALUES OF X+Y.
C   Y:       THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER.


C***FIRST EXECUTABLE STATEMENT  DXPY


      DO 20 J=1,M
         DO 10 I=1,N
            XPY(I,J) = X(I,J) + Y(I,J)
   10    CONTINUE
   20 CONTINUE

      RETURN
      END
*DZERO
      SUBROUTINE DZERO
     +   (N,M,A,LDA)
C***BEGIN PROLOGUE  DZERO
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET A = ZERO
C***END PROLOGUE  DZERO

C...SCALAR ARGUMENTS
      INTEGER
     +   LDA,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   A(LDA,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       THE ARRAY TO BE SET TO ZERO.
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDA:     THE LEADING DIMENSION OF ARRAY A.
C   M:       THE NUMBER OF COLUMNS TO BE SET TO ZERO.
C   N:       THE NUMBER OF ROWS TO BE SET TO ZERO.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DZERO


      DO 20 J=1,M
         DO 10 I=1,N
            A(I,J) = ZERO
   10    CONTINUE
   20 CONTINUE

      RETURN
      END
      SUBROUTINE FUN(N,M,NP,NQ,
     1               LDN,LDM,LDNP,
     1               BETA,XPLUSD,
     1               IFIXB,IFIXX,LDIFX,
     1               IDEVAL,F,FJACB,FJACD,
     1               IFLAG)
C***ROUTINE ADAPTED TO UTILIZE DATAPLOT FUNCTION PARSING ROUTINE.
C
C  N       = NUMBER OF OBSERVATIONS
C  M       = NUMBER OF INDPENDENT VARIABLES
C  NQ      = NUMBER OF RESPONSE VARIABLES
C  NP      = NUMBER OF PARAMETERS
C  LDN     = LEADING DIMENSION DECLARATOR (>= N)
C  LDM     = LEADING DIMENSION DECLARATOR (>= M)
C  LDNP    = LEADING DIMENSION DECLARATOR (>= NP)
C  BETA    = ARRAY OF CURRENT PARAMETER VALUES
C  XPLUSD  = X + DELTA (MATRIX OF DATA VALUES)
C  IFIXB   = INDICATORS FOR "FIXING" BETA (NOTE: DATAPLOT FIXES
C            BY USING "^A" RATHER THAN "A" FOR PARAMETER)
C  IFIXX   = INDICATORS FOR "FIXING" EXPLANATORY VARIABLE
C  LDIFX   = LEADING DIMENSION OF ARRAY IFIXX
C  F       = ARRAY OF EVALUATED POINTS
C  FJACB   = JACOBIAN WITH RESPECT TO BETA
C            (NOTE: DATAPLOT CURRENTLY ALWAYS COMPUTES THE
C            NUMERICAL JACOBIAN)
C  FJACD   = JACOBIAN WITH RESPECT TO ERRORS DELTA
C            (NOTE: DATAPLOT CURRENTLY ALWAYS COMPUTES THE
C            NUMERICAL JACOBIAN)
C  IFLAG   = ERROR FLAG
C            0 MEANS CURRENT BETA AND X+DELTA WERE ACCEPTABLE
C            1 MEANS CURRENT BETA AND X+DELTA ARE NOT ACCEPTABLE,
C              ODRPACK SHOULD SELECT VALUES CLOSER TO MOST RECENTLY
C              USED VALUES IF POSSIBLE
C           -1 MEANS CURRENT BETA AND X+DELTA ARE NOT ACCEPTABLE,
C              ODRPACK SHOULD STOP
C
C  FOR DATAPLOT, EVALUATE ONE ROW OF XPLUSD WITH A CALL TO COMPIM
C  (AND RETURN ONE VALUE FOR F).
C
C***BEGIN PROLOGUE  FUN
C***REFER TO  SODR,SODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  861217   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  DUMMY ROUTINE TO CATCH CASE WHEN USER DOES NOT PROVIDE
C            THE NECESSARY FUNCTION ROUTINE
C***END PROLOGUE  FUN
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
C  INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTININE
      INTEGER IFLAG,IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
      DOUBLE PRECISION BETA(NP)
      DOUBLE PRECISION XPLUSD(LDN,M)
      INTEGER IFIXB(NP), IFIXX(LDIFX,M)
C
C  OUTPUT ARGUMENTS:
      DOUBLE PRECISION F(LDN,NQ)
CCCCC DATAPLOT DOES NOT COMPUTE ANALYTIC JACOBIANS, SO DIMENSION
CCCCC AS SINGLE DUMMY DIMENSION.
CCCCC DOUBLE PRECISION FJACB(LDN,LDNP,NQ)
CCCCC DOUBLE PRECISION FJACD(LDN,LDM,NQ)
      DOUBLE PRECISION FJACB(*)
      DOUBLE PRECISION FJACD(*)
C
C***DATAPLOT DECLARATIONS
C
      CHARACTER*4 MODEL
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IANGLU
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IVARN
      CHARACTER*4 IVARN2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      PARAMETER (IODRCH=1000)
      PARAMETER (IODRC2=100)
      PARAMETER (MAXNQ=5)
C
      DIMENSION PARAM3(IODRC2)
      CHARACTER*4 IPART1
      CHARACTER*4 IPART2
      DIMENSION IPART1(IODRC2)
      DIMENSION IPART2(IODRC2)
C
      DIMENSION PARAM(IODRC2,MAXNQ)
      DIMENSION IPARN(IODRC2,MAXNQ)
      DIMENSION IPARN2(IODRC2,MAXNQ)
      DIMENSION IVARN(IODRC2,MAXNQ)
      DIMENSION IVARN2(IODRC2,MAXNQ)
C
      DIMENSION MODEL(IODRCH,MAXNQ)
      DIMENSION ITYPEH(IODRCH,MAXNQ)
      DIMENSION IW21HO(IODRCH,MAXNQ)
      DIMENSION IW22HO(IODRCH,MAXNQ)
      DIMENSION W2HOLD(IODRCH,MAXNQ)
C
      DIMENSION ILOCV(IODRC2,MAXNQ)
C
      INTEGER NUMCHA(MAXNQ)
      INTEGER NUMPAR(MAXNQ)
      INTEGER NWHOLD(MAXNQ)
      INTEGER NUMVAR(MAXNQ)
      COMMON /ODRCMC/ IBUGA3, ITYPEH, IW21HO, IW22HO, IPARN, IPARN2, 
     &                IVARN, IVARN2, MODEL
      COMMON /ODRCMR/ PARAM, W2HOLD,
     &                NUMCHA, NUMPAR, NWHOLD, NUMVAR, ILOCV
C
      CHARACTER*4 IPAROC
      CHARACTER*4 IPARO3
      CHARACTER*4 IPARN3
      CHARACTER*4 IPARN4
      CHARACTER*4 IVARN3
      CHARACTER*4 IVARN4
      DIMENSION IPAROC(100)
      DIMENSION IPARN3(100)
      DIMENSION IPARN4(100)
      DIMENSION ICON3(100)
      DIMENSION IPARO3(100)
      DIMENSION PARLI3(100)
      DIMENSION IVARN3(100)
      DIMENSION IVARN4(100)
C
      COMMON /ODRCM2/ IPAROC, IPARO3, IPARN3, IPARN4, IVARN3, IVARN4
      COMMON /ODRCR2/ ICON3, PARLI3, NUMP, NUMV
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
      IBUGCO='OFF'
      IBUGEV='OFF'
      IANGLU='RADI'
C
      IF(MOD(IDEVAL/10,10).GE.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR IN ORTHOGONAL DISTANCE FIT.  ODRPACK',
     +         ' REQUESTED THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3)
    3   FORMAT('      COMPUTATION OF AN ANALYTIC JACOBIAN (WITH ',
     +         'RESPECT TO THE PARAMETERS).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
    5   FORMAT('      DATAPLOT DOES NOT CURRENTLY SUPPORT COMPUTATION',
     +         'OF ANALYTIC JACOBIANS.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(MOD(IDEVAL/100,10).GE.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR IN ORTHOGONAL DISTANCE FIT.  ODRPACK',
     +         ' REQUESTED THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
   13   FORMAT('      COMPUTATION OF AN ANALYTIC JACOBIAN (WITH ',
     +         'RESPECT TO DELTA).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
   15   FORMAT('      DATAPLOT DOES NOT CURRENTLY SUPPORT COMPUTATION',
     +         'OF ANALYTIC JACOBIANS.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(MOD(IDEVAL,10).LT.1)GOTO9000
C
C
C               ***************************
C               **  STEP 3--             **
C               **  INITIALIZE PARAMETERS**
C               ***************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IPASS=2
      IBUGCO=IBUGA3
      IBUGEV=IBUGA3
C
      IF(IBUGA3.EQ.'ON')THEN
        DO1000I=1,NUMP+NUMV
        WRITE(ICOUT,1001)I,IPARN3(I),IPARN4(I)
 1001   FORMAT('I,IPARN3(I),IPARN4(I) = ',I5,A4,A4)
        CALL DPWRST('XXX','BUG ')
 1000   CONTINUE
      ENDIF
C
      DO9009L=1,NQ
C
C  ONLY LOAD PARAMETERS RELEVANT FOR GIVEN FUNCTION
C
        NTEMP=0
        DO9100K=1,NP
          DO9102J=1,NUMPAR(L)
            IF(IPARN(J,L).EQ.IPARN3(K).AND.IPARN2(J,L).EQ.IPARN4(K))THEN
              NTEMP=NTEMP+1
              PARAM3(NTEMP)=REAL(BETA(K))
              IPART1(NTEMP)=IPARN3(K)
              IPART2(NTEMP)=IPARN4(K)
              GOTO9100
            ENDIF
 9102     CONTINUE
 9100   CONTINUE
C
CCCCC   IF(NUMPAR(L).NE.NP)THEN
CCCCC     WRITE(ICOUT,999)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,21)
CCC21     FORMAT('***** ERROR IN ORTHOGONAL DISTANCE FIT.  THE NUMBER')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,23)NP
CCC23     FORMAT('      OF PASSED PARAMETERS, ',I5,' DOES NOT EQUAL')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,25)NUMPAR(L)
CCC25     FORMAT('      NUMBER OF EXPECTED PARAMETERS, ',I5,'.')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     IERROR='YES'
CCCCC     GOTO9000
CCCCC   ENDIF
C
CCCCC   IF(NUMVAR(L).NE.M)THEN
CCCCC     WRITE(ICOUT,999)
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,31)
CCC31     FORMAT('***** ERROR IN ORTHOGONAL DISTANCE FIT.  THE NUMBER')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,23)M
CCC33     FORMAT('      OF PASSED VARIABLES, ',I5,' DOES NOT EQUAL')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     WRITE(ICOUT,35)NUMVAR(L)
CCC35     FORMAT('      NUMBER OF EXPECTED VARIABLES, ',I5,'.')
CCCCC     CALL DPWRST('XXX','BUG ')
CCCCC     IERROR='YES'
CCCCC     GOTO9000
CCCCC   ENDIF
C
        IF(IBUGA3.EQ.'OFF')GOTO99
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)L
   51   FORMAT('AT THE BEGINNING OF FUN, L=--',I5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NUMCHA(L),NUMPAR(L),NUMVAR(L)
   53   FORMAT('NUMCHA,NUMPAR,NUMVAR = ',3I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,54)(MODEL(J,L),J=1,MIN(100,NUMCHA(L)))
   54   FORMAT('MODEL(I) = ',100A1)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NUMPAR(L)
        WRITE(ICOUT,56)I,PARAM(I,L),IPARN(I,L),IPARN2(I,L)
   56   FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,E15.7,A4,A4)
        CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO59I=1,NUMVAR(L)
        WRITE(ICOUT,61)I,IVARN(I,L),IVARN2(I,L)
   61   FORMAT('I, IVARN(I,L),IVARN2(I,L) = ',I8,2X,A4,A4)
        CALL DPWRST('XXX','BUG ')
   59   CONTINUE
        DO75I=1,NUMPAR(L)+NUMVAR(L)
          WRITE(ICOUT,76)I,IPARN(I,L),IPARN2(I,L)
   76     FORMAT('I,IPARN(I),IPARN2(I) = ',I8,A4,A4)
          CALL DPWRST('XXX','BUG ')
   75   CONTINUE
        DO85I=1,NUMCHA(L)
        WRITE(ICOUT,86)I,MODEL(I,L)
   86   FORMAT('I,MODEL(I) = ',I5,A4)
        CALL DPWRST('XXX','BUG ')
   85   CONTINUE
   99   CONTINUE
C
        NUMPV=NTEMP+M
C
        DO9200I=1,N
          DO9210J=1,M
            PARAM3(J+NTEMP)=REAL(XPLUSD(I,J))
            IPART1(J+NTEMP)=IPARN3(NUMP+J)
            IPART2(J+NTEMP)=IPARN4(NUMP+J)
 9210     CONTINUE
          FX=0.0D0
          CALL COMPIM(MODEL(1,L),NUMCHA(L),IPASS,PARAM3,
     1              IPART1,IPART2,NUMPV,
     1              IANGLU,ITYPEH(1,L),IW21HO(1,L),
     1              IW22HO(1,L),W2HOLD(1,L),NWHOLD(L),FX,
     1              IBUGCO,IBUGEV,IERROR)
        F(I,L)=DBLE(FX)
        IF(IBUGA3.EQ.'ON')THEN
          WRITE(ICOUT,9101)I,FX
          CALL DPWRST('XXX','BUG ')
        ENDIF
 9200 CONTINUE
C
 9009 CONTINUE
 9101 FORMAT('I,FX  = ',I5,E15.7)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END      OF FUN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IERROR
 9021 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      IFLAG=0
      IF(IERROR.EQ.'YES')IFLAG = -1
C
      RETURN
      END
      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***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
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
C     DCHEX updates the Cholesky factorization
C
C                   A = TRANS(R)*R
C
C     of a positive definite matrix A of order P under diagonal
C     permutations of the form
C
C                   TRANS(E)*A*E
C
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
C                           U*R*E = RR,
C
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
C     The matrix Q is determined as the product U(L-K)*...*U(1)
C     of plane rotations of the form
C
C                           (    C(I)       S(I) )
C                           (                    ) ,
C                           (    -S(I)      C(I) )
C
C     where C(I) is double precision.  The rows these rotations operate
C     on are described below.
C
C     There are two types of permutations, which are determined
C     by the value of JOB.
C
C     1. Right circular shift (JOB = 1).
C
C         The columns are rearranged in the following order.
C
C                1,...,K-1,L,K,K+1,...,L-1,L+1,...,P.
C
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
C     2. Left circular shift (JOB = 2).
C         The columns are rearranged in the following order
C
C                1,...,K-1,K+1,K+2,...,L,K,L+1,...,P.
C
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
C     On Entry
C
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
C         LDR    INTEGER.
C                LDR is the leading dimension of the array R.
C
C         P      INTEGER.
C                P is the order of the matrix R.
C
C         K      INTEGER.
C                K is the first column to be permuted.
C
C         L      INTEGER.
C                L is the last column to be permuted.
C                L must be strictly greater than K.
C
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
C         LDZ    INTEGER.
C                LDZ is the leading dimension of the array Z.
C
C         NZ     INTEGER.
C                NZ is the number of columns of the matrix Z.
C
C         JOB    INTEGER.
C                JOB determines the type of permutation.
C                       JOB = 1  right circular shift.
C                       JOB = 2  left circular shift.
C
C     On Return
C
C         R      contains the updated factor.
C
C         Z      contains the updated matrix Z.
C
C         C      DOUBLE PRECISION(P).
C                C contains the cosines of the transforming rotations.
C
C         S      DOUBLE PRECISION(P).
C                S contains the sines of the transforming rotations.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DCHEX uses the following functions and subroutines.
C
C     BLAS DROTG
C     Fortran MIN0
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
      INTEGER LDR,P,K,L,LDZ,NZ,JOB
      DOUBLE PRECISION R(LDR,*),Z(LDZ,*),S(*)
      DOUBLE PRECISION C(*)
C
      INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1
CCCCC DOUBLE PRECISION RJP1J,T
      DOUBLE PRECISION T
C
C     INITIALIZE
C
C***FIRST EXECUTABLE STATEMENT  DCHEX
      KM1 = K - 1
      KP1 = K + 1
      LMK = L - K
      LM1 = L - 1
C
C     PERFORM THE APPROPRIATE TASK.
C
      GO TO (10,130), JOB
C
C     RIGHT CIRCULAR SHIFT.
C
   10 CONTINUE
C
C        REORDER THE COLUMNS.
C
         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
C        CALCULATE THE ROTATIONS.
C
         T = S(1)
         DO 70 I = 1, LMK
            CALL DROTG(S(I+1),T,C(I),S(I))
            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
C        IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z.
C
         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
C     LEFT CIRCULAR SHIFT
C
  130 CONTINUE
C
C        REORDER THE COLUMNS
C
         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
C        REDUCTION LOOP.
C
         DO 220 J = K, P
            IF (J .EQ. K) GO TO 200
C
C              APPLY THE ROTATIONS.
C
               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
C        APPLY THE ROTATIONS TO Z.
C
         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
      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***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
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
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
C     On Entry
C
C        X       DOUBLE PRECISION(LDX,P), where LDX .GE. N.
C                X contains the matrix whose decomposition is to be
C                computed.
C
C        LDX     INTEGER.
C                LDX is the leading dimension of the array X.
C
C        N       INTEGER.
C                N is the number of rows of the matrix X.
C
C        P       INTEGER.
C                P is the number of columns of the matrix X.
C
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
C                   If JPVT(K) .GT. 0, then X(K) is an initial
C                                      column.
C
C                   If JPVT(K) .EQ. 0, then X(K) is a free column.
C
C                   If JPVT(K) .LT. 0, then X(K) is a final column.
C
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
C        WORK    DOUBLE PRECISION(P).
C                WORK is a work array.  WORK is not referenced if
C                JOB .EQ. 0.
C
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
C     On Return
C
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
C        QRAUX   DOUBLE PRECISION(P).
C                QRAUX contains further information required to recover
C                the orthogonal part of the decomposition.
C
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
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DQRDC uses the following functions and subprograms.
C
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2
C     Fortran DABS,DMAX1,MIN0,DSQRT
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
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(*)
      DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*)
C
      INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
      DOUBLE PRECISION MAXNRM,DNRM2,TT
      DOUBLE PRECISION DDOT,NRMXL,T
      LOGICAL NEGJ,SWAPJ
C
C***FIRST EXECUTABLE STATEMENT  DQRDC
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         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
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      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
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN0(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            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
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            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
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               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
C              SAVE THE TRANSFORMATION.
C
               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END
      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***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
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
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
C            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C
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
C              XK = Q * (R)
C                       (0)
C
C     This information is contained in coded form in the arrays
C     X and QRAUX.
C
C     On Entry
C
C        X      DOUBLE PRECISION(LDX,P).
C               X contains the output of DQRDC.
C
C        LDX    INTEGER.
C               LDX is the leading dimension of the array X.
C
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
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
C        QRAUX  DOUBLE PRECISION(P).
C               QRAUX contains the auxiliary output from DQRDC.
C
C        Y      DOUBLE PRECISION(N)
C               Y contains an N-vector that is to be manipulated
C               by DQRSL.
C
C        JOB    INTEGER.
C               JOB specifies what is to be computed.  JOB has
C               the decimal expansion ABCDE, with the following
C               meaning.
C
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
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
C     On Return
C
C        QY     DOUBLE PRECISION(N).
C               QY contains Q*Y, if its computation has been
C               requested.
C
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
C        B      DOUBLE PRECISION(K)
C               B contains the solution of the least squares problem
C
C                    minimize norm2(Y - XK*B),
C
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
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
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
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
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
C          CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
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
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C
C     In any group the value returned in the array allocated to
C     the group corresponds to the last member of the group.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DQRSL uses the following functions and subprograms.
C
C     BLAS DAXPY,DCOPY,DDOT
C     Fortran DABS,MIN0,MOD
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
      INTEGER LDX,N,K,JOB,INFO
      DOUBLE PRECISION X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),
     1                 XB(*)
C
      INTEGER I,J,JJ,JU,KP1
      DOUBLE PRECISION DDOT,T,TEMP
      LOGICAL CB,CQY,CQTY,CR,CXB
C
C     SET INFO FLAG.
C
C***FIRST EXECUTABLE STATEMENT  DQRSL
      INFO = 0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      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
C     SPECIAL ACTION WHEN N=1.
C
      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
C        SET UP TO COMPUTE QY OR QTY.
C
         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
C           COMPUTE QY.
C
            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
C           COMPUTE TRANS(Q)*Y.
C
            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
C        SET UP TO COMPUTE B, RSD, OR XB.
C
         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
C           COMPUTE B.
C
            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
C           COMPUTE RSD OR XB AS REQUIRED.
C
            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
      SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB)
C***BEGIN PROLOGUE  DTRCO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
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
C     DTRCO estimates the condition of a double precision triangular
C     matrix.
C
C     On Entry
C
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
C        LDT     INTEGER
C                LDT is the leading dimension of the array T.
C
C        N       INTEGER
C                N is the order of the system.
C
C        JOB     INTEGER
C                = 0         T  is lower triangular.
C                = nonzero   T  is upper triangular.
C
C     On Return
C
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
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
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS DAXPY,DSCAL,DASUM
C     Fortran DABS,DMAX1,DSIGN
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
      INTEGER LDT,N,JOB
      DOUBLE PRECISION T(LDT,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION W,WK,WKM,EK
      DOUBLE PRECISION TNORM,YNORM,S,SM,DASUM
      INTEGER I1,J,J1,J2,K,KK,L
      LOGICAL LOWER
C***FIRST EXECUTABLE STATEMENT  DTRCO
      LOWER = JOB .EQ. 0
C
C     COMPUTE 1-NORM OF T
C
      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
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
C     SOLVE TRANS(T)*Y = E
C
      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)
C
      YNORM = 1.0D0
C
C     SOLVE T*Z = Y
C
      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
C
      IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO)
C***BEGIN PROLOGUE  DTRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
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
C     DTRSL solves systems of the form
C
C                   T * X = B
C     or
C                   TRANS(T) * X = B
C
C     where T is a triangular matrix of order N.  Here TRANS(T)
C     denotes the transpose of the matrix T.
C
C     On Entry
C
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
C         LDT       INTEGER
C                   LDT is the leading dimension of the array T.
C
C         N         INTEGER
C                   N is the order of the system.
C
C         B         DOUBLE PRECISION(N).
C                   B contains the right hand side of the system.
C
C         JOB       INTEGER
C                   JOB specifies what kind of system is to be solved.
C                   If JOB is
C
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
C     On Return
C
C         B         B contains the solution, if INFO .EQ. 0.
C                   Otherwise B is unaltered.
C
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
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS DAXPY,DDOT
C     Fortran MOD
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
      INTEGER LDT,N,JOB,INFO
      DOUBLE PRECISION T(LDT,*),B(*)
C
C
      DOUBLE PRECISION DDOT,TEMP
      INTEGER CASE,J,JJ
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 150
C
C        CHECK FOR ZERO DIAGONAL ELEMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DTRSL
         DO 10 INFO = 1, N
C     ......EXIT
            IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150
   10    CONTINUE
         INFO = 0
C
C        DETERMINE THE TASK AND GO TO IT.
C
         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
C        SOLVE T*X=B FOR T LOWER TRIANGULAR
C
   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
C        SOLVE T*X=B FOR T UPPER TRIANGULAR.
C
   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
C        SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
C
   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
C        SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
C
  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
*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
*BACK
      SUBROUTINE BACK (NC,LB,L,K,MV,RS,A,I,JC,ID,XI,MD,II,NI,ND,KZ,NL,N)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81.   BACK V 7.00  2/14/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C                         LOOK BACK COMPUTATION OF RSS
C
C     ONE OF FOUR SUBROUTINES CALLED BY MAIN SUBROUTINE SCREEN FOR
C                   REGRESSIONS BY LEAPS AND BOUNDS
C          A PROGRAM FOR FINDING THE BEST SUBSET REGRESSIONS
C                     G.M.FURNIVAL AND R.W.WILSON
C               YALE UNIVERSITY AND U.S. FOREST SERVICE
C                           VERSION 11/11/74
C
C               ADAPTED TO OMNITAB BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION - FEBRUARY, 1977.
C                   CURRENT VERSION - FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DIMENSION I(ND,ND), ID(ND), K(ND), NC(ND,ND), NI(ND), MD(ND,ND)
C
      REAL             XI(NL)
      REAL             A, RS
      REAL             B
      REAL             FDIV
C
      DATA ITHRE  /3/
      DATA IONE   /1/
      DATA IZERO  /0/
C
C     ==================================================================
C
C                               FIND SOURCE MATRIX.
C
  10  ISUB1 = K(JC)
      IF (LB.LE.NI(ISUB1)) GO TO 20
      JC = JC - IONE
      GO TO 10
C
C                            ADJUST FOR PREVIOUS PIVOTS.
C
  20  ISUB2 = IONE
      ISUB3 = IONE
      DO 50 J=JC,MV
        IN    = K(J)
        L     = I(IN,LB)
        MM    = ID(IN)
        ISUB2 = MM + MD(L,KZ)
        ISUB3 = MM + MD(L,L)
        IF (J.EQ.MV) GO TO 60
        IS    = K(J+1)
        ISUB4 = ID(IS) + MD(LB,KZ)
        IP    = I(IN,IS-1)
        ISUB5 = MM + MD(IP,L)
        ISUB6 = MM + MD(IP,IP)
        ISUB7 = MM + MD(IP,KZ)
        B     = FDIV (XI(ISUB5),XI(ISUB6),IND)
        KA    = IS
  30    IF (KA.GT.LB) GO TO 40
        KN    = I(IN,KA)
        ISUB8 = ID(IS) + MD(KA,LB)
        ISUB9 = MM + MD(KN,L)
        ISUB0 = MM + MD(KN,IP)
        XI(ISUB8) = XI(ISUB9) - B * XI(ISUB0)
        KA    = KA + IONE
        GO TO 30
  40    XI(ISUB4) = XI(ISUB2) - B * XI(ISUB7)
        NI(IS) = LB
        I(IS,LB) = LB
        N = N + ITHRE + LB - IS
        IF (II.EQ.IZERO) NC(IS,LB) = NC(IN,L)
  50  CONTINUE
C
C                                 CURRENT PIVOT.
C
  60  RS = A - FDIV (XI(ISUB2)*XI(ISUB2),XI(ISUB3),IND)
      RETURN
C
C     ================================================================
C
      END
*CODEXY
      SUBROUTINE CODEXY (X,N,SUMX,AVEX,XCODE,SQRTCT,U,L)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. CODEXY V 7.00  2/14/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     PROCEDURE FOR CODING X FOR ACCURATELY COMPUTING
C        SUM OF SQUARED DEVIATIONS FROM THE MEAN.
C
C     INPUT PARAMETERS ARE -
C
C            X = VECTOR OF MEASUREMENTS
C            N = LENGTH OF X
C
C     OUPUT PARAMETERS ARE -
C
C         SUMX = DOUBLE PRECISION SUM OF X MEASUREMENTS
C         AVEX = SINGLE PRECISION AVERAGE OF THE X MEASUREMENTS
C        XCODE = CODED VALUE TO BE USED INSTEAD OF AVERAGE FOR
C                   CUMPUTING DEVIATIONS ABOUT THE MEAN.
C                   XCODE IS THE VALUE OF X(I) CLOSEST TO AVEX.
C       SQRTCT = SQUARE ROOT OF CORRECTION TERM FOR COMPUTING
C                   SUM OF SQUARED DEVIATIONS ABOUT THE MEAN.
C
C                   SUM (X-AVEX)**2 = SUM(X-CODEX)**2 - SQRTCT**2,
C
C                   WHERE SQRTCT = (SUMX-N*XCODE)/SQRT(N)
C
C         U(I) = X(I) -XCODE, = CODED VALUES OF X
C            L = VALUE OF I FOR WHICH XCODE = X(I).
C
C               WRITTEN BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION - FEBRUARY, 1977.
C                   CURRENT VERSION - FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      REAL             X(*), U(*)
      REAL             AVEX, DELTA, XCODE
      REAL             FDPCON
C
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION DN, SQRTCT, SUMX
      DOUBLE PRECISION FDDIV, FDSQRT
      DOUBLE PRECISION DX(1)
      DOUBLE PRECISION SNEG
      DOUBLE PRECISION SPOS
C
      DATA DZERO  /0.0D0/
      DATA IONE   /1/
      DATA IZERO  /0/
C     ==================================================================
C
      SNEG=0.0D0
      SPOS=0.0D0
C     COMPUTE AVEX.
C
CCCCC CALL DSUMAL (DX,IZERO,SUMX)
      CALL DSUMAL (DX,IZERO,SNEG,SPOS,SUMX)
      DO 10 I=1,N
        DX(1) = DBLE ( X(I) )
CCCCC   CALL DSUMAL (DX,-IONE,SUMX)
        CALL DSUMAL (DX,-IONE,SNEG,SPOS,SUMX)
  10  CONTINUE
CCCCC CALL DSUMAL (DX,IONE,SUMX)
      CALL DSUMAL (DX,IONE,SNEG,SPOS,SUMX)
C
      DN = N
C
      AVEX = FDPCON ( FDDIV (SUMX,DN,IND) )
C
C     COMPUTE XCODE AND L.
C
      L = IONE
      DELTA = ABS (X(1)-AVEX)
      DO 30 I=2,N
        IF (ABS(X(I)-AVEX)-DELTA) 20,30,30
  20    L = I
        DELTA = ABS (X(I)-AVEX)
  30    CONTINUE
C
      XCODE = X(L)
C
C     COMPUTE CODED X = (X-XCODE).
C
      DO 40 I=1,N
        U(I) = X(I) - XCODE
  40  CONTINUE
C
C     COMPUTE CORRECTION TERM
C        FOR COMPUTING SUMX OF DEVIATIONS ABOUT THE MEAN.
C
      SQRTCT = FDDIV (SUMX-DN*DBLE(XCODE),FDSQRT(DN),IND)
C
      RETURN
C
C     ==================================================================
C
      END
*COEF
      SUBROUTINE COEF (R2,MP,KZ,XI,RR,MAXC,IND,NDEF,M,ND,MD,NL,IB,ZC)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81.   COEF V 7.00  8/27/91. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C                     COMPUTES REGRESSION STATISTICS
C
C ******************************************************************** *
C                                                                      *
C     ONE OF FOUR SUBROUTINES CALLED BY MAIN SUBROUTINE SCREEN FOR     *
C                   REGRESSIONS BY LEAPS AND BOUNDS                    *
C          A PROGRAM FOR FINDING THE BEST SUBSET REGRESSIONS           *
C                     G.M.FURNIVAL AND R.W.WILSON                      *
C               YALE UNIVERSITY AND U.S. FOREST SERVICE                *
C                           VERSION 11/11/74                           *
C                                                                      *
C ******************************************************************** *
C
C               MODIFIED TO PFORT BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION - SEPTEMBER, 1976.
C                   CURRENT VERSION -    AUGUST, 1991.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DIMENSION IND(ND), MD(ND,ND), NALPHA(15), NOUT(12)
C
C     ==================================================================
C
C                         ***   TYPE STATEMENTS   ***
C
CCCCC REAL             RR(29,29), XI(NL), ZC(ND)
      REAL             RR(MAXC,MAXC), XI(NL), ZC(ND)
      REAL             DBET, F, R2, VAR
      REAL             FDIV
C
C     ..................................................................
C
      CHARACTER NALPHA*1, NOUT*1
C
      PARAMETER (MAXV=38)
      CHARACTER*1 ICOD(MAXV)
      CHARACTER*38 IOUT
      CHARACTER*8 IVLIST
      COMMON/BESTC1/IOUNI1,IOUNI2
      COMMON/BESTC2/IVLIST(MAXV)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     ==================================================================
C
C                 ***   DATA INITIALIZATION STATEMENTS   ***
C
      DATA NOUT( 1), NOUT( 2), NOUT( 3), NOUT( 4), NOUT( 5), NOUT( 6) /
     1          'R',      '*',      '*',      '2',      'R',      '*' /
      DATA NOUT( 7), NOUT( 8), NOUT( 9), NOUT(10), NOUT(11), NOUT(12) /
     1          '*',      '2',      'C',      '(',      'P',      ')' /
      DATA ICOD(1) /'1'/
      DATA ICOD(2) /'2'/
      DATA ICOD(3) /'3'/
      DATA ICOD(4) /'4'/
      DATA ICOD(5) /'5'/
      DATA ICOD(6) /'6'/
      DATA ICOD(7) /'7'/
      DATA ICOD(8) /'8'/
      DATA ICOD(9) /'9'/
      DATA ICOD(10) /'0'/
      DATA ICOD(11) /'A'/
      DATA ICOD(12) /'B'/
      DATA ICOD(13) /'C'/
      DATA ICOD(14) /'D'/
      DATA ICOD(15) /'E'/
      DATA ICOD(16) /'F'/
      DATA ICOD(17) /'G'/
      DATA ICOD(18) /'H'/
      DATA ICOD(19) /'I'/
      DATA ICOD(20) /'J'/
      DATA ICOD(21) /'K'/
      DATA ICOD(22) /'L'/
      DATA ICOD(23) /'M'/
      DATA ICOD(24) /'N'/
      DATA ICOD(25) /'O'/
      DATA ICOD(26) /'P'/
      DATA ICOD(27) /'Q'/
      DATA ICOD(28) /'R'/
      DATA ICOD(29) /'S'/
      DATA ICOD(30) /'T'/
      DATA ICOD(31) /'U'/
      DATA ICOD(32) /'V'/
      DATA ICOD(33) /'W'/
      DATA ICOD(34) /'X'/
      DATA ICOD(35) /'Y'/
      DATA ICOD(36) /'Z'/
      DATA ICOD(37) /'a'/
      DATA ICOD(38) /'b'/
C
C     IF THE FOLLOWING VALUE IS CHANGED,
C        THE DIMENSION OF NALPHA MUST BE CHANGED AND
C        15A1 MUST BE CHANGED IN FORMAT 70.
C
      DATA NX / 15 /
C
      DATA IFOUR  /4/
      DATA ITHRE  /3/
C
CCCCC NOTE: ISIGD = 7 CAUSES PROBLEMS ON MICROSOFT COMPILER, SGI
CCCCC       COMPILER.  JUST SET TO 6 TO BE SAFE.
CCCCC DATA ISIGD  /7/
      DATA ISIGD  /6/
C
C     ==================================================================
C
      IEND = IFOUR * IB
      IBEG = IEND - ITHRE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60) (NOUT(I),I=IBEG,IEND), R2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)
      CALL DPWRST('XXX','BUG ')
  60  FORMAT(19X,4A1,' = ',F7.3)
  61  FORMAT(4X,'VARIABLE',9X,'COEFFICIENT',7X,'F RATIO')
C
C                             FORM SUBMATRIX
C
      IND(MP) = KZ
      DO 20 I=1,MP
        DO 10 J=I,MP
          ISUB1 = MD(I,J)
          ISUB2 = IND(I)
          ISUB3 = IND(J)
          XI(ISUB1) = RR(ISUB2,ISUB3)
  10    CONTINUE
  20  CONTINUE
C
C                            INVERT SUBMATRIX
C
      DO 30 N=1,M
        NN = N
        CALL PIVOT (XI,MP,NN,MD,ND,NL)
  30  CONTINUE
C
      ISUB4 = MD(MP,MP)
      VAR = FDIV (XI(ISUB4),FLOAT(NDEF-M),IF)
C
      DO 40 I=1,M
        ISUB5 = MD(I,MP)
        ZC(I) = -XI(ISUB5)
 40   CONTINUE
C
CCCCC NOTE: HAD PROBLEMS WITH RFORMT ON SOME PLATFORMS (MICROSOFT
CCCCC FORTRAN, SGI), SO JUST USE E FORMAT FOR NOW.
CCCCC CALL RFORMT (0,ISIGD,ZC,XI(1), M,NX,LW,LD,NALPHA(1),IRF)
CCCCC LB = NX - LW
C
      DO 50 I=1,M
        DBET = ZC(I)
        ISUB6 = MD(I,I)
CCCCC   CALL RFORMT (1,ISIGD,XI,ZC(I),LB, 1,LW,LD,NALPHA(1),IRF)
        F = -DBET*FDIV (DBET,XI(ISUB6)*VAR,IF)
CCCCC   WRITE(ICOUT,70) IND(I), (NALPHA(J),J=1,NX), F
        WRITE(ICOUT,70) IVLIST(IND(I)), ZC(I), F
        CALL DPWRST('XXX','BUG ')
  50  CONTINUE
CC70  FORMAT (10X,I2,7X,15A1,5X,F7.3)
  70  FORMAT (4X,A8,7X,E15.7,5X,F7.3)
C
      WRITE(IOUNI1,71)M,R2,(IVLIST(IND(J)),J=1,M)
  71  FORMAT(I3,1X,F7.3,' :',38(1X,A8))
C
      IOUT=' '
      DO80I=1,M
        IOUT(I:I)=ICOD(IND(I))
  80  CONTINUE
      WRITE(IOUNI2,'(38A1)')(IOUT(I:I),I=1,M)
 999  FORMAT(1X)
C
      RETURN
      END
*CPSTRE
      SUBROUTINE CPSTRE (RSS,CAB,KO,CL,RM,N,NS,ND)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. CPSTRE V 7.00  2/14/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C                  SAVES RSS:S AND LABELS FOR BEST REGRESSIONS
C ******************************************************************** *
C                                                                      *
C     ONE OF FOUR SUBROUTINES CALLED BY MAIN SUBROUTINE SCREEN FOR     *
C                   REGRESSIONS BY LEAPS AND BOUNDS                    *
C          A PROGRAM FOR FINDING THE BEST SUBSET REGRESSIONS           *
C                     G.M.FURNIVAL AND R.W.WILSON                      *
C               YALE UNIVERSITY AND U.S. FOREST SERVICE                *
C                           VERSION 11/11/74                           *
C                                                                      *
C ******************************************************************** *
C
C               MODIFIED TO PFORT BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION - FEBRUARY, 1977.
C                   CURRENT VERSION - FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      REAL             CL(11,ND), RM(11,ND)
      REAL             CAB, RSS
C
      DATA IONE   /1/
      DATA IZERO  /0/
C
C     ==================================================================
C
      DO 10 L=1,KO
        IF (CAB.EQ.CL(L,N)) RETURN
  10  CONTINUE
C
      L = IZERO
  20  L = L + IONE
        IF (RSS.GT.RM(L+1,N)) GO TO 30
        RM(L,N) = RM(L+1,N)
        CL(L,N) = CL(L+1,N)
        IF (L.EQ.NS) GO TO 30
      GO TO 20
C
  30  RM(L,N) = RSS
      CL(L,N) = CAB
      RETURN
C
C     ==================================================================
C
      END
*CRSPRD
      SUBROUTINE CRSPRD (X,N,M,INTCPT,CTERM,CP,MAXC)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. CRSPRD V 7.00  2/14/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     PROGRAM UNIT FOR COMPUTING A CROSS PRODUCT OF DEVIATIONS ABOUT
C        MEAN MATRIX, CP().
C
C        INPUT X(N,M)
C              N = NUMBER OF MEASUREMENTS
C              M = NUMBER OF VARIABLES.
C         INTCPT = 0, CROSS PRODUCTS ABOUT ORIGIN ARE COMPUTED
C                = 1, CROSS PRODUCTS ABOUT MEAN   ARE COMPUTED.
C
C        STORAGE CONST(M).
C
C        OUTPUT CP(M,M) = CROSS PRODUCT MATRIX.
C
C               WRITTEN BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION - FEBRUARY, 1977.
C                   CURRENT VERSION - FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      REAL             X(N,*)
CCCCC REAL             CP(29,29)
      REAL             CP(MAXC,MAXC)
      REAL             AVEX, XCODE
      REAL             FDPCON
C
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION CTERM(*)
      DOUBLE PRECISION F, SUMNEG, SUMPOS, SUMX
C
C     ==================================================================
C
      DATA IONE   /1/
      DATA DZERO  /0.0D0/
C
C     BEGIN COMPUTING.
C
C     COMPUTE CORRECTION TERM, CTERM(I), AND CODE X(I,J).
C
      IF (INTCPT.EQ.IONE) GO TO 20
      DO 10 I= 1,M
        CTERM(I) = DZERO
  10  CONTINUE
      GO TO 40
C
  20  DO 30 I=1,M
        CALL CODEXY (X(1,I),N,SUMX,AVEX,XCODE,CTERM(I),X(1,I),L)
  30  CONTINUE
C
C     COMPUTE (N-1)*VARIANCES.
C
  40  DO 60 I=1,M
        SUMPOS = DZERO
        SUMNEG = DZERO
        DO 50 J=1,N
          F = X(J,I)
          F = F**2
          SUMPOS = SUMPOS + DMAX1 (DZERO, F)
          SUMNEG = SUMNEG + DMAX1 (DZERO,-F)
  50    CONTINUE
        CP(I,I) = FDPCON ( (SUMPOS - SUMNEG) - CTERM(I)**2 )
  60  CONTINUE
C
C     COMPUTE CROSS PRODUCT MATRIX.
C
      IEND = M-IONE
      DO 90 I=1,IEND
        JBEG = I + IONE
        DO 80 J=JBEG,M
          SUMPOS = DZERO
          SUMNEG = DZERO
          DO 70 K=1,N
            F = DBLE(X(K,I))*DBLE(X(K,J))
            SUMPOS = SUMPOS + DMAX1 (DZERO, F)
            SUMNEG = SUMNEG + DMAX1 (DZERO,-F)
  70      CONTINUE
          CP(I,J) = FDPCON ( (SUMPOS - SUMNEG) - CTERM(I)*CTERM(J) )
          CP(J,I) = CP(I,J)
  80    CONTINUE
  90  CONTINUE
C
      RETURN
C
C     ==================================================================
C
      END
*FDDIV
      DOUBLE PRECISION FUNCTION FDDIV (FN,FD,IND)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81.  FDDIV V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     THIS FUNCTION PERFORMS DOUBLE PRECISION DIVISION.
C
C     IF THE DENOMINATOR EQUALS ZERO, THE RESULT IS SET EQUAL TO ZERO
C        AND THE INDICATOR, IND, IS SET EQUAL TO ONE.  OTHERWISE
C           IND EQUALS ZERO.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION FN, FD
C
C     ==================================================================
C
      DATA IZERO  /0/
      DATA IONE   /1/
      DATA DZERO  /0.0D0/
C
      IND = IZERO
      IF (FD-DZERO) 10,20,10
C
  10  FDDIV = FN/FD
      RETURN
C
C     ..................................................................
C
  20  FDDIV = DZERO
      IND = IONE
      RETURN
C
C     ==================================================================
C
      END
*FDIV
      REAL             FUNCTION FDIV (FN,FD,IND)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81.   FDIV V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     PROGRAM UNIT ...
C        DIVIDES FN BY FD USING FORTRAN OPERATOR /,
C           IF X IS NOT EQUAL TO ZERO, OR
C        SETS FAULT INDICATOR EQUAL TO ONE,
C           IF X IS EQUAL TO ZERO.
C
C     FAULT INDICATOR, IND = 0, IF FN IS NOT EQUAL TO ZERO, AND
C                          = 1, IF FN IS     EQUAL TO ZERO.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
C
      REAL             FN, FD
C
C     ==================================================================
C
      DATA IONE   /1/
      DATA IZERO  /0/
      DATA RZERO  /0.0/
C
      IND = IZERO
      IF (FD.EQ.RZERO) GO TO 10
      FDIV = FN / FD
      RETURN
C
C     ..................................................................
C
  10  FDIV = RZERO
      IND = IONE
      RETURN
C
C     ==================================================================
C
      END
*FDPCON
      REAL             FUNCTION FDPCON (X)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. FDPCON V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     FUNCTION TO CONVERT DOUBLE PRECISION NUMBER TO REAL NUMBER BY
C        OCTAL ROUNDING INSTEAD OF TRUNCATION.
C
C               WRITTEN BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION -   AUGUST, 1969.
C                   CURRENT VERSION - FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      REAL             Y
C
      DOUBLE PRECISION X
      DOUBLE PRECISION XX, D
C
C     ==================================================================
C
      DATA RPIFY /1.0E38/
      DATA RMIFY /-1.0E37/
C
      XX = X
      IF (XX.GT.DBLE(RPIFY)) XX = RPIFY
      IF (XX.LT.DBLE(RMIFY)) XX = RMIFY
C
      Y = XX
      D = Y
      FDPCON = XX + (XX-D)
C
      RETURN
C
C     ==================================================================
C
      END
*FDSQRT
      DOUBLE PRECISION FUNCTION FDSQRT (X)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. FDSQRT V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     THIS FUNCTION COMPUTES THE DOUBLE PRECISION SQUARE ROOT OF X.
C
C     IF THE ARGUMENT, X, IS LESS THAN ZERO, THE FUNCTION VALUE IS SET
C        EQUAL TO ZERO AND AN ARITHMETIC FAULT MESSAGE IS PRINTED.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DOUBLE PRECISION DZERO
      DOUBLE PRECISION X, DSQRT
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DZERO /0.0D0/
C
C     ==================================================================
C
      IF (X-DZERO) 20,30,10
C
  10  CONTINUE
      FDSQRT = DSQRT (X)
      RETURN
C
C     ..................................................................
C
  20  CONTINUE
CCCCC CALL ERROR (101)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR FROM FDSQRT: ATTEMPT TO TAKE SQUARE ROOT OF ',
     1       'NEGATIVE NUMBER.')
      CALL DPWRST('XXX','BUG ')
  30  CONTINUE
      FDSQRT = DZERO
      RETURN
C
C     ==================================================================
C
      END
*FLOG10
      REAL             FUNCTION FLOG10 (X)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. FLOG10 V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     PROGRAM UNIT ...
C        COMPUTES LOG TO BASE 10 OF X USING LIBRARY FUNCTION ALOG10,
C           IF X IS POSITIVE, OR
C        CALLS ERROR (101) AND SETS FUNCTION VALUE EQUAL TO ZERO,
C           IF X IS NONPOSITIVE.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      REAL             X
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA RZERO  /0.0/
C     ==================================================================
C
      IF (X.GT.RZERO) THEN
         FLOG10 = ALOG10 (X)
      ELSE
CCCCC    CALL ERROR (101)
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR FROM FLOG10: ATTEMPT TO TAKE THE LOG OF ',
     1          'A NON-POSITIVE NUMBER')
         CALL DPWRST('XXX','BUG ')
         FLOG10 = RZERO
      ENDIF
C
C     ..................................................................
C
      RETURN
C
C     ==================================================================
C
      END
*PIVOT
      SUBROUTINE PIVOT (XI,KP,N,MD,ND,NL)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81.  PIVOT V 7.00  2/21/90. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C              SYMETRIC PIVOT-RETURNS NEGATIVE INVERSE
C     ONE OF FOUR SUBROUTINES CALLED BY MAIN SUBROUTINE SCREEN FOR
C                   REGRESSIONS BY LEAPS AND BOUNDS
C          A PROGRAM FOR FINDING THE BEST SUBSET REGRESSIONS
C                     G.M.FURNIVAL AND R.W.WILSON 
C               YALE UNIVERSITY AND U.S. FOREST SERVICE
C                           VERSION 11/11/74
C
C               MODIFIED TO PFORT BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845 
C                  ORIGINAL VERSION - SEPTEMBER, 1976.
C                   CURRENT VERSION -  FEBRUARY, 1990.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DIMENSION MD(ND,ND)
C
      REAL             XI(NL) 
      REAL             B
      REAL             FDIV
C
      DATA RONE /1.0/
C
C     ==================================================================
C
      ISUB1 = MD(N,N)
      XI(ISUB1) = FDIV (-RONE,XI(ISUB1),IND)
      DO 20 I=1,KP
        IF (I.EQ.N) GO TO 20
        ISUB2 = MD(I,N)
        ISUB3 = MD(N,N)
        B = XI(ISUB2) * XI(ISUB3)
        DO 10 J=I,KP
          ISUB4 = MD(I,J)
          ISUB5 = MD(J,N)
          IF (J.NE.N) XI(ISUB4) = XI(ISUB4) + B*XI(ISUB5)
  10    CONTINUE
        XI(ISUB2) = B
  20  CONTINUE
      RETURN
C
C     ==================================================================
C
      END 
*RFORMT
      SUBROUTINE RFORMT (KTYPE,KDIGIT,X,XVALUE,K1,K2,KW,KD,NALPHA,KE)
C
C **  NBS OMNITAB 1980 VERSION 6.01  2/25/81. RFORMT V 7.00  2/19/91. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C                            *** DESCRIPTION ***
C
C     RFORMT IS A GENERAL-PURPOSE PORTABLE FORTRAN SUBROUTINE FOR USE IN
C        PRINTING REAL NUMBERS.
C
C     IT IS PRIMARILY INTENDED FOR PREPARING REAL NUMBERS TO BE PRINTED
C        IN READABLE FORM, I.E., WITH A CONSTANT NUMBER OF SIGNIFICANT
C        DIGITS AND THE DECIMAL POINT IN A CONSTANT POSITION.  THIS IS
C        IS CALLED R FORMAT.  IT CAN ALSO BE USED TO PRINT REAL NUMBERS
C        IN E, F, OR I FORMATS.
C
C     TO USE THE R FORMAT, IT IS NORMALLY NECESSARY TO USE RFORMT IN TWO
C        STAGES.  IN THE FIRST STAGE, WITH ITYPE = 0, NWIDTH AND NDECS
C        ARE CALCULATED.  IN THE SECOND STAGE, NWIDTH AND NDECS ARE USED
C        TO OBTAIN THE HOLLERITH CHARACTER STRING IN THE VECTOR NALPHA.
C
C     IN STAGE 2, REAL NUMBERS ARE CONVERTED INTO A HOLLERITH STRING AND
C        STORED IN THE VECTOR NALPHA FOR PRINTING WITH AN NA1 FORMAT.
C        THE HOLLERITH STRING IS PACKED ONE CHARACTER PER WORD.
C
C     ..................................................................
C
C                       *** STAGE 1 ARGUMENTS ***
C                       COMPUTE NWIDTH AND NDECS
C
C     INPUT ARGUMENTS -
C
C        (1)    ITYPE = 0
C        (2)   NDIGIT = NUMBER OF SIGNIFICANT DIGITS TO BE USED
C        (3)        X = VECTOR OF REAL NUMBERS DIMENSIONED AT LEAST N1
C                          IN CALLING PROGRAM UNIT
C        (4)   XVALUE = DUMMY ARGUMENT
C        (5)       N1 = LENGTH OF VECTOR X
C        (6)       N2 = MAXIMUM VALUE OF NWIDTH ALLOWED
C
C     OUTPUT ARGUMENTS -
C
C        (7)   NWIDTH = WIDTH OF FIELD NEEDED TO PRINT EVERY REAL NUMBER
C                          IN X IN R FORMAT
C        (8)    NDECS = NUMBER OF PLACES AFTER THE DECIMAL POINT NEEDED
C                          TO PRINT NUMBERS IN X IN R FORMAT
C        (9)   NALPHA = DUMMY ARRAY ARGUMENT, WHICH MUST BE
C                                 DIMENSIONED IN CALLING PROGRAM UNIT
C       (10)   IFAULT = FAULT INDICATOR,
C                     = 0, IF EVERYTHING IS OK
C                     = 1, IF ITYPE IS NEGATIVE
C                     = 2, IF VALUE OF NDIGIT INVALID
C                     = 3, IF N1 IS NON-POSITIVE
C                     = 4, IF N2 IS LESS THAN NDIGIT+2
C                     = 5, IF CALCULATED VALUE OF NWIDTH EXCEEDS N2.
C                             NWIDTH IS RESET TO N2.
C                     = 6, IF CALCULATED NWIDTH EXCEEDS N2 AND NDIGIT+5
C                             EXCEEDS N2
C
C     ..................................................................
C
C                         *** STAGE 2 ARGUMENTS ***
C                      PUT HOLLERITH STRING IN NALPHA
C
C     INPUT ARGUMENTS -
C
C        (1)    ITYPE = TYPE OF FORMAT DESIRED,
C                     =  1, R FORMAT, NUMBER ZERO HAS BLANKS AFTER DEC.
C                             POINT, 1PEW.(D-1) FORMAT USED IF NECESSARY
C                     =  2, R FORMAT, ZERO CONVERTED NORMALLY
C                             1PEW.(D-1) FORMAT USED IF NECESSARY
C                     =  3, R FORMAT, ZERO HAS BLANKS AFTER DEC. POINT,
C                             0PEW.D FORMAT USED IF NECESSARY
C                     =  4, R FORMAT, ZEROS CONVERTED NORMALLY
C                             0PEW.D JORMAT USED IF NECESSARY
C                     =  5, 1PEW.D FORMAT
C                     =  6, 0PEW.D FORMAT
C                     =  7, FW.D FORMAT, WITH ROUNDING
C                     =  8, FW.D FORMAT, WITH TRUNCATION
C                     =  9, IW FORMAT, WITH ROUNDING
C                     = 10, IW FORMAT, WITH TRUNCATION
C                     = 11, NWIDTH+N1 BLANKS STORED IN NALPHA
C        (2)   NDIGIT = NUMBER OF SIGNIFICANT DIGITS USED
C        (3)        X = DUMMY ARRAY ARGUMENT, WHICH MUST BE
C                           DIMENSIONED IN CALLING PROGRAM UNIT
C        (4)   XVALUE = REAL NUMBER TO BE CONVERTED
C        (5)       N1 = NUMBER OF BLANKS ADDED TO FIELD IN NALPHA
C        (6)       N2 = 0, NA BLANKS INSERTED ON LEFT (BEGINNING)
C                     = 1, N1 BLANKS ARE CENTERED
C        (7)   NWIDTH = LENGTH OF FIELD (HOLLERITH STRING) EXCLUDING N2
C                          BLANKS
C        (8)    NDECS = NUMBER OF PLACES AFTER THE DECIMAL POINT
C
C     OUTPUT ARGUMENTS -
C
C        (9)   NALPHA = HOLLERITH STRING REPRESENTATION OF XVALUE,
C                          OF LENGTH NWIDTH+N1
C       (10)   IFAULT = FAULT INDICATOR,
C                     =  0, IF EVERYTHING IS OK
C                     =  1, IF VALUE OF ITYPE IS NOT VALID
C                     =  2, IF VALUE OF NDIGIT IS NOT VALID
C                     =  3, IF N1 IS NON-POSITIVE
C                     =  7, IF VALUE OF N2 IS NOT ZERO OR ONE
C                     =  8, IF VALUE OF NWIDTH IS NOT VALID
C                     =  9, IF VALUE OF NDECS IS NOT VALID
C                     = 10, IF OVERFLOW OCCURS WITH F OR I FORMATS
C                     = 11, IF R FORMAT FORCED INTO E FORMAT
C                     = 12, IF R FORMAT REQUIRES E FORMAT AND
C                              NWIDTH IS TOO SMALL
C                     = 13, IF R FORMAT REQUIRES E FORMAT AND
C                              NDECS IS TOO SMALL
C                     = 14, IF ITYPE EQUALS 9 OR 10 AND NDECS DOES NOT
C                              EQUAL ZERO. ZERO IS USED FOR IDECS.
C
C     ..................................................................
C
C                           *** NOTES ***
C
C      1.   CAUTION.  IN STAGE 1 ITYPE MUST EQUAL ZERO OR RFORMT WILL
C              EXECUTE STAGE 2.
C      2.   IFAULT = 5, 10, 11 OR 14, INDICATES INFORMATIVE DIAGNOSTIC.
C              OTHERWISE NON-ZERO VALUES OF IFAULT INDICATE FATAL ERRORS
C              AND EXIT OCCURS WITHOUT ANY FURTHER CALCULATIONS OR ERROR
C              CHECKING.
C      3.   NDIGIT MUST BE GREATER THAN ZERO AND LESS THAN OR EQUAL TO
C              NSIGD.  SEE SECTION ON PORTABILITY BELOW FOR DEFINITION
C              OF NSIGD.
C      4.   X AND NALPHA MUST BE DIMENSIONED IN CALLING PROGRAM UNIT.
C      5.   RFORMT HANDLES REAL NUMBERS BETWEEN 10**(-100) AND 10**100,
C              EXCLUSIVELY.
C      6.   WHEN N2 = 1 IN STAGE 2, LARGEST NUMBER OF BLANKS IS ON RIGHT
C              IF N1 IS ODD.
C      7.   IN STAGE 1, NWIDTH INCLUDES POSITION FOR SIGN, EVEN
C              IF ALL NUMBERS ARE POSITIVE.  HOWEVER THERE ARE TWO
C              SPECIAL CASES ...
C                 (A) WHEN ALL X(I) = 0, IN WHICH CASE NWIDTH = 2
C                        AND NDECS = 0.
C                 (B) WHEN ALL X(I) ARE LESS THAN ONE IN ABSOLUTE VALUE
C                        AND AT LEAST ONE X(I) EQUALS ZERO. A POSITION
C                        FOR THE SIGN OF ZERO IS NOT INCLUDED IN NWIDTH.
C
C      8.   WITH R FORMAT, A DECIMAL POINT IS NOT STORED IN NALPHA IF
C              THE REAL NUMBER XVALUE EXCEEDS 10**NDIGIT.  IF NDIGIT=3,
C              1.23+03 IS STORED AS 1230 RATHER THAN 1230., TO EMPHASIZE
C              THAT THE ZERO IS NOT A SIGNIFICANT DIGIT.
C      9.   RFORMT DOES NO PRINTING.  PRINTING OF NALPHA WITH NA1 FORMAT
C              MUST BE DONE BY THE CALLING PROGRAM UNIT.
C     10.   WHEN ZERO IS PRINTED WITH R FORMAT, NDECS OVERRIDES NDIGIT.
C     11.   CAUTION.  IF IFAULT IS NOT EQUAL TO ZERO, NALPHA MAY NOT BE
C              BLANKED OUT.
C     12.   NALPHA IS UNCHANGED, IF ITYPE EQUALS ZERO.
C
C     ..................................................................
C
C                     *** USE OF E, F, AND I FORMATS ***
C
C     1.   1PEW.D FORMAT IS OBTAINED BY SETTING -
C              ITYPE =   5
C             NWIDTH =   W   = WIDTH OF FIELD
C             NDIGIT = (D+1) = NUMBER OF DIGITS
C
C          WITH D=6, 12.345678 IS WRITTEN AS 1.234568+01
C
C     2.   0PEW.D FORMAT IS OBTAINED BY SETTING -
C              ITYPE = 6
C             NWIDTH = W = WIDTH OF FIELD
C             NDIGIT = D = NUMBER OF DIGITS
C
C          WITH D=7, 12.345678 IS WRITTEN AS .1234568+02
C
C     3.   FW.D FORMAT IS OBTAINED BY SETTING -
C              ITYPE = 7 OR 8
C             NWIDTH = W = WIDTH OF FIELD
C              NDECS = D = NUMBER OF PLACES AFTER DECIMAL POINT
C
C     4.   IW FORMAT IS OBTAINED BY SETTING -
C              ITYPE = 9 OR 10
C             NWIDTH = W = WIDTH OF FIELD
C              NDECS = 0
C
C     NOTES -
C        A.   FOR E FORMAT, NDECS MUST BE GREATER THAN OR EQUAL TO ZERO.
C                NSIGDS=NDECS IS SET EQUAL TO NDIGIT+2 BY RFORMT.
C        B.   WITH EW.D FORMAT, THE LETTER E IS NOT USED AFTER THE
C                NUMBER AND BEFORE THE SIGNED CHARACTERISTIC.
C        C.   WITH 0PEW.D FORMAT, ZERO IS NOT PUT BEFORE THE DECIMAL
C                POINT.
C        D.   WITH FW.D FORMAT AND THE ABSOLUTE VALUE OF NUMBER IS LESS
C                THAN ONE, ZERO IS NOT PUT ON LEFT OF DECIMAL POINT,
C                UNLESS D = 0.
C
C     ..................................................................
C
C                            *** PORTABILITY ***
C
C     RFORMT IS COMPLETELY PORTABLE EXCEPT FOR ONE MACHINE DEPENDENT
C        CONSTANT, NSIGD, SET IN THE DATA STATEMENT ON LINE RF 320.
C
C     NSIGD IS THE NUMBER OF SIGNIFICANT DECIMAL DIGITS IN THE COMPUTER.
C        NSIGD =  7, FOR A 32 BIT WORD COMPUTER (IBM)
C              =  8, FOR A 36 BIT WORD COMPUTER (UNIVAC), VALUE SET
C              = 10, FOR A 48 BIT WORD COMPUTER (BURROUGHS)
C              = 13, FOR A 60 BIT WORD COMPUTER (CDC).
C
C     CAUTION.  NSIGD MUST BE SMALL ENOUGH SO THAT 10**(NSIGD+1) IS A
C        VALID MACHINE INTEGER.  (THIS EXPLAINS WHY NSIGD EQUALS 13 AND
C        NOT 14 FOR A 60 BIT WORD COMPUTER.)
C
C     SOURCE LANGUAGE IS PFORT (A PORTABLE SUBSET OF ANS FORTRAN).
C
C     FORTRAN LIBRARY FUNCTION USED IS ALOG10,
C        WHICH APPEARS ON LINES RF 389, RF 391, AND RF 612.
C
C     STORAGE USED IS 1495 36 BIT WORDS WITH UNIVAC 1108 EXEC 8 COMPUTER
C
C     ..................................................................
C
C                           *** STATIC PROFILE ***
C
C     I/O STATEMENTS                 0
C     NONEXECUTABLE STATEMENTS      20
C     EXECUTABLE STATEMENTS        244
C        UNCONDITIONAL 160
C          CONDITIONAL  84
C     COMMENT STATEMENTS           532
C     --------------------------------
C     TOTAL NUMBER OF STATEMENTS   796
C     --------------------------------
C     CONTINUATION LINES             6
C     --------------------------------
C     NUMBER OF LINES OF CODE      802
C
C     ..................................................................
C
C                             *** REFERENCE ***
C
C     HOGBEN, DAVID (1977).  A FLEXIBLE PORTABLE FORTRAN PROGRAM UNIT
C        FOR READABLE PRINTING OF REAL NUMBERS.  IN PREPARATION.
C
C     ..................................................................
C
C               WRITTEN BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      CENTER FOR COMPUTING AND APPLIED MATHEMATICS,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-975-2845
C                  ORIGINAL VERSION -    APRIL, 1969.
C                   CURRENT VERSION - FEBRUARY, 1991.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      DIMENSION NALPHA(*)
C
C     ==================================================================
C
C                    ***   TYPE STATEMENTS   ***
C
      REAL             X(*)
      REAL             XVALUE
      REAL             ABSMAX, ABSMIN, ABSX, ABSXVA, X1, X2
      REAL             FLOG10
C
C......................................................................
C
      DOUBLE PRECISION Z, ZLOWER, ZUPPER
      DOUBLE PRECISION DFIVE, DTEN
      DOUBLE PRECISION FDDIV
C
C     ..................................................................
C
      CHARACTER*1 LA(74)
      CHARACTER NALPHA*1
C
CCCCC INCLUDE 'DPCOHO.INC'
C
C     ==================================================================
C
C                 ***   DATA INITIALIZATION STATEMENTS   ***
C
      DATA DFIVE, DTEN / 5.0D0, 10.0D0 /
C
      DATA ITEN   /10/
      DATA IFIVE  /5/
      DATA IFOUR  /4/
      DATA ITHRE  /3/
      DATA ITWO   /2/
      DATA IONE   /1/
      DATA IZERO  /0/
C
      DATA RHALF   /0.5/
      DATA RONE    /1.0/
      DATA RZERO   /0.0/
C
CCCCC DATA ISIGD /7/
C
C   LA( 1) =  0  LA( 2) =  1  LA( 3) =  2  LA( 4) =  3  LA( 5) =  4
C   LA( 6) =  5  LA( 7) =  6  LA( 8) =  7  LA( 9) =  8  LA(10) =  9
C   LA(11) =  A  LA(12) =  B  LA(13) =  C  LA(14) =  D  LA(15) =  E
C   LA(16) =  F  LA(17) =  G  LA(18) =  H  LA(19) =  I  LA(20) =  J
C   LA(21) =  K  LA(22) =  L  LA(23) =  M  LA(24) =  N  LA(25) =  O
C   LA(26) =  P  LA(27) =  Q  LA(28) =  R  LA(29) =  S  LA(30) =  T
C   LA(31) =  U  LA(32) =  V  LA(33) =  W  LA(34) =  X  LA(35) =  Y
C   LA(36) =  Z  LA(37) =  /  LA(38) =  .  LA(39) =  -  LA(40) =  +
C   LA(41) =  *  LA(42) =  (  LA(43) =  )  LA(44) =  ,  LA(45) =  
C   LA(46) =  =  LA(47) =  $  LA(48) =  '  LA(49) =  a  LA(50) =  b
C   LA(51) =  c  LA(52) =  d  LA(53) =  e  LA(54) =  f  LA(55) =  g
C   LA(56) =  h  LA(57) =  i  LA(58) =  j  LA(59) =  k  LA(60) =  l
C   LA(61) =  m  LA(62) =  n  LA(63) =  o  LA(64) =  p  LA(65) =  q
C   LA(66) =  r  LA(67) =  s  LA(68) =  t  LA(69) =  u  LA(70) =  v
C   LA(71) =  w  LA(72) =  x  LA(73) =  y  LA(74) =  z
C
      DATA LA( 1), LA( 2), LA( 3), LA( 4), LA( 5),
     1     LA( 6), LA( 7), LA( 8), LA( 9), LA(10)/
     2        '0',    '1',    '2',    '3',    '4',
     3        '5',    '6',    '7',    '8',    '9'/
C
      DATA LA(11), LA(12), LA(13), LA(14), LA(15),
     1     LA(16), LA(17), LA(18), LA(19), LA(20)/
     2        'A',    'B',    'C',    'D',    'E',
     3        'F',    'G',    'H',    'I',    'J'/
C
      DATA LA(21), LA(22), LA(23), LA(24), LA(25),
     1     LA(26), LA(27), LA(28), LA(29), LA(30)/
     2        'K',    'L',    'M',    'N',    'O',
     3        'P',    'Q',    'R',    'S',    'T'/
C
      DATA LA(31), LA(32), LA(33), LA(34), LA(35),
     1     LA(36), LA(37), LA(38), LA(39), LA(40)/
     2        'U',    'V',    'W',    'X',    'Y',
     3        'Z',    '/',    '.',    '-',    '+'/
C
      DATA LA(41), LA(42), LA(43), LA(44), LA(45),
     1     LA(46), LA(47), LA(48), LA(49), LA(50)/
     2        '*',    '(',    ')',    ',',    ' ',
     3        '=',    '$',   '''',    'a',    'b'/
C
      DATA LA(51), LA(52), LA(53), LA(54), LA(55),
     1     LA(56), LA(57), LA(58), LA(59), LA(60)/
     2        'c',    'd',    'e',    'f',    'g',
     3        'h',    'i',    'j',    'k',    'l'/
C
      DATA LA(61), LA(62), LA(63), LA(64), LA(65),
     1     LA(66), LA(67), LA(68), LA(69), LA(70)/
     2        'm',    'n',    'o',    'p',    'q',
     3        'r',    's',    't',    'u',    'v'/
C
      DATA LA(71), LA(72), LA(73), LA(74)/
     2        'w',    'x',    'y',    'z'/
C
C     ==================================================================
C
CCCCC ISIGD NEEDS TO BE 6 ON MICROSOFT/COMPAQ PC COMPILER.
CCCCC ALSO NEDS TO BE 6 ON SGI.
CCCCC TO BE SAFE, JUST SET TO 6, WHICH SHOULD WORK ON ALL 32-BIT
CCCCC HOSTS.
C
      ISIGD = 6
CCCCC IF(ICOMPI.EQ.'MS-F')ISIGD = 6
CCCCC IF(ICOMPI.EQ.'LAHE')ISIGD = 6
C
C     ADAPTIONS FOR OMNITAB.
C
C     NW IS USED INSTEAD OF NWIDTH
C     ND IS USED INSTEAD OF NDECS
C     IE IS USED INSTEAD OF IFAULT
C
      ITYPE  = KTYPE
      NDIGIT = KDIGIT
          N1 = K1
          N2 = K2
          NW = KW
          ND = KD
          IE = KE
C
C     GENERAL ERROR CHECKING.
C
      ZLOWER = ITEN ** NDIGIT
      ZUPPER = DTEN * ZLOWER
      IE = IZERO
      IF (ITYPE.GE.IZERO) GO TO 10
        IE = IONE
        GO TO 390
C
C     ..................................................................
C
  10  IF (NDIGIT.GT.IZERO .AND. NDIGIT.LE.ISIGD) GO TO 20
        IE = ITWO
        GO TO 390
C
C     ..................................................................
C
  20  IF (ITYPE.GT.IZERO) GO TO 80
C
C     ==================================================================
C
C                           *** STAGE 1 ***
C                       COMPUTE NWIDTH AND NDECS
C
C     STAGE 1 ERROR CHECKING
C
      IF (N1.GT.IZERO) GO TO 30
        IE = ITHRE
        GO TO 390
C
C     ..................................................................
C
C     N2 MUST BE LARGE ENOUGH FOR NDIGIT, DECIMAL POINT, AND SIGN.
C
  30  IF (N2.GE.NDIGIT+ITWO) GO TO 40
        IE = IFOUR
        GO TO 390
C
C     ..................................................................
C
C     (1)   COMPUTE MMIN, CHARACTERISTIC OF ABSMIN = MIN ABS VALUE X(I)
C             AND COMPUTE MMAX, CHARACTERISTIC OF ABSMAX = MAX ABS X(I).
C
  40  ABSX = ABS (X(1))
      IF (ABSX.LE.RZERO) ABSX = RONE
      ABSMIN = ABSX
      ABSMAX = ABSX
C
      K = IZERO
C
C     K IS USED IN TWO SPECIAL CASES ... WHEN
C        (A)  ALL X(I) EQUAL ZERO, AND
C        (B)  ABS (X(I)) IS LESS THAN 1.0, FOR ALL I, AND SOME X(I)=0.0.
C
      DO 50 I=1,N1
        ABSX = ABS (X(I))
        IF (ABSX.GE.RONE) K = IONE
        IF (ABSX.LE.RZERO) ABSX = RONE
        IF (ABSX.LT.ABSMIN) ABSMIN = ABSX
        IF (ABSX.GT.ABSMAX) ABSMAX = ABSX
  50  CONTINUE
C
      MMIN = FLOG10 (ABSMIN)
      IF (ABSMIN.LT.RONE) MMIN = MMIN - IONE
      MMAX = FLOG10 (ABSMAX)
      IF (ABSMAX.LT.RONE) MMAX = MMAX - IONE
C
C     ADJUST FOR POSSIBLE INCORRECT VALUES OF MMIN AND MMAX DUE TO
C        ERROR IN ALOG10 CALCULATION.
C
      Z = ABSMIN
      Z = Z * DTEN ** (NDIGIT-MMIN) + DFIVE
C
      IF (Z.LT.ZLOWER) MMIN = MMIN - IONE
      IF (Z.GE.ZUPPER) MMIN = MMIN + IONE
C
      Z = ABSMAX
      Z = Z * DTEN ** (NDIGIT-MMAX) + DFIVE
C
      IF (Z.LT.ZLOWER) MMAX = MMAX - IONE
      IF (Z.GE.ZUPPER) MMAX = MMAX + IONE
C
C     ..................................................................
C
C     (2)   USE MMIN AND MMAX TO COMPUTE NWIDTH AND NDECS.
C
      ND = NDIGIT - MMIN - IONE
      ND = MAX0 (IZERO,ND)
      NW = MMAX + ITHRE + ND
      IF (MMAX.LT.IZERO) NW = ND + ITWO
      IF (K.EQ.IONE) GO TO 60
C
C     ADJUST FOR SPECIAL CASE (B) DESCRIBED ON LINE RF 368
C
      IF (ABSMIN.LT.RONE .AND. ABSMAX.GE.RONE) NW = NW - IONE
C
C     ADJUST FOR SPECIAL CASE (A) DESCRIBED ON LINE RF 367
C
      IF (ABSMIN.LT.RONE .OR. ABSMAX.LT.RONE) GO TO 60
      NW = ITWO
      ND  = IZERO
C
  60  IF (NW.LE.N2) GO TO 390
C
C     NWIDTH IS TOO LARGE AND HAS TO BE ADJUSTED.
C
        IE = IFIVE
      IF (NDIGIT+IFIVE.LE.N2) GO TO 70
        IE = 6
        GO TO 390
C
C     ..................................................................
C
C
C     NDIGIT+2 = (NDIGIT-1) + (+XX), FOR EXPONENT OF FLOATING-POINT NO.
C
  70  ND = MAX0 (ND,NDIGIT+ITWO)
C
C     N2-3 = N2 - (SIGN+DIGIT+DECIMAL POINT).
C
      ND = MIN0 (ND,N2-ITHRE)
      NW = N2
      GO TO 390
C
C     ==================================================================
C
C                          ***** STAGE 2 *****
C                     PUT HOLLERITH STRING IN NALPHA
C
  80  ABSXVA = ABS (XVALUE)
C
C     STAGE 2 ERROR CHECKING
C
      IF (ITYPE.LT.12) GO TO 90
        IE = IONE
        GO TO 390
C
C     ..................................................................
C
  90  IF (N1.GE.IZERO) GO TO 100
        IE = ITHRE
        GO TO 390
C
C     ..................................................................
C
 100  IF (N2.EQ.IZERO .OR. N2.EQ.IONE) GO TO 110
        IE = 7
        GO TO 390
C
C     ..................................................................
C
 110  IF (ITYPE.LT.9 .AND. NW.LT.ND+ITWO) GO TO 120
      IF (NW.LE.IZERO) GO TO 120
      IF (ITYPE.GT.6) GO TO 130
      IF (ABSXVA.LE.RZERO .AND. NW.GE.ITWO .AND. ITYPE.LE.IFOUR)
     1     GO TO 130
C
C     CHECK WHETHER NWIDTH IS VALID.
C
      IF (NW.LT.NDIGIT+ITWO) GO TO 120
      IF (ITYPE.LT.IFIVE) GO TO 130
      IF (NW.GE.NDIGIT+IFIVE) GO TO 130
 120    IE = 8
        GO TO 390
C
C     ..................................................................
C
 130  IF (ND.GE.IZERO) GO TO 140
        IE = 9
        GO TO 390
C
C     ..................................................................
C
C         VARIABLES USED TO DEFINE FIELD WIDTH FOR R FORMAT
C
C                     -----------------------------
C                     I        NWIDTH             I
C          ----------------------------------------------
C          I  NBLANK  I     NDIFF     I   NDECS   I     I
C          ----------------------------------------------
C          I       NPONE              I
C          ----------------------------------------
C          I             LTOTAL                   I
C          ----------------------------------------------
C          I        NTOTAL = NWIDTH + N1                I
C          ----------------------------------------------
C
C     ..................................................................
C
C     (1)   INITIALIZATION.
C
C     CLEAR OUT NALPHA WITH BLANKS.
C
 140  NTOTAL = NW + N1
      DO 150 I=1,NTOTAL
        NALPHA(I) = LA(45)
 150  CONTINUE
C
      IF (ITYPE.EQ.11) GO TO 390
C
C     IF NECESSARY, CENTER BLANKS WITH LARGEST NUMBER ON RIGHT IF N1 ODD
C
      CALL IDIV (N1+IONE,ITWO,IND,NJUNK)
      NBLANK = N1 - NJUNK * N2
C
      MF    = IZERO
      MREAL = IZERO
      IDECS = ND
      IF (ITYPE.LT.9 .OR. IDECS.EQ.IZERO) GO TO 160
      IDECS = IZERO
      IE    = 14
 160  IF (ITYPE.EQ.IFIVE .OR. ITYPE.EQ.6) IDECS = NDIGIT + ITWO
C
C     THE NEXT THREE STATEMENTS ARE USED TO SWITCH FROM F TO I FORMAT
C
      NSIGDS = NDIGIT
      IWIDTH = NW
      IF (ITYPE.EQ.9 .OR. ITYPE.EQ.ITEN) IWIDTH = IWIDTH + IONE
      NDIFF = IWIDTH - IDECS
      LTOTAL = IWIDTH + NBLANK
      NPONE = NDIFF + NBLANK
C
      IF (ABSXVA.GE.RONE) GO TO 200
      IF (ITYPE.LT.9 .AND. ABSXVA.GT.RZERO) GO TO 200
C
C     ..................................................................
C
C     (2)   XVALUE = 0. IS SPECIAL CASE.
C
      IF (ITYPE.LT.9) GO TO 180
C
C     INTEGER FORMAT
C
      IF (ABSXVA.LE.RHALF .OR. ITYPE.EQ.ITEN) GO TO 170
      NALPHA(LTOTAL-1) = LA(2)
        IF (XVALUE.LT.RZERO) NALPHA(LTOTAL-2) = LA(39)
      GO TO 390
C
C     ..................................................................
C
 170  NALPHA(LTOTAL-1) = LA(1)
      GO TO 390
C
C     ..................................................................
C
C     R FORMAT WITH ZERO STORED AS 0.
C
 180  NALPHA(NPONE  ) = LA(38)
      NALPHA(NPONE-1) = LA(1)
      IF (ITYPE.EQ.IONE .OR. ITYPE.EQ.ITHRE) GO TO 390
      IF (ITYPE.EQ.ITWO .AND. IDECS.EQ.IZERO) GO TO 390
      IF (ITYPE.EQ.IFOUR .AND. IDECS.EQ.IZERO) GO TO 390
C
C     FIXED 0
C
      IF (ITYPE.EQ.7 .AND. ND.EQ.IZERO) GO TO 390
      IF (ITYPE.EQ.8 .AND. ND.EQ.IZERO) GO TO 390
C
      IF (ITYPE.EQ.7 .OR. ITYPE.EQ.8) NALPHA(NPONE-1) = LA(45)
C
C     ALL OTHER CASES
C
      IBEG = NPONE + IONE
      IEND = NPONE + IDECS
      DO 190 I=IBEG,IEND
        NALPHA(I) = LA(1)
 190  CONTINUE
C
C     ..................................................................
C
      IF (ITYPE.NE.IFIVE .AND. ITYPE.NE.6) GO TO 390
C
C     FLOATING
C
      NALPHA(LTOTAL-2) = LA(40)
      IF (ITYPE.EQ.IFIVE) GO TO 390
      NALPHA(NPONE  ) = LA(1)
      NALPHA(NPONE-1) = LA(38)
      GO TO 390
C
C     ..................................................................
C
C     (3)   COMPUTE M = CHARACTERISTIC OF ABSXVA = ABS(XVALUE) AND
C                  LL = (NSIGDS+1) INTEGER REPRESENTATION OF ABSXVA.
C              FOR XVALUE = -12.345678, M=1 AND LL=123456784, AN
C              ADDITIONAL DIGIT IN LL IS USED TO AVOID ROUNDOFF ERROR.
C
 200  M = FLOG10 (ABSXVA)
      IF (ABSXVA.LT.RONE) M = M - IONE
      Z = ABSXVA
      Z = Z * DTEN**(NSIGDS-M)
C
C     IF M IS COMPUTED ACCURATELY, ZLOWER .LE. Z .LT. ZUPPER
C
      IF (Z.GE.ZLOWER) GO TO 210
C
C     Z IS LESS THAN ZLOWER BECAUSE M IS ONE TOO LARGE.
C       ADJUST BY SUBTRACTING 1 FROM M AND MULTIPLYING Z BY 10.
C
      M = M - IONE
      Z = DTEN * Z
      GO TO 220
C
 210  IF (Z.LT.ZUPPER) GO TO 220
C
C     Z IS GREATER THAN OR EQUAL TO ZUPPER BECAUSE M IS ONE TOO SMALL.
C       ADJUST BY ADDING 1 TO M AND DIVIDING Z BY 10.
C
      M = M + IONE
      Z = FDDIV (Z,DTEN,IND)
C
 220  X1 = Z
      LL1 = X1
      X2 = Z - DBLE (X1)
      LL2 = X2
      LL = LL1 + LL2 + IFIVE
      IF (LL.LT.ITEN**(NSIGDS+IONE)) GO TO 230
C
C     MAKE ADJUSTMENT WHEN LL IS TOO LARGE.
C
      M = M + IONE
      CALL IDIV (LL,ITEN,IND,LL)
      GO TO 240
 230  IF (LL.GE.ITEN**NSIGDS) GO TO 240
C
C     MAKE ADJUSTMENT WHEN LL IS TOO SMALL.
C
      M = M - IONE
      LL = ITEN * LL
 240  IF (ITYPE.EQ.8 .OR. ITYPE.EQ.ITEN) LL = LL - IFIVE
      IF (ITYPE.LT.IFIVE) GO TO 290
      IF (ITYPE.EQ.IFIVE .OR. ITYPE.EQ.6) GO TO 300
C
C     ..................................................................
C
C     (4)   FIXED AND INTEGER.
C
C     CHECK FOR OVERFLOW.
C
      IF (M.GT.NDIFF-ITWO) GO TO 270
      IF (M.EQ.NDIFF-ITWO .AND. XVALUE.LT.RZERO) GO TO 270
C
C     ADJUST NUMBER OF DIGITS (NSIGDS) AND LL.
C
      NSIGDS = MIN0 (NDIGIT,IDECS+M+IONE)
      NSIGDS = MAX0 (IZERO,NSIGDS)
      IF (ITYPE.EQ.7 .OR. ITYPE.EQ.9) LL = LL - IFIVE
      CALL IDIV (LL,ITEN**(NDIGIT-NSIGDS),IND,LLTEMP)
      LTEMP=LL
      IF (ITYPE.EQ.7 .OR. ITYPE.EQ.9) LL = LL + IFIVE
      IF (LL.LT.ITEN**(NSIGDS+IONE)) GO TO 250
C
C     ADJUST FOR XVALUE ROUNDED TO ONE MORE DIGIT.
C
      M = M + IONE
      NSIGDS = MIN0 (NDIGIT,IDECS+M+IONE)
      NSIGDS = MAX0 (IZERO,NSIGDS)
C
C     CHECK FOR OVERFLOW CAUSED BY ROUNDING TO ONE MORE DIGIT.
C
      IF (M.GT.NDIFF-ITWO) GO TO 270
      IF (M.EQ.NDIFF-ITWO .AND. XVALUE.LT.RZERO) GO TO 270
C
C     CHECK FOR UNDERFLOW.
C
 250  IF (NSIGDS.GT.IZERO) GO TO 310
C
C     ADJUST FOR UNDERFLOW.  XVALUE ROUNDED TO IDECS EQUALS ZERO.
C
      IF (IDECS.EQ.IZERO) NALPHA(NPONE-1) = LA(1)
C
      DO 260 I=NPONE,LTOTAL
        NALPHA(I) = LA(1)
 260  CONTINUE
C
      NALPHA(NPONE) = LA(38)
      GO TO 390
C
C     ..................................................................
C
C     PUT IN ASTERISKS WHEN OVERFLOW OCCURS.
C
 270  IE = ITEN
      DO 280 I=1,NW
        ISUBSC = I + NBLANK
        NALPHA(ISUBSC) = LA(41)
 280  CONTINUE
      GO TO 390
C
C     ..................................................................
C
C     (5)   CHECK WHETHER R FORMAT IS FORCED INTO E FORMAT.
C
 290  IF (M.GE.NSIGDS-IONE-IDECS .AND. M.LT.NDIFF-ITWO) GO TO 310
      IF (M.EQ.NDIFF-ITWO .AND. XVALUE.GT.RZERO) GO TO 310
        IE = 11
      IF (NW.GE.NDIGIT+IFIVE .AND. ND.GE.NDIGIT+ITWO) GO TO 300
        IE = 13
      IF (NW.GE.NDIGIT+IFIVE) GO TO 390
        IE = 12
        GO TO 390
C
C     ..................................................................
C
C     (6)   FLOATING.
C
 300  MREAL = M
      M = IZERO
      MF = IONE
C
C     ..................................................................
C
C     (7)   STORE REPRESENTATION IN NALPHA.
C
 310  IF (M.LT.NSIGDS .AND. ITYPE.LT.9) NALPHA(NPONE) = LA(38)
      NINT = NPONE - IONE - M
      IF (M.LT.IZERO) NINT = NINT + IONE
      NEND = NINT + NSIGDS - IONE
      IF (M.GE.IZERO .AND. M.LT.NSIGDS-IONE) NEND = NEND + IONE
      DO 320 J=NINT,NEND
        I = NEND + NINT - J
        IF (I.EQ.NPONE) GO TO 320
        CALL IDIV (LL,ITEN,IND,LLTEMP)
        LL = LTEMP
        NN = MOD (LL,ITEN)
        NALPHA(I) = LA(NN+1)
 320  CONTINUE
C
      IF (MF.EQ.IZERO) GO TO 340
C
C     ..................................................................
C
C     (8)   PUT IN EXPONENT FOR FLOATING POINT NUMBER.
C
      IF (ITYPE.EQ.IONE .OR. ITYPE.EQ.ITWO .OR. ITYPE.EQ.IFIVE) GOTO 330
C
C     CHANGE FROM 1PE TO 0PE
C
      NALPHA(NINT+1) = NALPHA(NINT)
      NALPHA(NINT  ) = LA(38)
      MREAL = MREAL + IONE
C
 330  IF (MREAL.LT.IZERO) NALPHA(NEND+1) = LA(39)
      IF (MREAL.GE.IZERO) NALPHA(NEND+1) = LA(40)
      MREALA = IABS(MREAL)
      CALL IDIV (MREALA,ITEN,IND,M1)
      M2 = MOD (MREALA,ITEN)
      NALPHA(NEND+2) = LA(M1+1)
      NALPHA(NEND+3) = LA(M2+1)
C
C     ..................................................................
C
C     (9)   PUT IN MINUS SIGN IF XVALUE LESS THAN ZERO.
C
 340  IF (XVALUE.GE.RZERO) GO TO 350
        IF (M.GE.IZERO) NALPHA(NINT-1) = LA(39)
        IF (M.LT.IZERO) NALPHA(NPONE-1) = LA(39)
 350  IF (M.GE.(-IONE)) GO TO 370
C
C     PUT ZEROS AFTER DECIMAL POINT FOR ABSXVA LESS THAN 0.1
C
      IBEG = NPONE + IONE
      IEND = NINT - IONE
      DO 360 I=IBEG,IEND
        NALPHA(I) = LA(1)
 360  CONTINUE
      GO TO 390
C
C     ..................................................................
C
C     (10)   PUT IN NON-SIGNIFICANT ZEROS FOR LARGE INTEGERS.
C
 370  IF (M.LT.NSIGDS .OR. MF.NE.IZERO) GO TO 390
      IBEG = NINT + NSIGDS
      IEND = NPONE - IONE
      DO 380 I=IBEG,IEND
        NALPHA(I) = LA(1)
 380  CONTINUE
C
C     ..................................................................
C
 390  KW = NW
      KD = ND
      KE = IE
      IF (IE.EQ.IZERO .OR. IE.EQ.IFIVE .OR. IE.EQ.6 .OR. IE.EQ.ITEN
     1                .OR. IE.EQ.11    .OR. IE.GE.14) RETURN
CCCCC   CALL ERROR (259)
        RETURN
C
C     ==================================================================
C
      END
*SCREEN
      SUBROUTINE SCREEN(RR,KX,NR,NDEF,IBIT,MBST,INTCPT,A,NS)
C
C **  NBS OMNITAB 1980 VERSION 6.01  1/ 1/81. SCREEN V 7.00  4/21/92. **
C
C     ==================================================================
C
C                        ***   GENERAL COMMENTS   ***
C
C     **************************************************************** *
C                                                                      *
C                   REGRESSIONS BY LEAPS AND BOUNDS                    *
C          A PROGRAM FOR FINDING THE BEST SUBSET REGRESSIONS           *
C                     G.M.FURNIVAL AND R.W.WILSON                      *
C               YALE UNIVERSITY AND U.S. FOREST SERVICE                *
C                           VERSION 11/11/74                           *
C                                                                      *
C                 CALL SCREEN(RR,KX,NR,NDEF,IBIT,MBST)                 *
C                                                                      *
C     RR   = UPPER TRIANGULAR PORTION OF (KX+1)*(KX+1) CORRELATION OR  *
C            PRODUCT MATRIX. VARIABLE KX+1 IS THE DEPENDENT VARIABLE.  *
C     KX   = NUMBER OF INDEPENDENT VARIABLES (3.LE.KX.LE.28)           *
C     NR   = DIMENSION OF RR (NR.GT.KX)                                *
C     NDEF = DEGREES OF FREEDOM FOR RR (NDEF.GT.KX)                    *
C     IBIT = SELECTION CRITERION CODE (1=R**2,2=ADJUSTED R**2,3=CP)    *
C     MBST = NUMBER OF BEST REGRESSIONS DESIRED (1.LE.MBST.LE.10)      *
C                                                                      *
C       MBST BEST REGRESSIONS FOR EACH SIZE SUBSET WHEN IBIT.EQ.1      *
C             MBST BEST REGRESSIONS IN TOTAL WHEN IBIT.GT.1            *
C                                                                      *
C     **************************************************************** *
C
C     ARRAY STORAGE REQUIRED FOR K=KX INDPENDENT VARIABLES AND M = K+1.
C         2*NL FOR XI AND XN, WHERE NL = M(M+1)(M+2)/6
C        4M**2 FOR ILI, ILM, MD AND NC
C      2*(11M) FOR CL AND RM
C          12M FOR CI, CN, CO, ID, IPI, IPN, NI, NN, TOLL, YI, YN AND ZC
C
C     TOTAL STORAGE EQUALS 2M(M+1)(M+2)/6 + 4M**2 +22M + 12M
C                   = (M**3 + 15*M**2 + 104*M)/3
C
C              ***   ARRAY STORAGE EQUIVALENCE TO A(.)  ***
C
C                 ARRAY             SIZE                  START
C
C                   XI               NL                       1
C                   XN               NL                    NL+1
C                 .............................................
C                  ILI             M**2           2*NL+       1
C                  ILN             M**2           2*NL+  M**2+1
C                   MD             M**2           2*NL+2*M**2+1
C                   NC             M**2           2*NL+3*M**2+1
C                 .............................................
C                   CL             11*M      2*NL+4*M**2+     1
C                   RM             11*M      2*NL+4*M**2+11*M+1
C                 .............................................
C                   CI                M      2*NL+4*M**2+22*M+1
C                   CN                M      2*NL+4*M**2+23*M+1
C                   CO                M      2*NL+4*M**2+24*M+1
C                   ID                M      2*NL+4*M**2+25*M+1
C                  IPI                M      2*NL+4*M**2+26*M+1
C                  IPN                M      2*NL+4*M**2+27*M+1
C                   NI                M      2*NL+4*M**2+28*M+1
C                   NN                M      2*NL+4*M**2+29*M+1
C                 TOLL                M      2*NL+4*M**2+30*M+1
C                   YI                M      2*NL+4*M**2+31*M+1
C                   YN                M      2*NL+4*M**2+32*M+1
C                   ZC                M      2*NL+4*M**2+33*M+1
C                 .............................................
C
C               ADAPTED TO OMNITAB COMPUTING SYSTEM BY -
C                      DAVID HOGBEN,
C                      STATISTICAL ENGINEERING DIVISION,
C                      COMPUTING AND APPLIED MATHEMATICS LABORATORY,
C                      A337 ADMINISTRATION BUILDING,
C                      NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY,
C                      GAITHERSBURG, MD 20899
C                          TELEPHONE 301-921-3651
C                  ORIGINAL VERSION - FEBRUARY, 1977.
C                   CURRENT VERSION -    APRIL, 1992.
C
C     ==================================================================
C
C                    ***   SPECIFICATION STATEMENTS   ***
C
      PARAMETER (MAXC=40)
C
CCCCC DIMENSION     ID(29),    IPI(29),   IPN(29),    NI(29),    NN(29)
      DIMENSION  ID(MAXC),  IPI(MAXC),  IPN(MAXC),  NI(MAXC),  NN(MAXC)
      DIMENSION ILI(845), ILN(845), MD(845), NC(845)
C
CCCCC INCLUDE 'WRKSCR.H'
      REAL A(NS)
C
C     ==================================================================
C
C                         ***   TYPE STATEMENTS   ***
C
CCCCC REAL             RR(29,29)
      REAL             RR(MAXC,MAXC)
      REAL             BOUND, CAB, RS, R2
      REAL             SIG, SS, TEMP, TOL, TWO
      REAL             FDIV
      REAL             SPCA, SPCB
C
C     ..................................................................
C
      DOUBLE PRECISION DTWO
C
      PARAMETER (MAXV=38)
      CHARACTER*1 ICOD(MAXV)
      CHARACTER*38 IOUT
      CHARACTER*8 IVLIST
      COMMON/BESTC1/IOUNI1,IOUNI2
      COMMON/BESTC2/IVLIST(MAXV)
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     ==================================================================
C
C                 ***   DATA INITIALIZATION STATEMENTS   ***
C
      DATA DTWO  / 2.0D0 /
C
      DATA RTWO  / 2.0 /
      DATA RONE  / 1.0 /
      DATA RZERO / 0.0 /
      DATA RER   / 1.0E-8 /
C
      DATA IFOUR  /4/
      DATA ITHRE  /3/
      DATA ITWO   /2/
      DATA IONE   /1/
      DATA IZERO  /0/
      DATA LWIDE  /80/
C
      DATA KO, NV / 10, 11 /
C
      DATA SPCA /   100.0 /
      DATA SPCB / 10000.0 /
C
      DATA ICOD(1) /'1'/
      DATA ICOD(2) /'2'/
      DATA ICOD(3) /'3'/
      DATA ICOD(4) /'4'/
      DATA ICOD(5) /'5'/
      DATA ICOD(6) /'6'/
      DATA ICOD(7) /'7'/
      DATA ICOD(8) /'8'/
      DATA ICOD(9) /'9'/
      DATA ICOD(10) /'0'/
      DATA ICOD(11) /'A'/
      DATA ICOD(12) /'B'/
      DATA ICOD(13) /'C'/
      DATA ICOD(14) /'D'/
      DATA ICOD(15) /'E'/
      DATA ICOD(16) /'F'/
      DATA ICOD(17) /'G'/
      DATA ICOD(18) /'H'/
      DATA ICOD(19) /'I'/
      DATA ICOD(20) /'J'/
      DATA ICOD(21) /'K'/
      DATA ICOD(22) /'L'/
      DATA ICOD(23) /'M'/
      DATA ICOD(24) /'N'/
      DATA ICOD(25) /'O'/
      DATA ICOD(26) /'P'/
      DATA ICOD(27) /'Q'/
      DATA ICOD(28) /'R'/
      DATA ICOD(29) /'S'/
      DATA ICOD(30) /'T'/
      DATA ICOD(31) /'U'/
      DATA ICOD(32) /'V'/
      DATA ICOD(33) /'W'/
      DATA ICOD(34) /'X'/
      DATA ICOD(35) /'Y'/
      DATA ICOD(36) /'Z'/
      DATA ICOD(37) /'a'/
      DATA ICOD(38) /'b'/
C
C     ==================================================================
C
C     10=KO=NV-1     NL=(KX+1)*(KX+2)*(KX+3)/6      ND-1=NR-1
C                          NX=(KX+1)*(KX+2)/2
C
C                                 SET UP SIZE OF KZ, ND, NL AND NX.
C
      KZ = KX + IONE
      ND = KZ
      CALL IDIV (ND * (ND + IONE) * (ND + ITWO),6,IND,NL)
      CALL IDIV (ND * (ND + IONE),ITWO,IND,NX)
C
C                                 TEST INPUT.
C
      KZSIZE = ITWO * NL + IFOUR * ND ** 2 + 34 * ND
      IF (KZSIZE.GT.NS) THEN
         WRITE(ICOUT,23)
         CALL DPWRST('XXX','BUG ')
CCCCC    CALL ERROR (23)
         RETURN
      ENDIF
   23 FORMAT(1X,'***** ERROR FROM SCREEN (BEST CP): INSUFFICIENT ',
     1      'SCRATCH SPACE.')
CCCCC IF (NERROR.NE.IZERO) RETURN
C
C     ..................................................................
C
      IF (KX.GE.ITHRE .AND. KX.LT.ND .AND. NDEF.GT.KX .AND.
     1     MBST.GT.IZERO .AND. MBST.LE.KO .AND. KO.LE.NV .AND. NR.GT.KX
     2     .AND. IBIT.GE.IONE .AND. IBIT.LE.ITHRE) GO TO 10
CCCCC CALL ERROR (3)
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
    3 FORMAT(1X,'***** ERROR FROM SCREEN (BEST CP): INVALID OPTIONS')
      RETURN
C
C     ..................................................................
C
  10  SS = FDIV (RR(KZ,KZ),SPCA,IND)
      IF (IBIT.EQ.ITWO) SS = FDIV (SS,FLOAT(NDEF),IND)
      IF (SS.GT.RZERO) GO TO 30
  20  CONTINUE
CCCCC CALL ERROR (22)
      WRITE(ICOUT,22)
      CALL DPWRST('XXX','BUG ')
   22 FORMAT(1X,'***** ERROR FROM SCREEN (BEST CP): NON-POSITIVE SUM ',
     1      'OF SQUARES')
      RETURN
C
C     ..................................................................
C
C                                 INITIALIZE.
C
  30  LSUBXI = IONE
      LSUBXC = IONE
      LSUBXN = NL + IONE
      LSUBLI = ITWO * NL + IONE
      LSUBLN = LSUBLI + KZ ** 2
      LSUBMD = LSUBLN + KZ ** 2
      LSUBNC = LSUBMD + KZ ** 2
      LSUBCL = LSUBNC + KZ ** 2
      LSUBRM = LSUBCL + 11 * KZ
      LSUBCI = LSUBRM + 11 * KZ
      LSUBCN = LSUBCI + KZ
      LSUBCO = LSUBCN + KZ
      LSUBID = LSUBCO + KZ
      LSUBPI = LSUBID + KZ
      LSUBPN = LSUBPI + KZ
      LSUBNI = LSUBPN + KZ
      LSUBNN = LSUBNI + KZ
      LSUBTL = LSUBNN + KZ
      LSUBYI = LSUBTL + KZ
      LSUBYN = LSUBYI + KZ
      LSUBZC = LSUBYN + KZ
      A(LSUBCN)  = RZERO
      A(LSUBCI)  = RZERO
      TOL    = FDIV (RER,SPCB,IND)
      TWO    = RTWO * RR(KZ,KZ) * FLOAT(NDEF)
      LOW    = KO - MBST + IONE
      LISUBL = IONE
      LNSUBL = IONE
      MDSUBL = IONE
      NCSUBL = IONE
      IDSUBL = IONE
      NPSUBL = IONE
      IPSUBL = IONE
      NISUBL = IONE
      NNSUBL = IONE
      ISUBLI = LISUBL
      ISUBNC = NCSUBL
      ISUBCL = LSUBCL
      ISUBRM = LSUBRM
      ISUBCO = LSUBCO
      KSUBRM = LSUBRM + KO
      ISUBID = IDSUBL
      ISUBPN = NPSUBL
      ISUBTL = LSUBTL
C
C  FOR DATAPLOT, SET NTLINE HIGH.  THAT IS, WE ARE NOT USING A PAGE
C  BASED OUTPUT.
C
      NTLINE = 500
C
CCCCC IF (NCRT.NE.IZERO) NTLINE = LENGTH + ITHRE
      DO 50 L=1,KZ
        CALL IDIV ((KZ-IONE)*KZ*(KZ+IONE)-(KZ-L)*(KZ-L+IONE)*
     1                (KZ-L+ITWO),6,IND,ID(ISUBID))
        IPN(ISUBPN)  = IONE
        ILI(ISUBLI)  = L
        A(KSUBRM)   = -TWO
        KSUBRM       = KSUBRM + 11
        A(ISUBCO)   = DTWO**(KX-L)
        NC(ISUBNC)   = L
        A(ISUBTL) = TOL * RR(L,L)
        IF (A(ISUBTL).LE.RZERO) GO TO 20
        JSUBCL = ISUBCL
        JSUBRM = ISUBRM
        DO 40 M=1,KO
          A(JSUBCL) = RZERO
          A(JSUBRM) = TWO
          JSUBCL     = JSUBCL + IONE
          JSUBRM     = JSUBRM + IONE
  40    CONTINUE
        ISUBCL = ISUBCL + 11
        ISUBRM = ISUBRM + 11
        ISUBCO = ISUBCO + IONE
        ISUBLI = ISUBLI + KZ
        ISUBNC = ISUBNC + KZ
        ISUBID = ISUBID + IONE
        ISUBPN = ISUBPN + IONE
        ISUBTL = ISUBTL + IONE
  50  CONTINUE
C
C                           STORE MATRICES AS VECTORS.
C
      LS     = IZERO
      ISUBXC = LSUBXC - IONE
      ISUBXN = LSUBXN
      ISUBMD = MDSUBL
      MSUBMD = MDSUBL - IONE
      DO 70 L=1,KZ
        KSUBMD = ISUBMD
        JSUBMD = MSUBMD + KZ * (L - IONE) + L
        DO 60 M=L,KZ
          LS         = LS + IONE
          ISUBXC     = ISUBXC + IONE
          MD(KSUBMD) = LS
          MD(JSUBMD) = LS
          A(ISUBXC) = RR(L,M)
          A(ISUBXN) = A(ISUBXC)
          RR(M,L)    = RR(L,M)
          ISUBXN     = ISUBXN + IONE
          KSUBMD     = KSUBMD + KZ
          JSUBMD     = JSUBMD + IONE
  60    CONTINUE
        ISUBMD = ISUBMD + IONE + KZ
  70  CONTINUE
C
C                             INVERT MATRIX STEPWISE.
C
      ISUBMD = MDSUBL + KZ ** 2 - IONE
      ISUB2  = MD(ISUBMD) + LSUBXC - IONE
      NSUBLI = LISUBL
      NSUBLN = LNSUBL
      NSUBMD = MDSUBL + KZ * (KZ - IONE) - IONE
      ISUBRM = LSUBRM - IONE + KO
      MSUBRM = LSUBRM
      ISUBCO = LSUBCO - IONE
      DO 90 N=1,KX
        J      = IZERO
        N1     = N
        ISUBLI = NSUBLI
        DO 80 LA=N,KX
          L      = ILI(ISUBLI)
          ISUBLI = ISUBLI + KZ
          ISUBMD = MDSUBL + KZ * (L -IONE) - IONE
          MSUBMD = NSUBMD + L
          ISUBMD = ISUBMD + L
          ISUBTL = LSUBTL + L - IONE
          ISUB1  = MD(ISUBMD) + LSUBXC - IONE
          IF (A(ISUB1).LT.A(ISUBTL)) GO TO 80
          ISUB3 = MD(MSUBMD) + LSUBXC - IONE
          RS = A(ISUB2) - FDIV (A(ISUB3)*A(ISUB3),A(ISUB1),IND)
          IF (RS.LT.A(ISUBRM)) J = LA
          MSUBCO = ISUBCO + L
          IF (RS.LT.A(MSUBRM)) CALL CPSTRE (RS,A(LSUBCI)+A(MSUBCO),
     1                                KO,A(LSUBCL),A(LSUBRM),N1,NV,ND)
  80    CONTINUE
        IF (J.EQ.IZERO) GO TO 100
        JSUBLI      = LISUBL + KZ * (J -IONE)
        M           = ILI(JSUBLI)
        ILI(JSUBLI) = ILI(NSUBLI)
        ILI(NSUBLI) = M
        ILN(NSUBLN) = M
        MSUBCO      = ISUBCO + M
        A(LSUBCI)  = A(LSUBCI) + A(MSUBCO)
        NSUBLI      = NSUBLI + KZ
        NSUBLN      = NSUBLN + KZ
        ISUBRM      = ISUBRM + 11
        MSUBRM      = MSUBRM + 11
        CALL PIVOT (A(LSUBXC),KZ,M,MD(MDSUBL),ND,NX)
  90  CONTINUE
C
      N      = KZ
 100  K      = N - IONE
      KP     = KZ * K + LISUBL
      KXSUBL = KZ * (KX - IONE) + LISUBL
      IF (K.NE.KX) THEN
         ICNT=0
         DO102I=KP,KXSUBL,KZ
           ICNT=ICNT+1
           IF(ICNT.EQ.22)ILAST=I
           IF(ICNT.EQ.23)IFRST=I
  102    CONTINUE
         WRITE (ICOUT,330) (ILI(I),I=KP,KXSUBL,KZ)
         CALL DPWRST('XXX','BUG ')
         IF(ICNT.LE.22)THEN
           WRITE (ICOUT,331) (ILI(I),I=KP,KXSUBL,KZ)
           CALL DPWRST('XXX','BUG ')
         ELSE
           WRITE (ICOUT,331) (ILI(I),I=KP,KXSUBL,ILAST)
           CALL DPWRST('XXX','BUG ')
           WRITE (ICOUT,331) (ILI(I),I=IFRST,KXSUBL,KZ)
           CALL DPWRST('XXX','BUG ')
         ENDIF
      ENDIF
      IF (K.LT.ITHRE) RETURN
      KM = K - IONE
C
C     INTCPT - IONE = ADJUSTMENT FOR USING WITH NO CONSTANT TERM.
C
      SIG    = FDIV (RTWO*A(ISUBXC),FLOAT(NDEF-K+IONE-INTCPT),IND)
      A(LSUBYI)  = A(ISUBXC)
      A(LSUBYN)  = RR(KZ,KZ)
C
      NI(NISUBL) = K
      NN(NNSUBL) = K
      ISUBCL     = LSUBCL - IONE
      ISUBRM     = LSUBRM
      KSUBRM     = LSUBRM + 11 * (KZ - IONE)
      IF (IBIT.EQ.IONE) GO TO 130
      DO 120 M=1,K
        MSUBCL = ISUBCL
        MSUBRM = ISUBRM
        DO 110 L=1,KO
          IF (IBIT.EQ.ITWO)  RS = FDIV (A(MSUBRM),FLOAT(NDEF-M),IND)
          IF (IBIT.EQ.ITHRE) RS = A(MSUBRM) + SIG * FLOAT (M)
          MSUBCL = MSUBCL + IONE
          MSUBRM = MSUBRM + IONE
          IF (RS.GE.A(KSUBRM)) GO TO 110
          TEMP   = A(MSUBCL)
          CALL CPSTRE (RS,TEMP,KO,A(LSUBCL),A(LSUBRM),KZ,NV,ND)
 110    CONTINUE
        ISUBCL = ISUBCL + 11
        ISUBRM = ISUBRM + 11
 120  CONTINUE
C
 130  NREG =  IZERO
      NCAL =  ITWO
      MN   =  ITWO
      MV   = -IONE
C
C                                 STAGE  LOOP.
C
 140  CONTINUE
      JSUBRM = KSUBRM
      IF (MN.EQ.IONE) GO TO 240
      ISUBPN      = NPSUBL + MN - IONE
      IP          = IPN(ISUBPN)
      IPN(ISUBPN) = IP + IONE
      MV          = MV - IPN(ISUBPN+1) + IP + ITWO
      ISUBPI      = IPSUBL + MV - IONE
      IPI(ISUBPI) = IP
      MN          = MN - IONE
      ISUBPN      = ISUBPN - IONE
      IN          = IPN(ISUBPN)
      JC          = MV
      ISUBYI      = LSUBYI + IP - IONE
      BOUND       = A(ISUBYI)
      A(ISUBYI)  = TWO
C
C                              FIND LEAP FROM BOUNDS.
C
      ISUBRM = LSUBRM + LOW - IONE
      KSUBRM = LSUBRM + 11 * (KZ - IONE) + LOW - IONE
      DO 150 LB=IP,KM
        MT     = MN + KM - LB
        MSUBRM = ISUBRM + 11 * (MT - IONE)
        IF (IBIT.EQ.IONE .AND. A(MSUBRM).GT.BOUND) GO TO 160
        IF (IBIT.EQ.ITWO .AND. A(KSUBRM).GT.FDIV(BOUND,FLOAT(NDEF-MT),
     1     IND)) GO TO 160
        IF (IBIT.EQ.ITHRE .AND. A(KSUBRM).GT.BOUND+SIG*FLOAT(MT))
     1           GO TO 160
 150  CONTINUE
      GO TO 140
C
 160  LC = KM + IP - LB
      NREG = NREG + ITWO * (LC-IP+IONE)
      IF (IP.EQ.IONE) LC = K
C
C                         REGRESSIONS FROM INVERSE MATRIX.
C
      ISUBNI = NISUBL + IP
      ISUBNN = NNSUBL + IP
      KSUBLI = LISUBL + IP - IONE
      KSUBLN = LNSUBL + IN - IONE
      KSUBNN = NNSUBL + IN - IONE
      DO 200 LB=IP,LC
        LBB = LB
        CALL BACK (NC(NCSUBL),LBB,LI,IPI(IPSUBL),MV,RS,BOUND,ILI(LISUBL)
     1            ,JC,ID(IDSUBL),A(LSUBXI),MD(MDSUBL),
     2             IONE,NI(NISUBL),ND,KZ,NL,NCAL)
C
C                               RE-ORDER VARIABLES.
C
        M      = LB
        MSUBLN = KSUBLN + KZ * (M - IONE)
        MSUBLI = KSUBLI + KZ * (M - IONE)
        ISUBYI = LSUBYI + M - IONE
        IF (LB.GT.NN(KSUBNN)) GO TO 190
        LN = ILN(MSUBLN)
 170    IF (RS.LE.A(ISUBYI)) GO TO 180
        A(ISUBYI+1) = A(ISUBYI)
        NSUBLI       = MSUBLI - KZ
        NSUBLN       = MSUBLN - KZ
        ILI(MSUBLI)  = ILI(NSUBLI)
        ILN(MSUBLN)  = ILN(NSUBLN)
        M            = M - IONE
        MSUBLI       = MSUBLI - KZ
        MSUBLN       = MSUBLN - KZ
        ISUBYI       = ISUBYI - IONE
        GO TO 170
 180    ILI(MSUBLI)  = LI
        ILN(MSUBLN)  = LN
 190    A(ISUBYI+1) = RS
        NI(ISUBNI)   = LB
        NN(ISUBNN)   = LB
        ISUBNI       = ISUBNI + IONE
        ISUBNN       = ISUBNN + IONE
 200  CONTINUE
      IF (LC.EQ.K) LC = KM
      MI = K - MV
      JC = MN
C
C                         REGRESSIONS FROM PRODUCT MATRIX.
C
      ISUBRM = LSUBRM + 11 * (MI - IONE)
      KSUBRM = LSUBRM + 11 * (KZ - IONE)
      ISUBCI = LSUBCI + IP - IONE
      ISUBYI = LSUBYI + IP - IONE
      ISUBYN = LSUBYN + IP - IONE
      ISUBCO = LSUBCO - IONE
      DO 230 LB=IP,LC
        LBB        = LB
        ISUBCN     = LSUBCN + IN - IONE
        ISUBNC     = NCSUBL + IN - IONE
        KSUBYN     = LSUBYN + IN - IONE
        ISUBYI     = ISUBYI + IONE
        ISUBYN     = ISUBYN + IONE
        IS         = LB + IONE
        MSUBCN     = LSUBCN + LB
        A(MSUBCN) = A(KSUBYN)
        CALL BACK (NC(NCSUBL),LBB,L,IPN(NPSUBL),MN,A(ISUBYN),A(MSUBCN)
     1            ,ILN(LNSUBL),JC,ID(IDSUBL),A(LSUBXN),MD(MDSUBL),
     2             IZERO,NN(NNSUBL),ND,KZ,NL,NCAL)
        MSUBNC     = ISUBNC + KZ * (L - IONE)
        ISUB4      = NC(MSUBNC)
        MSUBCI     = LSUBCI + LB
        MSUBCO     = ISUBCO + ISUB4
        A(MSUBCI) = A(ISUBCI) - A(MSUBCO)
        A(MSUBCN) = A(ISUBCN) + A(MSUBCO)
        IF (A(ISUBYI).GE.A(ISUBRM)) GO TO 210
        CALL CPSTRE (A(ISUBYI),A(MSUBCI),KO,A(LSUBCL),A(LSUBRM),MI,
     1               NV,ND)
        IF (IBIT.EQ.IONE) GO TO 210
        IF (IBIT.EQ.ITWO) RS = FDIV (A(ISUBYI),FLOAT(NDEF-MI),IND)
        IF (IBIT.EQ.ITHRE) RS = A(ISUBYI) + FLOAT(MI) * SIG
        IF (RS.LT.A(KSUBRM)) CALL CPSTRE (RS,A(MSUBCI),KO,A(LSUBCL),
     1      A(LSUBRM),KZ,NV,ND)
 210    MSUBRM = LSUBRM + 11 * (MN - IONE)
        IF (A(ISUBYN).GE.A(MSUBRM)) GO TO 220
        CALL CPSTRE (A(ISUBYN),A(MSUBCN),KO,A(LSUBCL),A(LSUBRM),MN,
     1               NV,ND)
        IF (IBIT.EQ.IONE) GO TO 220
        IF (IBIT.EQ.ITWO) RS = FDIV (A(ISUBYN),FLOAT(NDEF-MN),IND)
        IF (IBIT.EQ.ITHRE) RS = A(ISUBYN) + FLOAT(MN) * SIG
        IF (RS.LT.A(KSUBRM)) CALL CPSTRE (RS,A(MSUBCN),KO,A(LSUBCL),
     1      A(LSUBRM),KZ,NV,ND)
 220    MN            = MN + IONE
        ISUBPN        = NPSUBL + MN - IONE
        IPN(ISUBPN+1) = IPN(ISUBPN) + IONE
        IN            = IS
 230  CONTINUE
      IF (LC.EQ.KM) MN = MN - IONE
      GO TO 140
C
C                                    OUTPUT.
C
 240  CONTINUE
      CALL IDIV (KX-IONE,ITWO,IND,NJUNK)
      NLINES = 8 + NJUNK
      ISUBCL = LSUBCL - 12
      ISUBRM = LSUBRM - 12
      DO 320 M=1,K
        MM     = M
        ISUBCL = ISUBCL + 11
        ISUBRM = ISUBRM + 11
        IF (NLINES+ITHRE.LE.NTLINE) GO TO 250
CCCCC   CALL PAGE (IFOUR)
        NLINES = ITHRE
 250    IF (KO.GT.IONE .AND. M.EQ.IONE) THEN
           WRITE (ICOUT,390)
           CALL DPWRST('XXX','BUG ')
        ENDIF
        IF (KO.GT.IONE .AND. M.GT.IONE) THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE (ICOUT,340) M
            CALL DPWRST('XXX','BUG ')
        ENDIF
        NLINES = NLINES + ITWO
        IPRTSW = IZERO
        DO 310 LA=1,KO
          NCOF   = IONE
          L      = KO - LA + IONE
          MSUBRM = ISUBRM + L
          IF (A(MSUBRM).EQ.TWO) GO TO 320
          IF (IBIT.EQ.IONE)  R2 = SPCA - FDIV (A(MSUBRM),SS,IND)
          IF (IBIT.EQ.ITWO)  RS = FDIV (A(MSUBRM),FLOAT(NDEF-M),IND)
          IF (IBIT.EQ.ITHRE) RS = A(MSUBRM) + SIG * FLOAT(M)
          IF (IBIT.EQ.IONE .AND. LA.LE.MBST .OR. IBIT.GT.IONE
     1         .AND. RS.LE.A(JSUBRM)) NCOF = IZERO
          IF (IBIT.EQ.ITWO)  R2 = SPCA - FDIV (RS,SS,IND)
          IF (IBIT.EQ.ITHRE) R2 = RTWO * FDIV (RS,SIG,IND) - FLOAT(NDEF)
C
C           ADJUSTMENT TO ALLOW USE OF MODEL WHICH DOES NOT HAVE
C              A CONSTANT TERM FOR THE FIRST TERM.
C                 CHANGE SUGGESTED BY JAMES W. FRANE.
C
          IF  (IBIT.EQ.ITHRE .AND. INTCPT.EQ.IZERO) R2 = R2 - RONE
          IF  (IBIT.EQ.ITHRE .AND. INTCPT.EQ.IONE ) R2 = R2 + RONE
C
C                               DECODE LABELS.
C
          MSUBCL = ISUBCL + L
          CAB    = A(MSUBCL)
          MP     = IONE
          ISUBCO = LSUBCO - IONE
          ISUBPN = NPSUBL
          DO 260 I=1,KX
            ISUBCO      = ISUBCO + IONE
            IF (CAB.LT.A(ISUBCO)) GO TO 260
            IPN(ISUBPN) = I
            MP          = MP + IONE
            CAB         = CAB - A(ISUBCO)
            ISUBPN      = ISUBPN + IONE
 260      CONTINUE
C
          IF (NCOF.NE.IZERO) GO TO 280
          NLINES = NLINES + M + ITHRE
          IF (NLINES.LE.NTLINE) GO TO 270
CCCCC     CALL PAGE (IFOUR)
          NLINES = M + 6
 270      CONTINUE
          CALL COEF (R2,MP,KZ,A(LSUBXC),RR,MAXC,IPN(NPSUBL),NDEF,MM,ND,
     1               MD(MDSUBL),NX,IBIT,A(LSUBZC))
          GO TO 310
 280      IF (IPRTSW.GT.IZERO) GO TO 300
          NLINES = NLINES + M + IONE
          IF (M.GT.15 .AND. LWIDE.LT.110) NLINES = NLINES + M
          IF (NLINES.LE.NTLINE) GO TO 290
CCCCC       CALL PAGE (IFOUR)
            NLINES = M + IFOUR
            IF (M.GT.15 .AND. LWIDE.LT.110) NLINES = NLINES + M
 290      CONTINUE
          WRITE (ICOUT,350)
          CALL DPWRST('XXX','BUG ')
          IPRTSW = IONE
 300      ISTPPN = NPSUBL + M - IONE
          IJUNK=1
          IF(M.EQ.IONE)THEN
            WRITE(IOUNI1,71)IJUNK,R2,IVLIST(IPN(NPSUBL))
  71        FORMAT(I3,1X,F7.3,' : ',A8)
            WRITE(IOUNI2,'(A1)')ICOD(IPN(NPSUBL))
          ENDIF
          IF (LWIDE.GE.110) THEN
             WRITE (ICOUT,360) R2, (IPN(I),I=NPSUBL,ISTPPN)
             CALL DPWRST('XXX','BUG ')
          ELSEIF (LWIDE.LT.110) THEN
             INUMB=ISTPPN-NPSUBL+1
             IF(INUMB.LE.15)THEN
               WRITE (ICOUT,370) R2, (IPN(I),I=NPSUBL,ISTPPN)
               CALL DPWRST('XXX','BUG ')
             ELSE
               ITEMP1=NPSUBL+14
               WRITE (ICOUT,370) R2, (IPN(I),I=NPSUBL,ITEMP1)
               CALL DPWRST('XXX','BUG ')
               WRITE (ICOUT,371) R2, (IPN(I),I=ITEMP1+1,ISTPPN)
               CALL DPWRST('XXX','BUG ')
             ENDIF
          ENDIF
 310    CONTINUE
 320  CONTINUE
      NCAL = NCAL + ITWO * NREG
      WRITE (ICOUT,380) NREG, NCAL
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ==================================================================
C
C                       ***   FORMAT STATEMENTS   ***
C
 330  FORMAT(2X,'SCREEN-MATRIX IS SINGULAR.  VARIABLES DELETED ARE ...')
 331  FORMAT(5X,22I3)
 340  FORMAT(4X,'REGRESSIONS WITH',I3,' VARIABLES')
 350  FORMAT(10X,'C(P) STATISTIC',2X,'VARIABLES')
 360  FORMAT(13X,F8.3,5X,28I3)
 370  FORMAT(14X,F8.3,3X,15I3)
 371  FORMAT(26X,15I3)
 380  FORMAT(2X,I9,' REGRESSIONS',2X,I10,' OPERATIONS')
 390  FORMAT(4X,'REGRESSION WITH 1 VARIABLE')
 999  FORMAT(1X)
C
C     ==================================================================
C
      END
      SUBROUTINE SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA,
     1                 XDATA,NOBS)
C***BEGIN PROLOGUE  SNSQE
C***DATE WRITTEN   800301   (YYMMDD)
C***REVISION DATE  880222   (YYMMDD)
C***CATEGORY NO.  F2A
C***KEYWORDS  EASY-TO-USE,NONLINEAR SQUARE SYSTEM,POWELL HYBRID METHOD,
C             ZERO
C***AUTHOR  HIEBERT, K. L., (SNLA)
C***PURPOSE  SNSQE is the easy-to-use version of SNSQ which finds a zero
C            of a system of N nonlinear functions in N variables by a
C            modification of Powell hybrid method.  This code is the
C            combination of the MINPACK codes(Argonne) HYBRD1 and HYBRJ1
C***DESCRIPTION
C
C 1. Purpose. 
C
C
C       The purpose of SNSQE is to find a zero of a system of N non-
C       linear functions in N variables by a modification of the Powell
C       hybrid method.  This is done by using the more general nonlinear
C       equation solver SNSQ.  The user must provide a subroutine which
C       calculates the functions.  The user has the option of either to
C       provide a subroutine which calculates the Jacobian or to let the
C       code calculate it by a forward-difference approximation.  This
C       code is the combination of the MINPACK codes (Argonne) HYBRD1
C       and HYBRJ1.
C
C
C 2. Subroutine and Type Statements.
C
C       SUBROUTINE SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,
C      *                  WA,LWA)
C       INTEGER IOPT,N,NPRINT,INFO,LWA
C       REAL TOL
C       REAL X(N),FVEC(N),WA(LWA)
C       EXTERNAL FCN,JAC
C
C
C 3. Parameters.
C
C       Parameters designated as input parameters must be specified on
C       entry to SNSQE and are not changed on exit, while parameters
C       designated as output parameters need not be specified on entry
C       and are set to appropriate values on exit from SNSQE. 
C
C       FCN is the name of the user-supplied subroutine which calculates
C         the functions.  FCN must be declared in an EXTERNAL statement
C         in the user calling program, and should be written as follows.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         REAL X(N),FVEC(N)
C         ----------
C         Calculate the functions at X and
C         return this vector in FVEC.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by FCN unless the
C         user wants to terminate execution of SNSQE.  In this case, set
C         IFLAG to a negative integer.
C
C       JAC is the name of the user-supplied subroutine which calculates
C         the Jacobian.  If IOPT=1, then JAC must be declared in an
C         EXTERNAL statement in the user calling program, and should be
C         written as follows.
C
C         SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG)
C         INTEGER N,LDFJAC,IFLAG
C         REAL X(N),FVEC(N),FJAC(LDFJAC,N)
C         ----------
C         Calculate the Jacobian at X and return this
C         matrix in FJAC.  FVEC contains the function
C         values at X and should not be altered.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by JAC unless the
C         user wants to terminate execution of SNSQE.  In this case, set
C         IFLAG to a negative integer.
C
C         If IOPT=2, JAC can be ignored (treat it as a dummy argument).
C
C       IOPT is an input variable which specifies how the Jacobian will 
C         be calculated.  If IOPT=1, then the user must supply the
C         Jacobian through the subroutine JAC.  If IOPT=2, then the
C         code will approximate the Jacobian by forward-differencing. 
C
C       N is a positive integer input variable set to the number of
C         functions and variables.
C
C       X is an array of length N.  On input, X must contain an initial
C         estimate of the solution vector.  On output, X contains the
C         final estimate of the solution vector.
C
C       FVEC is an output array of length N which contains the functions
C         evaluated at the output X.
C
C       TOL is a non-negative input variable.  Termination occurs when
C         the algorithm estimates that the relative error between X and
C         the solution is at most TOL.  Section 4 contains more details
C         about TOL.
C
C       NPRINT is an integer input variable that enables controlled
C         printing of iterates if it is positive.  In this case, FCN is
C         called with IFLAG = 0 at the beginning of the first iteration
C         and every NPRINT iteration thereafter and immediately prior
C         to return, with X and FVEC available for printing. Appropriate
C         print statements must be added to FCN (see example). If NPRINT
C         is not positive, no special calls of FCN with IFLAG = 0 are
C         made. 
C
C       INFO is an integer output variable.  If the user has terminated
C         execution, INFO is set to the (negative) value of IFLAG.  See
C         description of FCN and JAC. Otherwise, INFO is set as follows.
C
C         INFO = 0  improper input parameters. 
C
C         INFO = 1  algorithm estimates that the relative error between
C                   X and the solution is at most TOL.
C
C         INFO = 2  number of calls to FCN has reached or exceeded
C                   100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2.
C
C         INFO = 3  TOL is too small.  No further improvement in the
C                   approximate solution X is possible.
C
C         INFO = 4  iteration is not making good progress.
C
C         Sections 4 and 5 contain more details about INFO.
C
C       WA is a work array of length LWA.
C
C       LWA is a positive integer input variable not less than
C         (3*N**2+13*N))/2.
C
C
C 4. Successful Completion.
C
C       The accuracy of SNSQE is controlled by the convergence parame-
C       ter TOL.  This parameter is used in a test which makes a compar-
C       ison between the approximation X and a solution XSOL.  SNSQE
C       terminates when the test is satisfied.  If TOL is less than the
C       machine precision (as defined by the function R1MACH(4)), then
C       SNSQE attemps only to satisfy the test defined by the machine
C       precision.  Further progress is not usually possible.  Unless
C       high precision solutions are required, the recommended value
C       for TOL is the square root of the machine precision. 
C
C       The test assumes that the functions are reasonably well behaved,
C       and, if the Jacobian is supplied by the user, that the functions
C       and the Jacobian  coded consistently.  If these conditions
C       are not satisfied, SNSQE may incorrectly indicate convergence.
C       The coding of the Jacobian can be checked by the subroutine
C       CHKDER.  If the Jacobian is coded correctly or IOPT=2, then
C       the validity of the answer can be checked, for example, by
C       rerunning SNSQE with a tighter tolerance. 
C
C       Convergence Test.  If SNRM2(Z) denotes the Euclidean norm of a 
C         vector Z, then this test attempts to guarantee that
C
C               SNRM2(X-XSOL) .LE.  TOL*SNRM2(XSOL).
C
C         If this condition is satisfied with TOL = 10**(-K), then the
C         larger components of X have K significant decimal digits and 
C         INFO is set to 1.  There is a danger that the smaller compo- 
C         nents of X may have large relative errors, but the fast rate
C         of convergence of SNSQE usually avoids this possibility. 
C
C
C 5. Unsuccessful Completion. 
C
C       Unsuccessful termination of SNSQE can be due to improper input
C       parameters, arithmetic interrupts, an excessive number of func-
C       tion evaluations, errors in the functions, or lack of good prog-
C       ress.
C
C       Improper Input Parameters.  INFO is set to 0 if IOPT .LT. 1, or
C         IOPT .GT. 2, or N .LE. 0, or TOL .LT. 0.E0, or
C         LWA .LT. (3*N**2+13*N)/2.
C
C       Arithmetic Interrupts.  If these interrupts occur in the FCN
C         subroutine during an early stage of the computation, they may
C         be caused by an unacceptable choice of X by SNSQE.  In this
C         case, it may be possible to remedy the situation by not evalu-
C         ating the functions here, but instead setting the components
C         of FVEC to numbers that exceed those in the initial FVEC.
C
C       Excessive Number of Function Evaluations.  If the number of
C         calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for
C         IOPT=2, then this indicates that the routine is converging
C         very slowly as measured by the progress of FVEC, and INFO is
C         set to 2.  This situation should be unusual because, as
C         indicated below, lack of good progress is usually diagnosed 
C         earlier by SNSQE, causing termination with INFO = 4.
C
C       Errors in the Functions.  When IOPT=2, the choice of step length
C         in the forward-difference approximation to the Jacobian
C         assumes that the relative errors in the functions are of the
C         order of the machine precision.  If this is not the case,
C         SNSQE may fail (usually with INFO = 4).  The user should
C         then either use SNSQ and set the step length or use IOPT=1
C         and supply the Jacobian.
C
C       Lack of Good Progress.  SNSQE searches for a zero of the system
C         by minimizing the sum of the squares of the functions.  In so
C         doing, it can become trapped in a region where the minimum
C         does not correspond to a zero of the system and, in this situ-
C         ation, the iteration eventually fails to make good progress.
C         In particular, this will happen if the system does not have a 
C         zero.  If the system has a zero, rerunning SNSQE from a dif- 
C         ferent starting point may be helpful.
C
C
C 6. Characteristics of the Algorithm.
C
C       SNSQE is a modification of the Powell hybrid method.  Two of 
C       its main characteristics involve the choice of the correction as
C       a convex combination of the Newton and scaled gradient direc- 
C       tions, and the updating of the Jacobian by the rank-1 method of 
C       Broyden.  The choice of the correction guarantees (under reason-
C       able conditions) global convergence for starting points far from
C       the solution and a fast rate of convergence.  The Jacobian is
C       calculated at the starting point by either the user-supplied 
C       subroutine or a forward-difference approximation, but it is not
C       recalculated until the rank-1 method fails to produce satis-
C       factory progress.
C
C       Timing.  The time required by SNSQE to solve a given problem 
C         depends on N, the behavior of the functions, the accuracy
C         requested, and the starting point.  The number of arithmetic
C         operations needed by SNSQE is about 11.5*(N**2) to process
C         each evaluation of the functions (call to FCN) and 1.3*(N**3)
C         to process each evaluation of the Jacobian (call to JAC,
C         if IOPT = 1).  Unless FCN and JAC can be evaluated quickly,
C         the timing of SNSQE will be strongly influenced by the time
C         spent in FCN and JAC.
C
C       Storage.  SNSQE requires (3*N**2 + 17*N)/2 single precision
C         storage locations, in addition to the storage required by the
C         program.  There are no internally declared storage arrays.
C
C
C 7. Example. 
C
C       The problem is to determine the values of X(1), X(2), ..., X(9),
C       which solve the system of tridiagonal equations
C
C       (3-2*X(1))*X(1)           -2*X(2)                   = -1
C               -X(I-1) + (3-2*X(I))*X(I)         -2*X(I+1) = -1, I=2-8
C                                   -X(8) + (3-2*X(9))*X(9) = -1
C
C       **********
C
C       PROGRAM TEST(INPUT,OUTPUT,TAPE6=OUTPUT)
C C
C C     Driver for SNSQE example.
C C
C       INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE
C       REAL TOL,FNORM
C       REAL X(9),FVEC(9),WA(180)
C       REAL SNRM2,R1MACH
C       EXTERNAL FCN
C       DATA NWRITE /6/
C C
C       IOPT = 2
C       N = 9
C C
C C     The following starting values provide a rough solution. 
C C
C       DO 10 J = 1, 9
C          X(J) = -1.E0
C    10    CONTINUE 
C
C       LWA = 180
C       NPRINT = 0
C C
C C     Set TOL to the square root of the machine precision.
C C     Unless high precision solutions are required,
C C     this is the recommended setting.
C C
C       TOL = SQRT(R1MACH(4)) 
C C
C       CALL SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA)
C       FNORM = SNRM2(N,FVEC) 
C       WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
C       STOP
C  1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 //
C      *        5X,' EXIT PARAMETER',16X,I10 //
C      *        5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7))
C       END
C       SUBROUTINE FCN(N,X,FVEC,IFLAG)
C       INTEGER N,IFLAG
C       REAL X(N),FVEC(N)
C       INTEGER K
C       REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
C       DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/
C C
C       DO 10 K = 1, N
C          TEMP = (THREE - TWO*X(K))*X(K)
C          TEMP1 = ZERO
C          IF (K .NE. 1) TEMP1 = X(K-1) 
C          TEMP2 = ZERO
C          IF (K .NE. N) TEMP2 = X(K+1) 
C          FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
C    10    CONTINUE 
C       RETURN
C       END
C
C       Results obtained with different compilers or machines
C       may be slightly different.
C
C       FINAL L2 NORM OF THE RESIDUALS  0.1192636E-07
C
C       EXIT PARAMETER                         1
C
C       FINAL APPROXIMATE SOLUTION
C
C       -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
C       -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
C       -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
C***REFERENCES  POWELL, M. J. D.
C                 A HYBRID METHOD FOR NONLINEAR EQUATIONS.
C                 NUMERICAL METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS,
C                 P. RABINOWITZ, EDITOR.  GORDON AND BREACH, 1970.
C***ROUTINES CALLED  SNSQ,XERROR
C***END PROLOGUE  SNSQE
      INTEGER IOPT,N,NPRINT,INFO,LWA
      REAL TOL
      REAL X(N),FVEC(N),WA(LWA),XDATA(NOBS)
      EXTERNAL FCN,JAC
      INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NJEV
      REAL EPSFCN,FACTOR,ONE,XTOL,ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
C***FIRST EXECUTABLE STATEMENT  SNSQE
      INFO = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0
     1    .OR. TOL .LT. ZERO .OR. LWA .LT. (3*N**2 +13*N)/2)
     2   GO TO 20
C
C     CALL SNSQ.
C
      MAXFEV = 100*(N + 1)
      IF (IOPT .EQ. 2) MAXFEV = 2*MAXFEV
      XTOL = TOL
      ML = N - 1
      MU = N - 1
      EPSFCN = ZERO 
      MODE = 2
      DO 10 J = 1, N
         WA(J) = ONE
   10    CONTINUE
      LR = (N*(N + 1))/2
      INDEX=6*N+LR
      CALL SNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML,MU,
     1           EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
     2           WA(6*N+1),LR,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),
     3           WA(5*N+1),
     4           XDATA,NOBS)
      IF (INFO .EQ. 5) INFO = 4
   20 CONTINUE
      IF (INFO .EQ. 0) THEN
CCCCC    CALL XERROR( 'SNSQE  -- INVALID INPUT PARAMETER.'
CCCCC1,34,2,1)
        WRITE(ICOUT,11)
 11     FORMAT('***** ERROR IN SNSQE NON-LINEAR SIMULTANEOUS EQUATION ',
     1         'SOLVER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
 13     FORMAT('      INVALID INPUT PARAMETER.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      RETURN
C
C     LAST CARD OF SUBROUTINE SNSQE.
C
      END 
      SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
      INTEGER N,LR
      REAL DELTA
      REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N)
      INTEGER I,J,JJ,JP1,K,L
      REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO
      REAL SNRM2
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA ONE,ZERO /1.0E0,0.0E0/
      EPSMCH = R1MACH(4)
      JJ = (N*(N + 1))/2 + 1
      DO 50 K = 1, N
         J = N - K + 1
         JP1 = J + 1
         JJ = JJ - K
         L = JJ + 1 
         SUM = ZERO 
         IF (N .LT. JP1) GO TO 20
         DO 10 I = JP1, N
            SUM = SUM + R(L)*X(I)
            L = L + 1
   10       CONTINUE
   20    CONTINUE
         TEMP = R(JJ)
         IF (TEMP .NE. ZERO) GO TO 40
         L = J
         DO 30 I = 1, J
            TEMP = AMAX1(TEMP,ABS(R(L)))
            L = L + N - I
   30       CONTINUE
         TEMP = EPSMCH*TEMP
         IF (TEMP .EQ. ZERO) TEMP = EPSMCH
   40    CONTINUE
         X(J) = (QTB(J) - SUM)/TEMP
   50    CONTINUE
      DO 60 J = 1, N
         WA1(J) = ZERO
         WA2(J) = DIAG(J)*X(J)
   60    CONTINUE
      QNORM = SNRM2(N,WA2,1)
      IF (QNORM .LE. DELTA) GO TO 140
      L = 1
      DO 80 J = 1, N
         TEMP = QTB(J)
         DO 70 I = J, N
            WA1(I) = WA1(I) + R(L)*TEMP 
            L = L + 1
   70       CONTINUE
         WA1(J) = WA1(J)/DIAG(J)
   80    CONTINUE
      GNORM = SNRM2(N,WA1,1)
      SGNORM = ZERO 
      ALPHA = DELTA/QNORM
      IF (GNORM .EQ. ZERO) GO TO 120
      DO 90 J = 1, N
         WA1(J) = (WA1(J)/GNORM)/DIAG(J)
   90    CONTINUE
      L = 1
      DO 110 J = 1, N
         SUM = ZERO 
         DO 100 I = J, N
            SUM = SUM + R(L)*WA1(I)
            L = L + 1
  100       CONTINUE
         WA2(J) = SUM
  110    CONTINUE
      TEMP = SNRM2(N,WA2,1)
      SGNORM = (GNORM/TEMP)/TEMP
      ALPHA = ZERO
      IF (SGNORM .GE. DELTA) GO TO 120
      BNORM = SNRM2(N,QTB,1)
      TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
      TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
     1       + SQRT((TEMP-(DELTA/QNORM))**2
     2              +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2))
      ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP
  120 CONTINUE
      TEMP = (ONE - ALPHA)*AMIN1(SGNORM,DELTA)
      DO 130 J = 1, N
         X(J) = TEMP*WA1(J) + ALPHA*X(J)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END 
      SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
     1   WA1,WA2,
     1   XDATA,NOBS)
      INTEGER N,LDFJAC,IFLAG,ML,MU
      REAL EPSFCN
      REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N)
      REAL XDATA(NOBS)
      INTEGER I,J,K,MSUM
      REAL EPS,EPSMCH,H,TEMP,ZERO
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO /0.0E0/
      EPSMCH = R1MACH(4)
      EPS = SQRT(AMAX1(EPSFCN,EPSMCH))
      MSUM = ML + MU + 1
      IF (MSUM .LT. N) GO TO 40
         DO 20 J = 1, N
            TEMP = X(J)
            H = EPS*ABS(TEMP) 
            IF (H .EQ. ZERO) H = EPS
            X(J) = TEMP + H
            CALL FCN(N,X,WA1,IFLAG,XDATA,NOBS)
            IF (IFLAG .LT. 0) GO TO 30
            X(J) = TEMP
            DO 10 I = 1, N
               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   10          CONTINUE
   20       CONTINUE
   30    CONTINUE
         GO TO 110
   40 CONTINUE
         DO 90 K = 1, MSUM
            DO 60 J = K, N, MSUM
               WA2(J) = X(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS 
               X(J) = WA2(J) + H
   60          CONTINUE
            CALL FCN(N,X,WA1,IFLAG,XDATA,NOBS)
            IF (IFLAG .LT. 0) GO TO 100 
            DO 80 J = K, N, MSUM
               X(J) = WA2(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS 
               DO 70 I = 1, N 
                  FJAC(I,J) = ZERO
                  IF (I .GE. J - MU .AND. I .LE. J + ML)
     1               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
  110 CONTINUE
      RETURN
      END 
      SUBROUTINE QFORM(M,N,Q,LDQ,WA)
      INTEGER M,N,LDQ
      REAL Q(LDQ,M),WA(M)
      INTEGER I,J,JM1,K,L,MINMN,NP1
      REAL ONE,SUM,TEMP,ZERO
      DATA ONE,ZERO /1.0E0,0.0E0/
      MINMN = MIN0(M,N)
      IF (MINMN .LT. 2) GO TO 30
      DO 20 J = 2, MINMN
         JM1 = J - 1
         DO 10 I = 1, JM1
            Q(I,J) = ZERO
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
      NP1 = N + 1
      IF (M .LT. NP1) GO TO 60
      DO 50 J = NP1, M
         DO 40 I = 1, M
            Q(I,J) = ZERO
   40       CONTINUE
         Q(J,J) = ONE
   50    CONTINUE
   60 CONTINUE
      DO 120 L = 1, MINMN
         K = MINMN - L + 1
         DO 70 I = K, M
            WA(I) = Q(I,K)
            Q(I,K) = ZERO
   70       CONTINUE
         Q(K,K) = ONE
         IF (WA(K) .EQ. ZERO) GO TO 110 
         DO 100 J = K, M
            SUM = ZERO
            DO 80 I = K, M
               SUM = SUM + Q(I,J)*WA(I) 
   80          CONTINUE
            TEMP = SUM/WA(K)
            DO 90 I = K, M
               Q(I,J) = Q(I,J) - TEMP*WA(I)
   90          CONTINUE
  100       CONTINUE
  110    CONTINUE
  120    CONTINUE
      RETURN
      END 
      SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA)
      INTEGER M,N,LDA,LIPVT
      INTEGER IPVT(LIPVT)
      LOGICAL PIVOT 
      REAL A(LDA,N),SIGMA(N),ACNORM(N),WA(N)
      INTEGER I,J,JP1,K,KMAX,MINMN
      REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
      REAL SNRM2
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/
      EPSMCH = R1MACH(4)
      DO 10 J = 1, N
         ACNORM(J) = SNRM2(M,A(1,J),1)
         SIGMA(J) = ACNORM(J) 
         WA(J) = SIGMA(J)
         IF (PIVOT) IPVT(J) = J
   10    CONTINUE
      MINMN = MIN0(M,N)
      DO 110 J = 1, MINMN
         IF (.NOT.PIVOT) GO TO 40
         KMAX = J
         DO 20 K = J, N
            IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K
   20       CONTINUE
         IF (KMAX .EQ. J) GO TO 40
         DO 30 I = 1, M
            TEMP = A(I,J)
            A(I,J) = A(I,KMAX)
            A(I,KMAX) = TEMP
   30       CONTINUE
         SIGMA(KMAX) = SIGMA(J)
         WA(KMAX) = WA(J)
         K = IPVT(J)
         IPVT(J) = IPVT(KMAX) 
         IPVT(KMAX) = K
   40    CONTINUE
         AJNORM = SNRM2(M-J+1,A(J,J),1)
         IF (AJNORM .EQ. ZERO) GO TO 100
         IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM
         DO 50 I = J, M
            A(I,J) = A(I,J)/AJNORM
   50       CONTINUE
         A(J,J) = A(J,J) + ONE
         JP1 = J + 1
         IF (N .LT. JP1) GO TO 100
         DO 90 K = JP1, N
            SUM = ZERO
            DO 60 I = J, M
               SUM = SUM + A(I,J)*A(I,K)
   60          CONTINUE
            TEMP = SUM/A(J,J) 
            DO 70 I = J, M
               A(I,K) = A(I,K) - TEMP*A(I,J)
   70          CONTINUE
            IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80
            TEMP = A(J,K)/SIGMA(K)
            SIGMA(K) = SIGMA(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2))
            IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80
            SIGMA(K) = SNRM2(M-J,A(JP1,K),1)
            WA(K) = SIGMA(K)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
         SIGMA(J) = -AJNORM
  110    CONTINUE
      RETURN
      END 
      SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
      INTEGER M,N,LDA
      REAL A(LDA,N),V(N),W(N) 
      INTEGER I,J,NMJ,NM1
      REAL COS,ONE,SIN,TEMP
      DATA ONE /1.0E0/
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 50
      DO 20 NMJ = 1, NM1
         J = N - NMJ
         IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
         IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(V(J)) .LE. ONE) SIN = V(J)
         IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 10 I = 1, M
            TEMP = COS*A(I,J) - SIN*A(I,N)
            A(I,N) = SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
      DO 40 J = 1, NM1
         IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
         IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(W(J)) .LE. ONE) SIN = W(J)
         IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 30 I = 1, M
            TEMP = COS*A(I,J) + SIN*A(I,N)
            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
      END 
      SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
      INTEGER M,N,LS
      LOGICAL SING
      REAL S(LS),U(M),V(N),W(M)
      INTEGER I,J,JJ,L,NMJ,NM1
      REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO 
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
      GIANT = R1MACH(2)
      JJ = (N*(2*M - N + 1))/2 - (M - N)
      L = JJ
      DO 10 I = N, M
         W(I) = S(L)
         L = L + 1
   10    CONTINUE
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 NMJ = 1, NM1
         J = N - NMJ
         JJ = JJ - (M - J + 1)
         W(J) = ZERO
         IF (V(J) .EQ. ZERO) GO TO 50
         IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20
            COTAN = V(N)/V(J) 
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 30
   20    CONTINUE
            TAN = V(J)/V(N)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
   30    CONTINUE
         V(N) = SIN*V(J) + COS*V(N)
         V(J) = TAU 
         L = JJ
         DO 40 I = J, M
            TEMP = COS*S(L) - SIN*W(I)
            W(I) = SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
      DO 80 I = 1, M
         W(I) = W(I) + V(N)*U(I)
   80    CONTINUE
      SING = .FALSE.
      IF (NM1 .LT. 1) GO TO 140
      DO 130 J = 1, NM1
         IF (W(J) .EQ. ZERO) GO TO 120
         IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90
            COTAN = S(JJ)/W(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 100
   90    CONTINUE
            TAN = W(J)/S(JJ)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
  100    CONTINUE
         L = JJ
         DO 110 I = J, M
            TEMP = COS*S(L) + SIN*W(I)
            W(I) = -SIN*S(L) + COS*W(I) 
            S(L) = TEMP
            L = L + 1
  110       CONTINUE
         W(J) = TAU 
  120    CONTINUE
         IF (S(JJ) .EQ. ZERO) SING = .TRUE.
         JJ = JJ + (M - J + 1)
  130    CONTINUE
  140 CONTINUE
      L = JJ
      DO 150 I = N, M
         S(L) = W(I)
         L = L + 1
  150    CONTINUE
      IF (S(JJ) .EQ. ZERO) SING = .TRUE.
      RETURN
      END 
      SUBROUTINE SNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,
     1   MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,
     2   WA2,WA3,WA4,
     3   XDATA,NOBS)
      INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NJEV
      REAL XTOL,EPSFCN,FACTOR 
      REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),WA1(N),
     1     WA2(N),WA3(N),WA4(N)
      REAL XDATA(NOBS)
      EXTERNAL FCN
      INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2
      INTEGER IWA(1)
      LOGICAL JEVAL,SING
      REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5,
     1     P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO
      REAL SNRM2
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,P1,P5,P001,P0001,ZERO
     1     /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/
      EPSMCH = R1MACH(4)
      INFO = 0
      IFLAG = 0
      NFEV = 0
      NJEV = 0
      IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR.
     1    N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0
     2    .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO
     3    .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300
      IF (MODE .NE. 2) GO TO 20
      DO 10 J = 1, N
         IF (DIAG(J) .LE. ZERO) GO TO 300
   10    CONTINUE
   20 CONTINUE
      IFLAG = 1
      CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS)
      NFEV = 1
      IF (IFLAG .LT. 0) GO TO 300
      FNORM = SNRM2(N,FVEC,1)
      ITER = 1
      NCSUC = 0
      NCFAIL = 0
      NSLOW1 = 0
      NSLOW2 = 0
   30 CONTINUE
         JEVAL = .TRUE.
         IF (IOPT .EQ. 2) GO TO 31
            CALL JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG)
            NJEV = NJEV+1
            GO TO 32
   31       IFLAG = 2
            CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1,
     1               WA2,
     2               XDATA,NOBS)
            NFEV = NFEV + MIN0(ML+MU+1,N)
   32    IF (IFLAG .LT. 0) GO TO 300
         CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
         IF (ITER .NE. 1) GO TO 70
         IF (MODE .EQ. 2) GO TO 50
         DO 40 J = 1, N
            DIAG(J) = WA2(J)
            IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
   40       CONTINUE
   50    CONTINUE
         DO 60 J = 1, N
            WA3(J) = DIAG(J)*X(J)
   60       CONTINUE
         XNORM = SNRM2(N,WA3,1) 
         DELTA = FACTOR*XNORM 
         IF (DELTA .EQ. ZERO) DELTA = FACTOR
   70    CONTINUE
         DO 80 I = 1, N
            QTF(I) = FVEC(I)
   80       CONTINUE
         DO 120 J = 1, N
            IF (FJAC(J,J) .EQ. ZERO) GO TO 110
            SUM = ZERO
            DO 90 I = J, N
               SUM = SUM + FJAC(I,J)*QTF(I)
   90          CONTINUE
            TEMP = -SUM/FJAC(J,J)
            DO 100 I = J, N
               QTF(I) = QTF(I) + FJAC(I,J)*TEMP
  100          CONTINUE
  110       CONTINUE
  120       CONTINUE
         SING = .FALSE.
         DO 150 J = 1, N
            L = J
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 140
            DO 130 I = 1, JM1 
               R(L) = FJAC(I,J)
               L = L + N - I
  130          CONTINUE
  140       CONTINUE
            R(L) = WA1(J)
            IF (WA1(J) .EQ. ZERO) SING = .TRUE.
  150       CONTINUE
         CALL QFORM(N,N,FJAC,LDFJAC,WA1)
         IF (MODE .EQ. 2) GO TO 170
         DO 160 J = 1, N
            DIAG(J) = AMAX1(DIAG(J),WA2(J))
  160       CONTINUE
  170    CONTINUE
  180    CONTINUE
            IF (NPRINT .LE. 0) GO TO 190
            IFLAG = 0
            IF (MOD(ITER-1,NPRINT) .EQ. 0)
     1         CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS)
            IF (IFLAG .LT. 0) GO TO 300 
  190       CONTINUE
            CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
            DO 200 J = 1, N
               WA1(J) = -WA1(J)
               WA2(J) = X(J) + WA1(J)
               WA3(J) = DIAG(J)*WA1(J)
  200          CONTINUE
            PNORM = SNRM2(N,WA3,1)
            IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
            IFLAG = 1
            CALL FCN(N,WA2,WA4,IFLAG,XDATA,NOBS)
            NFEV = NFEV + 1
            IF (IFLAG .LT. 0) GO TO 300 
            FNORM1 = SNRM2(N,WA4,1)
            ACTRED = -ONE
            IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
            L = 1
            DO 220 I = 1, N
               SUM = ZERO
               DO 210 J = I, N
                  SUM = SUM + R(L)*WA1(J)
                  L = L + 1
  210             CONTINUE
               WA3(I) = QTF(I) + SUM
  220          CONTINUE
            TEMP = SNRM2(N,WA3,1)
            PRERED = ZERO
            IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
            RATIO = ZERO
            IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
            IF (RATIO .GE. P1) GO TO 230
               NCSUC = 0
               NCFAIL = NCFAIL + 1
               DELTA = P5*DELTA
               GO TO 240
  230       CONTINUE
               NCFAIL = 0
               NCSUC = NCSUC + 1
               IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
     1            DELTA = AMAX1(DELTA,PNORM/P5)
               IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 
  240       CONTINUE
            IF (RATIO .LT. P0001) GO TO 260
            DO 250 J = 1, N
               X(J) = WA2(J)
               WA2(J) = DIAG(J)*X(J)
               FVEC(J) = WA4(J)
  250          CONTINUE
            XNORM = SNRM2(N,WA2,1)
            FNORM = FNORM1
            ITER = ITER + 1
  260       CONTINUE
            NSLOW1 = NSLOW1 + 1
            IF (ACTRED .GE. P001) NSLOW1 = 0
            IF (JEVAL) NSLOW2 = NSLOW2 + 1
            IF (ACTRED .GE. P1) NSLOW2 = 0
            IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
            IF (INFO .NE. 0) GO TO 300
            IF (NFEV .GE. MAXFEV) INFO = 2
            IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
            IF (NSLOW2 .EQ. 5) INFO = 4 
            IF (NSLOW1 .EQ. 10) INFO = 5
            IF (INFO .NE. 0) GO TO 300
            IF (NCFAIL .EQ. 2) GO TO 290
            DO 280 J = 1, N
               SUM = ZERO
               DO 270 I = 1, N
                  SUM = SUM + FJAC(I,J)*WA4(I)
  270             CONTINUE
               WA2(J) = (SUM - WA3(J))/PNORM
               WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
               IF (RATIO .GE. P0001) QTF(J) = SUM 
  280          CONTINUE
            CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
            CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
            CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
            JEVAL = .FALSE.
            GO TO 180
  290    CONTINUE
         GO TO 30
  300 CONTINUE
      IF (IFLAG .LT. 0) INFO = IFLAG
      IFLAG = 0
      IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS) 
C
C  ERROR SECTION
C
      IF (INFO .LT. 0) THEN
CCCCC   CALL XERROR( 'SNSQ   -- EXECUTION TERMINATED BECA
CCCCC1USE USER SET IFLAG NEGATIVE.',63,1,1)
        WRITE(ICOUT,1001)
 1001   FORMAT('***** ERROR IN SNSQE NON-LINEAR SIMULTANEOUS EQUATION ',
     1         'SOLVER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1003)
 1003   FORMAT('      TERMINATION HALTED BECAUSE IFLAG IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 0) THEN
CCCCC   CALL XERROR( 'SNSQ   -- INVALID INPUT PARAMETER.',34,2,1)
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1004)
 1004   FORMAT('      INVALID INPUT PARAMETER.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 2) THEN
CCCCC   CALL XERROR( 'SNSQ   -- TOO MANY FUNCTION EVALUATIONS.',40,9,1)
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1005)
 1005   FORMAT('      TOO MANY FUNCTION EVALUATIONS.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 3) THEN
CCCCC   CALL XERROR( 'SNSQ   -- XTOL TOO SMALL. NO FURTHE
CCCCC1R IMPROVEMENT POSSIBLE.',58,3,1)
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1006)
 1006   FORMAT('      XTOL TOO SMALL.  NO FURTHER IMPROVEMENT ',
     1         'POSSIBLE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .GT. 4) THEN
CCCCC   CALL XERROR( 'SNSQ   -- ITERATION NOT MAKING GOOD
CCCCC1 PROGRESS.',45,1,1)
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1007)
 1007   FORMAT('      ITERATION NOT MAKING GOOD PROGRESS.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END 
*DECK DNSQE
      SUBROUTINE DNSQE (FCN, JAC, IOPT, N, X, FVEC, TOL, NPRINT, INFO,
     +   WA, LWA,
     +   XDATA,NOBS)
C***BEGIN PROLOGUE  DNSQE
C***PURPOSE  An easy-to-use code to find a zero of a system of N
C            nonlinear functions in N variables by a modification of
C            the Powell hybrid method.
C***LIBRARY   SLATEC
C***CATEGORY  F2A
C***TYPE      DOUBLE PRECISION (SNSQE-S, DNSQE-D)
C***KEYWORDS  EASY-TO-USE, NONLINEAR SQUARE SYSTEM,
C             POWELL HYBRID METHOD, ZEROS
C***AUTHOR  Hiebert, K. L. (SNLA)
C***DESCRIPTION
C
C 1. Purpose.
C
C       The purpose of DNSQE is to find a zero of a system of N
C       nonlinear functions in N variables by a modification of the
C       Powell hybrid method.  This is done by using the more general
C       nonlinear equation solver DNSQ.  The user must provide a
C       subroutine which calculates the functions.  The user has the
C       option of either to provide a subroutine which calculates the
C       Jacobian or to let the code calculate it by a forward-difference
C       approximation.  This code is the combination of the MINPACK
C       codes (Argonne) HYBRD1 and HYBRJ1.
C
C 2. Subroutine and Type Statements.
C
C       SUBROUTINE DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,
C      *                  WA,LWA)
C       INTEGER IOPT,N,NPRINT,INFO,LWA
C       DOUBLE PRECISION TOL
C       DOUBLE PRECISION X(N),FVEC(N),WA(LWA)
C       EXTERNAL FCN,JAC
C
C 3. Parameters.
C
C       Parameters designated as input parameters must be specified on
C       entry to DNSQE and are not changed on exit, while parameters
C       designated as output parameters need not be specified on entry
C       and are set to appropriate values on exit from DNSQE.
C
C       FCN is the name of the user-supplied subroutine which calculates
C         the functions.  FCN must be declared in an external statement
C         in the user calling program, and should be written as follows.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         DOUBLE PRECISION X(N),FVEC(N)
C         ----------
C         Calculate the functions at X and
C         return this vector in FVEC.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by FCN unless the
C         user wants to terminate execution of DNSQE.  In this case set
C         IFLAG to a negative integer.
C
C       JAC is the name of the user-supplied subroutine which calculates
C         the Jacobian.  If IOPT=1, then JAC must be declared in an
C         external statement in the user calling program, and should be
C         written as follows.
C
C         SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG)
C         INTEGER N,LDFJAC,IFLAG
C         DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
C         ----------
C         Calculate the Jacobian at X and return this
C         matrix in FJAC.  FVEC contains the function
C         values at X and should not be altered.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by JAC unless the
C         user wants to terminate execution of DNSQE. In this case set
C         IFLAG to a negative integer.
C
C         If IOPT=2, JAC can be ignored (treat it as a dummy argument).
C
C       IOPT is an input variable which specifies how the Jacobian will
C         be calculated.  If IOPT=1, then the user must supply the
C         Jacobian through the subroutine JAC.  If IOPT=2, then the
C         code will approximate the Jacobian by forward-differencing.
C
C       N is a positive integer input variable set to the number of
C         functions and variables.
C
C       X is an array of length N.  On input X must contain an initial
C         estimate of the solution vector.  On output X contains the
C         final estimate of the solution vector.
C
C       FVEC is an output array of length N which contains the functions
C         evaluated at the output X.
C
C       TOL is a nonnegative input variable.  Termination occurs when
C         the algorithm estimates that the relative error between X and
C         the solution is at most TOL.  Section 4 contains more details
C         about TOL.
C
C       NPRINT is an integer input variable that enables controlled
C         printing of iterates if it is positive.  In this case, FCN is
C         called with IFLAG = 0 at the beginning of the first iteration
C         and every NPRINT iterations thereafter and immediately prior
C         to return, with X and FVEC available for printing. Appropriate
C         print statements must be added to FCN(see example).  If NPRINT
C         is not positive, no special calls of FCN with IFLAG = 0 are
C         made.
C
C       INFO is an integer output variable.  If the user has terminated
C         execution, INFO is set to the (negative) value of IFLAG.  See
C         description of FCN and JAC. Otherwise, INFO is set as follows.
C
C         INFO = 0  Improper input parameters.
C
C         INFO = 1  Algorithm estimates that the relative error between
C                   X and the solution is at most TOL.
C
C         INFO = 2  Number of calls to FCN has reached or exceeded
C                   100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2.
C
C         INFO = 3  TOL is too small.  No further improvement in the
C                   approximate solution X is possible.
C
C         INFO = 4  Iteration is not making good progress.
C
C         Sections 4 and 5 contain more details about INFO.
C
C       WA is a work array of length LWA.
C
C       LWA is a positive integer input variable not less than
C         (3*N**2+13*N))/2.
C
C 4. Successful Completion.
C
C       The accuracy of DNSQE is controlled by the convergence parameter
C       TOL.  This parameter is used in a test which makes a comparison
C       between the approximation X and a solution XSOL.  DNSQE
C       terminates when the test is satisfied.  If TOL is less than the
C       machine precision (as defined by the  function D1MACH(4)), then
C       DNSQE only attempts to satisfy the test defined by the machine
C       precision.  Further progress is not usually possible.  Unless
C       high precision solutions are required, the recommended value
C       for TOL is the square root of the machine precision.
C
C       The test assumes that the functions are reasonably well behaved,
C       and, if the Jacobian is supplied by the user, that the functions
C       and the Jacobian are coded consistently. If these conditions are
C       not satisfied, then DNSQE may incorrectly indicate convergence.
C       The coding of the Jacobian can be checked by the subroutine
C       DCKDER.  If the Jacobian is coded correctly or IOPT=2, then
C       the validity of the answer can be checked, for example, by
C       rerunning DNSQE with a tighter tolerance.
C
C       Convergence Test.  If DENORM(Z) denotes the Euclidean norm of a
C         vector Z, then this test attempts to guarantee that
C
C               DENORM(X-XSOL) .LE. TOL*DENORM(XSOL).
C
C         If this condition is satisfied with TOL = 10**(-K), then the
C         larger components of X have K significant decimal digits and
C         INFO is set to 1.  There is a danger that the smaller
C         components of X may have large relative errors, but the fast
C         rate of convergence of DNSQE usually avoids this possibility.
C
C 5. Unsuccessful Completion.
C
C       Unsuccessful termination of DNSQE can be due to improper input
C       parameters, arithmetic interrupts, an excessive number of
C       function evaluations, errors in the functions, or lack of good
C       progress.
C
C       Improper Input Parameters.  INFO is set to 0 if IOPT .LT. 1, or
C         IOPT .GT. 2, or N .LE. 0, or TOL .LT. 0.E0, or
C         LWA .LT. (3*N**2+13*N)/2.
C
C       Arithmetic Interrupts.  If these interrupts occur in the FCN
C         subroutine during an early stage of the computation, they may
C         be caused by an unacceptable choice of X by DNSQE.  In this
C         case, it may be possible to remedy the situation by not
C         evaluating the functions here, but instead setting the
C         components of FVEC to numbers that exceed those in the initial
C         FVEC.
C
C       Excessive Number of Function Evaluations.  If the number of
C         calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for
C         IOPT=2, then this indicates that the routine is converging
C         very slowly as measured by the progress of FVEC, and INFO is
C         set to 2.  This situation should be unusual because, as
C         indicated below, lack of good progress is usually diagnosed
C         earlier by DNSQE, causing termination with INFO = 4.
C
C       Errors In the Functions.  When IOPT=2, the choice of step length
C         in the forward-difference approximation to the Jacobian
C         assumes that the relative errors in the functions are of the
C         order of the machine precision.  If this is not the case,
C         DNSQE may fail (usually with INFO = 4).  The user should
C         then either use DNSQ and set the step length or use IOPT=1
C         and supply the Jacobian.
C
C       Lack of Good Progress.  DNSQE searches for a zero of the system
C         by minimizing the sum of the squares of the functions.  In so
C         doing, it can become trapped in a region where the minimum
C         does not correspond to a zero of the system and, in this
C         situation, the iteration eventually fails to make good
C         progress.  In particular, this will happen if the system does
C         not have a zero.  If the system has a zero, rerunning DNSQE
C         from a different starting point may be helpful.
C
C 6. Characteristics of The Algorithm.
C
C       DNSQE is a modification of the Powell Hybrid method.  Two of
C       its main characteristics involve the choice of the correction as
C       a convex combination of the Newton and scaled gradient
C       directions, and the updating of the Jacobian by the rank-1
C       method of Broyden.  The choice of the correction guarantees
C       (under reasonable conditions) global convergence for starting
C       points far from the solution and a fast rate of convergence.
C       The Jacobian is calculated at the starting point by either the
C       user-supplied subroutine or a forward-difference approximation,
C       but it is not recalculated until the rank-1 method fails to
C       produce satisfactory progress.
C
C       Timing.  The time required by DNSQE to solve a given problem
C         depends on N, the behavior of the functions, the accuracy
C         requested, and the starting point.  The number of arithmetic
C         operations needed by DNSQE is about 11.5*(N**2) to process
C         each evaluation of the functions (call to FCN) and 1.3*(N**3)
C         to process each evaluation of the Jacobian (call to JAC,
C         if IOPT = 1).  Unless FCN and JAC can be evaluated quickly,
C         the timing of DNSQE will be strongly influenced by the time
C         spent in FCN and JAC.
C
C       Storage.  DNSQE requires (3*N**2 + 17*N)/2 single precision
C         storage locations, in addition to the storage required by the
C         program.  There are no internally declared storage arrays.
C
C *Long Description:
C
C 7. Example.
C
C       The problem is to determine the values of X(1), X(2), ..., X(9),
C       which solve the system of tridiagonal equations
C
C       (3-2*X(1))*X(1)           -2*X(2)                   = -1
C               -X(I-1) + (3-2*X(I))*X(I)         -2*X(I+1) = -1, I=2-8
C                                   -X(8) + (3-2*X(9))*X(9) = -1
C
C       **********
C
C       PROGRAM TEST
C C
C C     DRIVER FOR DNSQE EXAMPLE.
C C
C       INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE
C       DOUBLE PRECISION TOL,FNORM
C       DOUBLE PRECISION X(9),FVEC(9),WA(180)
C       DOUBLE PRECISION DENORM,D1MACH
C       EXTERNAL FCN
C       DATA NWRITE /6/
C C
C       IOPT = 2
C       N = 9
C C
C C     THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
C C
C       DO 10 J = 1, 9
C          X(J) = -1.E0
C    10    CONTINUE
C
C       LWA = 180
C       NPRINT = 0
C C
C C     SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
C C     UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
C C     THIS IS THE RECOMMENDED SETTING.
C C
C       TOL = SQRT(D1MACH(4))
C C
C       CALL DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA)
C       FNORM = DENORM(N,FVEC)
C       WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N)
C       STOP
C  1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 //
C      *        5X,' EXIT PARAMETER',16X,I10 //
C      *        5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7))
C       END
C       SUBROUTINE FCN(N,X,FVEC,IFLAG)
C       INTEGER N,IFLAG
C       DOUBLE PRECISION X(N),FVEC(N)
C       INTEGER K
C       DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
C       DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/
C C
C       DO 10 K = 1, N
C          TEMP = (THREE - TWO*X(K))*X(K)
C          TEMP1 = ZERO
C          IF (K .NE. 1) TEMP1 = X(K-1)
C          TEMP2 = ZERO
C          IF (K .NE. N) TEMP2 = X(K+1)
C          FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
C    10    CONTINUE
C       RETURN
C       END
C
C       RESULTS OBTAINED WITH DIFFERENT COMPILERS OR MACHINES
C       MAY BE SLIGHTLY DIFFERENT.
C
C       FINAL L2 NORM OF THE RESIDUALS  0.1192636E-07
C
C       EXIT PARAMETER                         1
C
C       FINAL APPROXIMATE SOLUTION
C
C       -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
C       -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
C       -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
C
C***REFERENCES  M. J. D. Powell, A hybrid method for nonlinear equa-
C                 tions. In Numerical Methods for Nonlinear Algebraic
C                 Equations, P. Rabinowitz, Editor.  Gordon and Breach,
C                 1988.
C***ROUTINES CALLED  DNSQ, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DNSQE
      INTEGER INDEX, INFO, IOPT, J, LR, LWA, MAXFEV, ML, MODE, MU, N,
     1     NFEV, NJEV, NPRINT
      DOUBLE PRECISION EPSFCN, FACTOR, FVEC(*), ONE, TOL, WA(*),
     1     X(*), XTOL, ZERO
      REAL XDATA(NOBS)
      EXTERNAL FCN, JAC
      SAVE FACTOR, ONE, ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
C     BEGIN BLOCK PERMITTING ...EXITS TO 20
C***FIRST EXECUTABLE STATEMENT  DNSQE
         INFO = 0
C
C        CHECK THE INPUT PARAMETERS FOR ERRORS.
C
C     ...EXIT
         IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0
     1       .OR. TOL .LT. ZERO .OR. LWA .LT. (3*N**2 + 13*N)/2)
     2      GO TO 20
C
C        CALL DNSQ.
C
         MAXFEV = 100*(N + 1)
         IF (IOPT .EQ. 2) MAXFEV = 2*MAXFEV
         XTOL = TOL
         ML = N - 1
         MU = N - 1
         EPSFCN = ZERO
         MODE = 2
         DO 10 J = 1, N
            WA(J) = ONE
   10    CONTINUE
         LR = (N*(N + 1))/2
         INDEX = 6*N + LR
         CALL DNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML,
     1             MU,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
     2             WA(6*N+1),LR,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),
     3             WA(5*N+1),
     4             XDATA,NOBS)
         IF (INFO .EQ. 5) INFO = 4
   20 CONTINUE
CCCCC IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNSQE',
CCCCC+   'INVALID INPUT PARAMETER.', 2, 1)
      IF (INFO .EQ. 0) THEN
        WRITE(ICOUT,11)
 11     FORMAT('***** ERROR IN DNSQE NON-LINEAR SIMULTANEOUS EQUATION ',
     1         'SOLVER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
 13     FORMAT('      INVALID INPUT PARAMETER.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      RETURN
C
C     LAST CARD OF SUBROUTINE DNSQE.
C
      END
*DECK DNSQ
      SUBROUTINE DNSQ (FCN, JAC, IOPT, N, X, FVEC, FJAC, LDFJAC, XTOL,
     +   MAXFEV, ML, MU, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, NFEV,
     +   NJEV, R, LR, QTF, WA1, WA2, WA3, WA4,
     +   XDATA,NOBS)
C***BEGIN PROLOGUE  DNSQ
C***PURPOSE  Find a zero of a system of a N nonlinear functions in N
C            variables by a modification of the Powell hybrid method.
C***LIBRARY   SLATEC
C***CATEGORY  F2A
C***TYPE      DOUBLE PRECISION (SNSQ-S, DNSQ-D)
C***KEYWORDS  NONLINEAR SQUARE SYSTEM, POWELL HYBRID METHOD, ZEROS
C***AUTHOR  Hiebert, K. L. (SNLA)
C***DESCRIPTION
C
C 1. Purpose.
C
C       The purpose of DNSQ is to find a zero of a system of N nonlinear
C       functions in N variables by a modification of the Powell
C       hybrid method.  The user must provide a subroutine which
C       calculates the functions.  The user has the option of either to
C       provide a subroutine which calculates the Jacobian or to let the
C       code calculate it by a forward-difference approximation.
C       This code is the combination of the MINPACK codes (Argonne)
C       HYBRD and HYBRDJ.
C
C 2. Subroutine and Type Statements.
C
C       SUBROUTINE DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,
C      *                 ML,MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,
C      *                 NJEV,R,LR,QTF,WA1,WA2,WA3,WA4)
C       INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,NJEV,LR
C       DOUBLE PRECISION XTOL,EPSFCN,FACTOR
C       DOUBLE PRECISION
C       X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),
C      *     WA1(N),WA2(N),WA3(N),WA4(N)
C       EXTERNAL FCN,JAC
C
C 3. Parameters.
C
C       Parameters designated as input parameters must be specified on
C       entry to DNSQ and are not changed on exit, while parameters
C       designated as output parameters need not be specified on entry
C       and are set to appropriate values on exit from DNSQ.
C
C       FCN is the name of the user-supplied subroutine which calculates
C         the functions.  FCN must be declared in an EXTERNAL statement
C         in the user calling program, and should be written as follows.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         DOUBLE PRECISION X(N),FVEC(N)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by FCN unless the
C         user wants to terminate execution of DNSQ.  In this case set
C         IFLAG to a negative integer.
C
C       JAC is the name of the user-supplied subroutine which calculates
C         the Jacobian.  If IOPT=1, then JAC must be declared in an
C         EXTERNAL statement in the user calling program, and should be
C         written as follows.
C
C         SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG)
C         INTEGER N,LDFJAC,IFLAG
C         DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
C         ----------
C         Calculate the Jacobian at X and return this
C         matrix in FJAC.  FVEC contains the function
C         values at X and should not be altered.
C         ----------
C         RETURN
C         END
C
C         The value of IFLAG should not be changed by JAC unless the
C         user wants to terminate execution of DNSQ.  In this case set
C         IFLAG to a negative integer.
C
C         If IOPT=2, JAC can be ignored (treat it as a dummy argument).
C
C       IOPT is an input variable which specifies how the Jacobian will
C         be calculated.  If IOPT=1, then the user must supply the
C         Jacobian through the subroutine JAC.  If IOPT=2, then the
C         code will approximate the Jacobian by forward-differencing.
C
C       N is a positive integer input variable set to the number of
C         functions and variables.
C
C       X is an array of length N.  On input X must contain an initial
C         estimate of the solution vector.  On output X contains the
C         final estimate of the solution vector.
C
C       FVEC is an output array of length N which contains the functions
C         evaluated at the output X.
C
C       FJAC is an output N by N array which contains the orthogonal
C         matrix Q produced by the QR factorization of the final
C         approximate Jacobian.
C
C       LDFJAC is a positive integer input variable not less than N
C         which specifies the leading dimension of the array FJAC.
C
C       XTOL is a nonnegative input variable.  Termination occurs when
C         the relative error between two consecutive iterates is at most
C         XTOL.  Therefore, XTOL measures the relative error desired in
C         the approximate solution.  Section 4 contains more details
C         about XTOL.
C
C       MAXFEV is a positive integer input variable.  Termination occurs
C         when the number of calls to FCN is at least MAXFEV by the end
C         of an iteration.
C
C       ML is a nonnegative integer input variable which specifies the
C         number of subdiagonals within the band of the Jacobian matrix.
C         If the Jacobian is not banded or IOPT=1, set ML to at
C         least N - 1.
C
C       MU is a nonnegative integer input variable which specifies the
C         number of superdiagonals within the band of the Jacobian
C         matrix.  If the Jacobian is not banded or IOPT=1, set MU to at
C         least N - 1.
C
C       EPSFCN is an input variable used in determining a suitable step
C         for the forward-difference approximation.  This approximation
C         assumes that the relative errors in the functions are of the
C         order of EPSFCN.  If EPSFCN is less than the machine
C         precision, it is assumed that the relative errors in the
C         functions are of the order of the machine precision.  If
C         IOPT=1, then EPSFCN can be ignored (treat it as a dummy
C         argument).
C
C       DIAG is an array of length N.  If MODE = 1 (see below), DIAG is
C         internally set.  If MODE = 2, DIAG must contain positive
C         entries that serve as implicit (multiplicative) scale factors
C         for the variables.
C
C       MODE is an integer input variable.  If MODE = 1, the variables
C         will be scaled internally.  If MODE = 2, the scaling is
C         specified by the input DIAG.  Other values of MODE are
C         equivalent to MODE = 1.
C
C       FACTOR is a positive input variable used in determining the
C         initial step bound.  This bound is set to the product of
C         FACTOR and the Euclidean norm of DIAG*X if nonzero, or else to
C         FACTOR itself.  In most cases FACTOR should lie in the
C         interval (.1,100.).  100. is a generally recommended value.
C
C       NPRINT is an integer input variable that enables controlled
C         printing of iterates if it is positive.  In this case, FCN is
C         called with IFLAG = 0 at the beginning of the first iteration
C         and every NPRINT iterations thereafter and immediately prior
C         to return, with X and FVEC available for printing. appropriate
C         print statements must be added to FCN(see example).  If NPRINT
C         is not positive, no special calls of FCN with IFLAG = 0 are
C         made.
C
C       INFO is an integer output variable.  If the user has terminated
C         execution, INFO is set to the (negative) value of IFLAG.  See
C         description of FCN and JAC. Otherwise, INFO is set as follows.
C
C         INFO = 0  Improper input parameters.
C
C         INFO = 1  Relative error between two consecutive iterates is
C                   at most XTOL.
C
C         INFO = 2  Number of calls to FCN has reached or exceeded
C                   MAXFEV.
C
C         INFO = 3  XTOL is too small.  No further improvement in the
C                   approximate solution X is possible.
C
C         INFO = 4  Iteration is not making good progress, as measured
C                   by the improvement from the last five Jacobian
C                   evaluations.
C
C         INFO = 5  Iteration is not making good progress, as measured
C                   by the improvement from the last ten iterations.
C
C         Sections 4 and 5 contain more details about INFO.
C
C       NFEV is an integer output variable set to the number of calls to
C         FCN.
C
C       NJEV is an integer output variable set to the number of calls to
C         JAC. (If IOPT=2, then NJEV is set to zero.)
C
C       R is an output array of length LR which contains the upper
C         triangular matrix produced by the QR factorization of the
C         final approximate Jacobian, stored rowwise.
C
C       LR is a positive integer input variable not less than
C         (N*(N+1))/2.
C
C       QTF is an output array of length N which contains the vector
C         (Q transpose)*FVEC.
C
C       WA1, WA2, WA3, and WA4 are work arrays of length N.
C
C
C 4. Successful completion.
C
C       The accuracy of DNSQ is controlled by the convergence parameter
C       XTOL.  This parameter is used in a test which makes a comparison
C       between the approximation X and a solution XSOL.  DNSQ
C       terminates when the test is satisfied.  If the convergence
C       parameter is less than the machine precision (as defined by the
C       function D1MACH(4)), then DNSQ only attempts to satisfy the test
C       defined by the machine precision.  Further progress is not
C       usually possible.
C
C       The test assumes that the functions are reasonably well behaved,
C       and, if the Jacobian is supplied by the user, that the functions
C       and the Jacobian are coded consistently.  If these conditions
C       are not satisfied, then DNSQ may incorrectly indicate
C       convergence.  The coding of the Jacobian can be checked by the
C       subroutine DCKDER. If the Jacobian is coded correctly or IOPT=2,
C       then the validity of the answer can be checked, for example, by
C       rerunning DNSQ with a tighter tolerance.
C
C       Convergence Test.  If DENORM(Z) denotes the Euclidean norm of a
C         vector Z and D is the diagonal matrix whose entries are
C         defined by the array DIAG, then this test attempts to
C         guarantee that
C
C               DENORM(D*(X-XSOL)) .LE. XTOL*DENORM(D*XSOL).
C
C         If this condition is satisfied with XTOL = 10**(-K), then the
C         larger components of D*X have K significant decimal digits and
C         INFO is set to 1.  There is a danger that the smaller
C         components of D*X may have large relative errors, but the fast
C         rate of convergence of DNSQ usually avoids this possibility.
C         Unless high precision solutions are required, the recommended
C         value for XTOL is the square root of the machine precision.
C
C
C 5. Unsuccessful Completion.
C
C       Unsuccessful termination of DNSQ can be due to improper input
C       parameters, arithmetic interrupts, an excessive number of
C       function evaluations, or lack of good progress.
C
C       Improper Input Parameters.  INFO is set to 0 if IOPT .LT .1,
C         or IOPT .GT. 2, or N .LE. 0, or LDFJAC .LT. N, or
C         XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0,
C         or FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2.
C
C       Arithmetic Interrupts.  If these interrupts occur in the FCN
C         subroutine during an early stage of the computation, they may
C         be caused by an unacceptable choice of X by DNSQ.  In this
C         case, it may be possible to remedy the situation by rerunning
C         DNSQ with a smaller value of FACTOR.
C
C       Excessive Number of Function Evaluations.  A reasonable value
C         for MAXFEV is 100*(N+1) for IOPT=1 and 200*(N+1) for IOPT=2.
C         If the number of calls to FCN reaches MAXFEV, then this
C         indicates that the routine is converging very slowly as
C         measured by the progress of FVEC, and INFO is set to 2. This
C         situation should be unusual because, as indicated below, lack
C         of good progress is usually diagnosed earlier by DNSQ,
C         causing termination with info = 4 or INFO = 5.
C
C       Lack of Good Progress.  DNSQ searches for a zero of the system
C         by minimizing the sum of the squares of the functions.  In so
C         doing, it can become trapped in a region where the minimum
C         does not correspond to a zero of the system and, in this
C         situation, the iteration eventually fails to make good
C         progress.  In particular, this will happen if the system does
C         not have a zero.  If the system has a zero, rerunning DNSQ
C         from a different starting point may be helpful.
C
C
C 6. Characteristics of The Algorithm.
C
C       DNSQ is a modification of the Powell Hybrid method.  Two of its
C       main characteristics involve the choice of the correction as a
C       convex combination of the Newton and scaled gradient directions,
C       and the updating of the Jacobian by the rank-1 method of
C       Broyden.  The choice of the correction guarantees (under
C       reasonable conditions) global convergence for starting points
C       far from the solution and a fast rate of convergence.  The
C       Jacobian is calculated at the starting point by either the
C       user-supplied subroutine or a forward-difference approximation,
C       but it is not recalculated until the rank-1 method fails to
C       produce satisfactory progress.
C
C       Timing.  The time required by DNSQ to solve a given problem
C         depends on N, the behavior of the functions, the accuracy
C         requested, and the starting point.  The number of arithmetic
C         operations needed by DNSQ is about 11.5*(N**2) to process
C         each evaluation of the functions (call to FCN) and 1.3*(N**3)
C         to process each evaluation of the Jacobian (call to JAC,
C         if IOPT = 1).  Unless FCN and JAC can be evaluated quickly,
C         the timing of DNSQ will be strongly influenced by the time
C         spent in FCN and JAC.
C
C       Storage.  DNSQ requires (3*N**2 + 17*N)/2 single precision
C         storage locations, in addition to the storage required by the
C         program.  There are no internally declared storage arrays.
C
C *Long Description:
C
C 7. Example.
C
C       The problem is to determine the values of X(1), X(2), ..., X(9),
C       which solve the system of tridiagonal equations
C
C       (3-2*X(1))*X(1)           -2*X(2)                   = -1
C               -X(I-1) + (3-2*X(I))*X(I)         -2*X(I+1) = -1, I=2-8
C                                   -X(8) + (3-2*X(9))*X(9) = -1
C C     **********
C
C       PROGRAM TEST
C C
C C     Driver for DNSQ example.
C C
C       INTEGER J,IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,
C      *        NWRITE
C       DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM
C       DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9),
C      *     WA1(9),WA2(9),WA3(9),WA4(9)
C       DOUBLE PRECISION DENORM,D1MACH
C       EXTERNAL FCN
C       DATA NWRITE /6/
C C
C       IOPT = 2
C       N = 9
C C
C C     THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION.
C C
C       DO 10 J = 1, 9
C          X(J) = -1.E0
C    10    CONTINUE
C C
C       LDFJAC = 9
C       LR = 45
C C
C C     SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION.
C C     UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED,
C C     THIS IS THE RECOMMENDED SETTING.
C C
C       XTOL = SQRT(D1MACH(4))
C C
C       MAXFEV = 2000
C       ML = 1
C       MU = 1
C       EPSFCN = 0.E0
C       MODE = 2
C       DO 20 J = 1, 9
C          DIAG(J) = 1.E0
C    20    CONTINUE
C       FACTOR = 1.E2
C       NPRINT = 0
C C
C       CALL DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,MU,
C      *           EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,
C      *           R,LR,QTF,WA1,WA2,WA3,WA4)
C       FNORM = DENORM(N,FVEC)
C       WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N)
C       STOP
C  1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 //
C      *        5X,' NUMBER OF FUNCTION EVALUATIONS',I10 //
C      *        5X,' EXIT PARAMETER',16X,I10 //
C      *        5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7))
C       END
C       SUBROUTINE FCN(N,X,FVEC,IFLAG)
C       INTEGER N,IFLAG
C       DOUBLE PRECISION X(N),FVEC(N)
C       INTEGER K
C       DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO
C       DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/
C C
C       IF (IFLAG .NE. 0) GO TO 5
C C
C C     INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE.
C C
C       RETURN
C     5 CONTINUE
C       DO 10 K = 1, N
C          TEMP = (THREE - TWO*X(K))*X(K)
C          TEMP1 = ZERO
C          IF (K .NE. 1) TEMP1 = X(K-1)
C          TEMP2 = ZERO
C          IF (K .NE. N) TEMP2 = X(K+1)
C          FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE
C    10    CONTINUE
C       RETURN
C       END
C
C       Results obtained with different compilers or machines
C       may be slightly different.
C
C       Final L2 norm of the residuals  0.1192636E-07
C
C       Number of function evaluations        14
C
C       Exit parameter                         1
C
C       Final approximate solution
C
C       -0.5706545E+00 -0.6816283E+00 -0.7017325E+00
C       -0.7042129E+00 -0.7013690E+00 -0.6918656E+00
C       -0.6657920E+00 -0.5960342E+00 -0.4164121E+00
C
C***REFERENCES  M. J. D. Powell, A hybrid method for nonlinear equa-
C                 tions. In Numerical Methods for Nonlinear Algebraic
C                 Equations, P. Rabinowitz, Editor.  Gordon and Breach,
C                 1988.
C***ROUTINES CALLED  D1MACH, D1MPYQ, D1UPDT, DDOGLG, DENORM, DFDJC1,
C                    DQFORM, DQRFAC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DNSQ
CCCCC DOUBLE PRECISION D1MACH,DENORM
      DOUBLE PRECISION DENORM
      INTEGER I, IFLAG, INFO, IOPT, ITER, IWA(1), J, JM1, L, LDFJAC,
     1     LR, MAXFEV, ML, MODE, MU, N, NCFAIL, NCSUC, NFEV, NJEV,
     2     NPRINT, NSLOW1, NSLOW2
      DOUBLE PRECISION ACTRED, DELTA, DIAG(*), EPSFCN, EPSMCH, FACTOR,
     1     FJAC(LDFJAC,*), FNORM, FNORM1, FVEC(*), ONE, P0001, P001,
     2     P1, P5, PNORM, PRERED, QTF(*), R(*), RATIO, SUM, TEMP,
     3     WA1(*), WA2(*), WA3(*), WA4(*), X(*), XNORM, XTOL, ZERO
      REAL XDATA(NOBS)
      EXTERNAL FCN
      LOGICAL JEVAL,SING
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      SAVE ONE, P1, P5, P001, P0001, ZERO
      DATA ONE,P1,P5,P001,P0001,ZERO
     1     /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 320
C***FIRST EXECUTABLE STATEMENT  DNSQ
         EPSMCH = D1MACH(4)
C
         INFO = 0
         IFLAG = 0
         NFEV = 0
         NJEV = 0
C
C        CHECK THE INPUT PARAMETERS FOR ERRORS.
C
C     ...EXIT
         IF (IOPT .LT. 1 .OR. IOPT .GT. 2 .OR. N .LE. 0
     1       .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 .OR. ML .LT. 0
     2       .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO .OR. LDFJAC .LT. N
     3       .OR. LR .LT. (N*(N + 1))/2) GO TO 320
         IF (MODE .NE. 2) GO TO 20
            DO 10 J = 1, N
C     .........EXIT
               IF (DIAG(J) .LE. ZERO) GO TO 320
   10       CONTINUE
   20    CONTINUE
C
C        EVALUATE THE FUNCTION AT THE STARTING POINT
C        AND CALCULATE ITS NORM.
C
         IFLAG = 1
         CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS)
         NFEV = 1
C     ...EXIT
         IF (IFLAG .LT. 0) GO TO 320
         FNORM = DENORM(N,FVEC)
C
C        INITIALIZE ITERATION COUNTER AND MONITORS.
C
         ITER = 1
         NCSUC = 0
         NCFAIL = 0
         NSLOW1 = 0
         NSLOW2 = 0
C
C        BEGINNING OF THE OUTER LOOP.
C
   30    CONTINUE
C           BEGIN BLOCK PERMITTING ...EXITS TO 90
               JEVAL = .TRUE.
C
C              CALCULATE THE JACOBIAN MATRIX.
C
               IF (IOPT .EQ. 2) GO TO 40
C
C                 USER SUPPLIES JACOBIAN
C
                  CALL JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG)
                  NJEV = NJEV + 1
               GO TO 50
   40          CONTINUE
C
C                 CODE APPROXIMATES THE JACOBIAN
C
                  IFLAG = 2
                  CALL DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,
     1                        EPSFCN,WA1,WA2,XDATA,NOBS)
                  NFEV = NFEV + MIN(ML+MU+1,N)
   50          CONTINUE
C
C     .........EXIT
               IF (IFLAG .LT. 0) GO TO 320
C
C              COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
C
               CALL DQRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
C
C              ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
C              TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
C
C           ...EXIT
               IF (ITER .NE. 1) GO TO 90
               IF (MODE .EQ. 2) GO TO 70
                  DO 60 J = 1, N
                     DIAG(J) = WA2(J)
                     IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
   60             CONTINUE
   70          CONTINUE
C
C              ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED
C              X AND INITIALIZE THE STEP BOUND DELTA.
C
               DO 80 J = 1, N
                  WA3(J) = DIAG(J)*X(J)
   80          CONTINUE
               XNORM = DENORM(N,WA3)
               DELTA = FACTOR*XNORM
               IF (DELTA .EQ. ZERO) DELTA = FACTOR
   90       CONTINUE
C
C           FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
C
            DO 100 I = 1, N
               QTF(I) = FVEC(I)
  100       CONTINUE
            DO 140 J = 1, N
               IF (FJAC(J,J) .EQ. ZERO) GO TO 130
                  SUM = ZERO
                  DO 110 I = J, N
                     SUM = SUM + FJAC(I,J)*QTF(I)
  110             CONTINUE
                  TEMP = -SUM/FJAC(J,J)
                  DO 120 I = J, N
                     QTF(I) = QTF(I) + FJAC(I,J)*TEMP
  120             CONTINUE
  130          CONTINUE
  140       CONTINUE
C
C           COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
C
            SING = .FALSE.
            DO 170 J = 1, N
               L = J
               JM1 = J - 1
               IF (JM1 .LT. 1) GO TO 160
               DO 150 I = 1, JM1
                  R(L) = FJAC(I,J)
                  L = L + N - I
  150          CONTINUE
  160          CONTINUE
               R(L) = WA1(J)
               IF (WA1(J) .EQ. ZERO) SING = .TRUE.
  170       CONTINUE
C
C           ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
C
            CALL DQFORM(N,N,FJAC,LDFJAC,WA1)
C
C           RESCALE IF NECESSARY.
C
            IF (MODE .EQ. 2) GO TO 190
               DO 180 J = 1, N
                  DIAG(J) = MAX(DIAG(J),WA2(J))
  180          CONTINUE
  190       CONTINUE
C
C           BEGINNING OF THE INNER LOOP.
C
  200       CONTINUE
C
C              IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
C
               IF (NPRINT .LE. 0) GO TO 210
                  IFLAG = 0
                  IF (MOD(ITER-1,NPRINT) .EQ. 0)
     1               CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS)
C     ............EXIT
                  IF (IFLAG .LT. 0) GO TO 320
  210          CONTINUE
C
C              DETERMINE THE DIRECTION P.
C
               CALL DDOGLG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
C
C              STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
C
               DO 220 J = 1, N
                  WA1(J) = -WA1(J)
                  WA2(J) = X(J) + WA1(J)
                  WA3(J) = DIAG(J)*WA1(J)
  220          CONTINUE
               PNORM = DENORM(N,WA3)
C
C              ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
C
               IF (ITER .EQ. 1) DELTA = MIN(DELTA,PNORM)
C
C              EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
C
               IFLAG = 1
               CALL FCN(N,WA2,WA4,IFLAG,XDATA,NOBS)
               NFEV = NFEV + 1
C     .........EXIT
               IF (IFLAG .LT. 0) GO TO 320
               FNORM1 = DENORM(N,WA4)
C
C              COMPUTE THE SCALED ACTUAL REDUCTION.
C
               ACTRED = -ONE
               IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
C
C              COMPUTE THE SCALED PREDICTED REDUCTION.
C
               L = 1
               DO 240 I = 1, N
                  SUM = ZERO
                  DO 230 J = I, N
                     SUM = SUM + R(L)*WA1(J)
                     L = L + 1
  230             CONTINUE
                  WA3(I) = QTF(I) + SUM
  240          CONTINUE
               TEMP = DENORM(N,WA3)
               PRERED = ZERO
               IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
C
C              COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
C              REDUCTION.
C
               RATIO = ZERO
               IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
C
C              UPDATE THE STEP BOUND.
C
               IF (RATIO .GE. P1) GO TO 250
                  NCSUC = 0
                  NCFAIL = NCFAIL + 1
                  DELTA = P5*DELTA
               GO TO 260
  250          CONTINUE
                  NCFAIL = 0
                  NCSUC = NCSUC + 1
                  IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
     1               DELTA = MAX(DELTA,PNORM/P5)
                  IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
  260          CONTINUE
C
C              TEST FOR SUCCESSFUL ITERATION.
C
               IF (RATIO .LT. P0001) GO TO 280
C
C                 SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
C
                  DO 270 J = 1, N
                     X(J) = WA2(J)
                     WA2(J) = DIAG(J)*X(J)
                     FVEC(J) = WA4(J)
  270             CONTINUE
                  XNORM = DENORM(N,WA2)
                  FNORM = FNORM1
                  ITER = ITER + 1
  280          CONTINUE
C
C              DETERMINE THE PROGRESS OF THE ITERATION.
C
               NSLOW1 = NSLOW1 + 1
               IF (ACTRED .GE. P001) NSLOW1 = 0
               IF (JEVAL) NSLOW2 = NSLOW2 + 1
               IF (ACTRED .GE. P1) NSLOW2 = 0
C
C              TEST FOR CONVERGENCE.
C
               IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
C     .........EXIT
               IF (INFO .NE. 0) GO TO 320
C
C              TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
C
               IF (NFEV .GE. MAXFEV) INFO = 2
               IF (P1*MAX(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
               IF (NSLOW2 .EQ. 5) INFO = 4
               IF (NSLOW1 .EQ. 10) INFO = 5
C     .........EXIT
               IF (INFO .NE. 0) GO TO 320
C
C              CRITERION FOR RECALCULATING JACOBIAN
C
C           ...EXIT
               IF (NCFAIL .EQ. 2) GO TO 310
C
C              CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
C              AND UPDATE QTF IF NECESSARY.
C
               DO 300 J = 1, N
                  SUM = ZERO
                  DO 290 I = 1, N
                     SUM = SUM + FJAC(I,J)*WA4(I)
  290             CONTINUE
                  WA2(J) = (SUM - WA3(J))/PNORM
                  WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
                  IF (RATIO .GE. P0001) QTF(J) = SUM
  300          CONTINUE
C
C              COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
C
               CALL D1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
               CALL D1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
               CALL D1MPYQ(1,N,QTF,1,WA2,WA3)
C
C              END OF THE INNER LOOP.
C
               JEVAL = .FALSE.
            GO TO 200
  310       CONTINUE
C
C           END OF THE OUTER LOOP.
C
         GO TO 30
  320 CONTINUE
C
C     TERMINATION, EITHER NORMAL OR USER IMPOSED.
C
      IF (IFLAG .LT. 0) INFO = IFLAG
      IFLAG = 0
      IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG,XDATA,NOBS)
CCCCC IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'DNSQ',
CCCCC+   'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1)
CCCCC IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'DNSQ',
CCCCC+   'INVALID INPUT PARAMETER.', 2, 1)
CCCCC IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'DNSQ',
CCCCC+   'TOO MANY FUNCTION EVALUATIONS.', 9, 1)
CCCCC IF (INFO .EQ. 3) CALL XERMSG ('SLATEC', 'DNSQ',
CCCCC+   'XTOL TOO SMALL. NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1)
CCCCC IF (INFO .GT. 4) CALL XERMSG ('SLATEC', 'DNSQ',
CCCCC+   'ITERATION NOT MAKING GOOD PROGRESS.', 1, 1)
      IF (INFO .LT. 0) THEN
        WRITE(ICOUT,1001)
 1001   FORMAT('***** ERROR IN DNSQE NON-LINEAR SIMULTANEOUS EQUATION ',
     1         'SOLVER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1003)
 1003   FORMAT('      TERMINATION HALTED BECAUSE IFLAG IS NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 0) THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1004)
 1004   FORMAT('      INVALID INPUT PARAMETER.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 2) THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1005)
 1005   FORMAT('      TOO MANY FUNCTION EVALUATIONS.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .EQ. 3) THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1006)
 1006   FORMAT('      XTOL TOO SMALL.  NO FURTHER IMPROVEMENT ',
     1         'POSSIBLE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (INFO .GT. 4) THEN
        WRITE(ICOUT,1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1007)
 1007   FORMAT('      ITERATION NOT MAKING GOOD PROGRESS.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
C
C     LAST CARD OF SUBROUTINE DNSQ.
C
      END
*DECK DFDJC1
      SUBROUTINE DFDJC1 (FCN, N, X, FVEC, FJAC, LDFJAC, IFLAG, ML, MU,
     +   EPSFCN, WA1, WA2,
     +   XDATA,NOBS)
C***BEGIN PROLOGUE  DFDJC1
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (FDJAC1-S, DFDJC1-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine computes a forward-difference approximation
C     to the N by N Jacobian matrix associated with a specified
C     problem of N functions in N variables. If the Jacobian has
C     a banded form, then function evaluations are saved by only
C     approximating the nonzero terms.
C
C     The subroutine statement is
C
C       SUBROUTINE DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
C                         WA1,WA2)
C
C     where
C
C       FCN is the name of the user-supplied subroutine which
C         calculates the functions. FCN must be declared
C         in an EXTERNAL statement in the user calling
C         program, and should be written as follows.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         DOUBLE PRECISION X(N),FVEC(N)
C         ----------
C         Calculate the functions at X and
C         return this vector in FVEC.
C         ----------
C         RETURN
C
C         The value of IFLAG should not be changed by FCN unless
C         the user wants to terminate execution of DFDJC1.
C         In this case set IFLAG to a negative integer.
C
C       N is a positive integer input variable set to the number
C         of functions and variables.
C
C       X is an input array of length N.
C
C       FVEC is an input array of length N which must contain the
C         functions evaluated at X.
C
C       FJAC is an output N by N array which contains the
C         approximation to the Jacobian matrix evaluated at X.
C
C       LDFJAC is a positive integer input variable not less than N
C         which specifies the leading dimension of the array FJAC.
C
C       IFLAG is an integer variable which can be used to terminate
C         the execution of DFDJC1. See description of FCN.
C
C       ML is a nonnegative integer input variable which specifies
C         the number of subdiagonals within the band of the
C         Jacobian matrix. If the Jacobian is not banded, set
C         ML to at least N - 1.
C
C       EPSFCN is an input variable used in determining a suitable
C         step length for the forward-difference approximation. This
C         approximation assumes that the relative errors in the
C         functions are of the order of EPSFCN. If EPSFCN is less
C         than the machine precision, it is assumed that the relative
C         errors in the functions are of the order of the machine
C         precision.
C
C       MU is a nonnegative integer input variable which specifies
C         the number of superdiagonals within the band of the
C         Jacobian matrix. If the Jacobian is not banded, set
C         MU to at least N - 1.
C
C       WA1 and WA2 are work arrays of length N. If ML + MU + 1 is at
C         least N, then the Jacobian is considered dense, and WA2 is
C         not referenced.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DFDJC1
CCCCC DOUBLE PRECISION D1MACH
      INTEGER I, IFLAG, J, K, LDFJAC, ML, MSUM, MU, N
      DOUBLE PRECISION EPS, EPSFCN, EPSMCH, FJAC(LDFJAC,*),
     1     FVEC(*), H, TEMP, WA1(*), WA2(*), X(*), ZERO
      SAVE ZERO
C
      REAL XDATA(NOBS)
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO /0.0D0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
C***FIRST EXECUTABLE STATEMENT  DFDJC1
      EPSMCH = D1MACH(4)
C
      EPS = SQRT(MAX(EPSFCN,EPSMCH))
      MSUM = ML + MU + 1
      IF (MSUM .LT. N) GO TO 40
C
C        COMPUTATION OF DENSE APPROXIMATE JACOBIAN.
C
         DO 20 J = 1, N
            TEMP = X(J)
            H = EPS*ABS(TEMP)
            IF (H .EQ. ZERO) H = EPS
            X(J) = TEMP + H
            CALL FCN(N,X,WA1,IFLAG,XDATA,NOBS)
            IF (IFLAG .LT. 0) GO TO 30
            X(J) = TEMP
            DO 10 I = 1, N
               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   10          CONTINUE
   20       CONTINUE
   30    CONTINUE
         GO TO 110
   40 CONTINUE
C
C        COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
C
         DO 90 K = 1, MSUM
            DO 60 J = K, N, MSUM
               WA2(J) = X(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS
               X(J) = WA2(J) + H
   60          CONTINUE
            CALL FCN(N,X,WA1,IFLAG,XDATA,NOBS)
            IF (IFLAG .LT. 0) GO TO 100
            DO 80 J = K, N, MSUM
               X(J) = WA2(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS
               DO 70 I = 1, N
                  FJAC(I,J) = ZERO
                  IF (I .GE. J - MU .AND. I .LE. J + ML)
     1               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
  110 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE DFDJC1.
C
      END
*DECK DQRFAC
      SUBROUTINE DQRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA,
     +   ACNORM, WA)
C***BEGIN PROLOGUE  DQRFAC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNLS1, DNLS1E, DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (QRFAC-S, DQRFAC-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   **** Double Precision version of QRFAC ****
C
C     This subroutine uses Householder transformations with column
C     pivoting (optional) to compute a QR factorization of the
C     M by N matrix A. That is, DQRFAC determines an orthogonal
C     matrix Q, a permutation matrix P, and an upper trapezoidal
C     matrix R with diagonal elements of nonincreasing magnitude,
C     such that A*P = Q*R. The Householder transformation for
C     column K, K = 1,2,...,MIN(M,N), is of the form
C
C                           T
C           I - (1/U(K))*U*U
C
C     where U has zeros in the first K-1 positions. The form of
C     this transformation and the method of pivoting first
C     appeared in the corresponding LINPACK subroutine.
C
C     The subroutine statement is
C
C       SUBROUTINE DQRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A.
C
C       N is a positive integer input variable set to the number
C         of columns of A.
C
C       A is an M by N array. On input A contains the matrix for
C         which the QR factorization is to be computed. On output
C         the strict upper trapezoidal part of A contains the strict
C         upper trapezoidal part of R, and the lower trapezoidal
C         part of A contains a factored form of Q (the non-trivial
C         elements of the U vectors described above).
C
C       LDA is a positive integer input variable not less than M
C         which specifies the leading dimension of the array A.
C
C       PIVOT is a logical input variable. If pivot is set .TRUE.,
C         then column pivoting is enforced. If pivot is set .FALSE.,
C         then no column pivoting is done.
C
C       IPVT is an integer output array of length LIPVT. IPVT
C         defines the permutation matrix P such that A*P = Q*R.
C         Column J of P is column IPVT(J) of the identity matrix.
C         If pivot is .FALSE., IPVT is not referenced.
C
C       LIPVT is a positive integer input variable. If PIVOT is
C             .FALSE., then LIPVT may be as small as 1. If PIVOT is
C             .TRUE., then LIPVT must be at least N.
C
C       SIGMA is an output array of length N which contains the
C         diagonal elements of R.
C
C       ACNORM is an output array of length N which contains the
C         norms of the corresponding columns of the input matrix A.
C         If this information is not needed, then ACNORM can coincide
C         with SIGMA.
C
C       WA is a work array of length N. If pivot is .FALSE., then WA
C         can coincide with SIGMA.
C
C***SEE ALSO  DNLS1, DNLS1E, DNSQ, DNSQE
C***ROUTINES CALLED  D1MACH, DENORM
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DQRFAC
      INTEGER M,N,LDA,LIPVT
      INTEGER IPVT(*)
      LOGICAL PIVOT
      SAVE ONE, P05, ZERO
      DOUBLE PRECISION A(LDA,*),SIGMA(*),ACNORM(*),WA(*)
      INTEGER I,J,JP1,K,KMAX,MINMN
      DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
CCCCC DOUBLE PRECISION D1MACH,DENORM
      DOUBLE PRECISION DENORM
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/
C***FIRST EXECUTABLE STATEMENT  DQRFAC
      EPSMCH = D1MACH(4)
C
C     COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS.
C
      DO 10 J = 1, N
         ACNORM(J) = DENORM(M,A(1,J))
         SIGMA(J) = ACNORM(J)
         WA(J) = SIGMA(J)
         IF (PIVOT) IPVT(J) = J
   10    CONTINUE
C
C     REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS.
C
      MINMN = MIN(M,N)
      DO 110 J = 1, MINMN
         IF (.NOT.PIVOT) GO TO 40
C
C        BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION.
C
         KMAX = J
         DO 20 K = J, N
            IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K
   20       CONTINUE
         IF (KMAX .EQ. J) GO TO 40
         DO 30 I = 1, M
            TEMP = A(I,J)
            A(I,J) = A(I,KMAX)
            A(I,KMAX) = TEMP
   30       CONTINUE
         SIGMA(KMAX) = SIGMA(J)
         WA(KMAX) = WA(J)
         K = IPVT(J)
         IPVT(J) = IPVT(KMAX)
         IPVT(KMAX) = K
   40    CONTINUE
C
C        COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE
C        J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR.
C
         AJNORM = DENORM(M-J+1,A(J,J))
         IF (AJNORM .EQ. ZERO) GO TO 100
         IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM
         DO 50 I = J, M
            A(I,J) = A(I,J)/AJNORM
   50       CONTINUE
         A(J,J) = A(J,J) + ONE
C
C        APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS
C        AND UPDATE THE NORMS.
C
         JP1 = J + 1
         IF (N .LT. JP1) GO TO 100
         DO 90 K = JP1, N
            SUM = ZERO
            DO 60 I = J, M
               SUM = SUM + A(I,J)*A(I,K)
   60          CONTINUE
            TEMP = SUM/A(J,J)
            DO 70 I = J, M
               A(I,K) = A(I,K) - TEMP*A(I,J)
   70          CONTINUE
            IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80
            TEMP = A(J,K)/SIGMA(K)
            SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2))
            IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80
            SIGMA(K) = DENORM(M-J,A(JP1,K))
            WA(K) = SIGMA(K)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
         SIGMA(J) = -AJNORM
  110    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE DQRFAC.
C
      END
*DECK DENORM
      DOUBLE PRECISION FUNCTION DENORM (N, X)
C***BEGIN PROLOGUE  DENORM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (ENORM-S, DENORM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an N-vector X, this function calculates the
C     Euclidean norm of X.
C
C     The Euclidean norm is computed by accumulating the sum of
C     squares in three different sums. The sums of squares for the
C     small and large components are scaled so that no overflows
C     occur. Non-destructive underflows are permitted. Underflows
C     and overflows do not occur in the computation of the unscaled
C     sum of squares for the intermediate components.
C     The definitions of small, intermediate and large components
C     depend on two constants, RDWARF and RGIANT. The main
C     restrictions on these constants are that RDWARF**2 not
C     underflow and RGIANT**2 not overflow. The constants
C     given here are suitable for every known computer.
C
C     The function statement is
C
C       DOUBLE PRECISION FUNCTION DENORM(N,X)
C
C     where
C
C       N is a positive integer input variable.
C
C       X is an input array of length N.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DENORM
      INTEGER I, N
      DOUBLE PRECISION AGIANT, FLOATN, ONE, RDWARF, RGIANT, S1, S2, S3,
     1     X(*), X1MAX, X3MAX, XABS, ZERO
      SAVE ONE, ZERO, RDWARF, RGIANT
      DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/
C***FIRST EXECUTABLE STATEMENT  DENORM
      S1 = ZERO
      S2 = ZERO
      S3 = ZERO
      X1MAX = ZERO
      X3MAX = ZERO
      FLOATN = N
      AGIANT = RGIANT/FLOATN
      DO 90 I = 1, N
         XABS = ABS(X(I))
         IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
            IF (XABS .LE. RDWARF) GO TO 30
C
C              SUM FOR LARGE COMPONENTS.
C
               IF (XABS .LE. X1MAX) GO TO 10
                  S1 = ONE + S1*(X1MAX/XABS)**2
                  X1MAX = XABS
                  GO TO 20
   10          CONTINUE
                  S1 = S1 + (XABS/X1MAX)**2
   20          CONTINUE
               GO TO 60
   30       CONTINUE
C
C              SUM FOR SMALL COMPONENTS.
C
               IF (XABS .LE. X3MAX) GO TO 40
                  S3 = ONE + S3*(X3MAX/XABS)**2
                  X3MAX = XABS
                  GO TO 50
   40          CONTINUE
                  IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
   50          CONTINUE
   60       CONTINUE
            GO TO 80
   70    CONTINUE
C
C           SUM FOR INTERMEDIATE COMPONENTS.
C
            S2 = S2 + XABS**2
   80    CONTINUE
   90    CONTINUE
C
C     CALCULATION OF NORM.
C
      IF (S1 .EQ. ZERO) GO TO 100
         DENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
         GO TO 130
  100 CONTINUE
         IF (S2 .EQ. ZERO) GO TO 110
            IF (S2 .GE. X3MAX)
     1         DENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
            IF (S2 .LT. X3MAX)
     1         DENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
            GO TO 120
  110    CONTINUE
            DENORM = X3MAX*SQRT(S3)
  120    CONTINUE
  130 CONTINUE
      RETURN
C
C     LAST CARD OF FUNCTION DENORM.
C
      END
*DECK DQFORM
      SUBROUTINE DQFORM (M, N, Q, LDQ, WA)
C***BEGIN PROLOGUE  DQFORM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (QFORM-S, DQFORM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine proceeds from the computed QR factorization of
C     an M by N matrix A to accumulate the M by M orthogonal matrix
C     Q from its factored form.
C
C     The subroutine statement is
C
C       SUBROUTINE DQFORM(M,N,Q,LDQ,WA)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A and the order of Q.
C
C       N is a positive integer input variable set to the number
C         of columns of A.
C
C       Q is an M by M array. On input the full lower trapezoid in
C         the first MIN(M,N) columns of Q contains the factored form.
C         On output Q has been accumulated into a square matrix.
C
C       LDQ is a positive integer input variable not less than M
C         which specifies the leading dimension of the array Q.
C
C       WA is a work array of length M.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DQFORM
      INTEGER I, J, JM1, K, L, LDQ, M, MINMN, N, NP1
      DOUBLE PRECISION ONE, Q(LDQ,*), SUM, TEMP, WA(*), ZERO
      SAVE ONE, ZERO
      DATA ONE,ZERO /1.0D0,0.0D0/
C
C     ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.
C
C***FIRST EXECUTABLE STATEMENT  DQFORM
      MINMN = MIN(M,N)
      IF (MINMN .LT. 2) GO TO 30
      DO 20 J = 2, MINMN
         JM1 = J - 1
         DO 10 I = 1, JM1
            Q(I,J) = ZERO
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
C
C     INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.
C
      NP1 = N + 1
      IF (M .LT. NP1) GO TO 60
      DO 50 J = NP1, M
         DO 40 I = 1, M
            Q(I,J) = ZERO
   40       CONTINUE
         Q(J,J) = ONE
   50    CONTINUE
   60 CONTINUE
C
C     ACCUMULATE Q FROM ITS FACTORED FORM.
C
      DO 120 L = 1, MINMN
         K = MINMN - L + 1
         DO 70 I = K, M
            WA(I) = Q(I,K)
            Q(I,K) = ZERO
   70       CONTINUE
         Q(K,K) = ONE
         IF (WA(K) .EQ. ZERO) GO TO 110
         DO 100 J = K, M
            SUM = ZERO
            DO 80 I = K, M
               SUM = SUM + Q(I,J)*WA(I)
   80          CONTINUE
            TEMP = SUM/WA(K)
            DO 90 I = K, M
               Q(I,J) = Q(I,J) - TEMP*WA(I)
   90          CONTINUE
  100       CONTINUE
  110    CONTINUE
  120    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE DQFORM.
C
      END
*DECK DDOGLG
      SUBROUTINE DDOGLG (N, R, LR, DIAG, QTB, DELTA, X, WA1, WA2)
C***BEGIN PROLOGUE  DDOGLG
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (DOGLEG-S, DDOGLG-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N matrix A, an N by N nonsingular diagonal
C     matrix D, an M-vector B, and a positive number DELTA, the
C     problem is to determine the convex combination X of the
C     Gauss-Newton and scaled gradient directions that minimizes
C     (A*X - B) in the least squares sense, subject to the
C     restriction that the Euclidean norm of D*X be at most DELTA.
C
C     This subroutine completes the solution of the problem
C     if it is provided with the necessary information from the
C     QR factorization of A. That is, if A = Q*R, where Q has
C     orthogonal columns and R is an upper triangular matrix,
C     then DDOGLG expects the full upper triangle of R and
C     the first N components of (Q transpose)*B.
C
C     The subroutine statement is
C
C       SUBROUTINE DDOGLG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
C
C     where
C
C       N is a positive integer input variable set to the order of R.
C
C       R is an input array of length LR which must contain the upper
C         triangular matrix R stored by rows.
C
C       LR is a positive integer input variable not less than
C         (N*(N+1))/2.
C
C       DIAG is an input array of length N which must contain the
C         diagonal elements of the matrix D.
C
C       QTB is an input array of length N which must contain the first
C         N elements of the vector (Q transpose)*B.
C
C       DELTA is a positive input variable which specifies an upper
C         bound on the Euclidean norm of D*X.
C
C       X is an output array of length N which contains the desired
C         convex combination of the Gauss-Newton direction and the
C         scaled gradient direction.
C
C       WA1 and WA2 are work arrays of length N.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  D1MACH, DENORM
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DDOGLG
CCCCC DOUBLE PRECISION D1MACH,DENORM
      DOUBLE PRECISION DENORM
      INTEGER I, J, JJ, JP1, K, L, LR, N
      DOUBLE PRECISION ALPHA, BNORM, DELTA, DIAG(*), EPSMCH, GNORM,
     1     ONE, QNORM, QTB(*), R(*), SGNORM, SUM, TEMP, WA1(*),
     2     WA2(*), X(*), ZERO
      SAVE ONE, ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,ZERO /1.0D0,0.0D0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
C***FIRST EXECUTABLE STATEMENT  DDOGLG
      EPSMCH = D1MACH(4)
C
C     FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.
C
      JJ = (N*(N + 1))/2 + 1
      DO 50 K = 1, N
         J = N - K + 1
         JP1 = J + 1
         JJ = JJ - K
         L = JJ + 1
         SUM = ZERO
         IF (N .LT. JP1) GO TO 20
         DO 10 I = JP1, N
            SUM = SUM + R(L)*X(I)
            L = L + 1
   10       CONTINUE
   20    CONTINUE
         TEMP = R(JJ)
         IF (TEMP .NE. ZERO) GO TO 40
         L = J
         DO 30 I = 1, J
            TEMP = MAX(TEMP,ABS(R(L)))
            L = L + N - I
   30       CONTINUE
         TEMP = EPSMCH*TEMP
         IF (TEMP .EQ. ZERO) TEMP = EPSMCH
   40    CONTINUE
         X(J) = (QTB(J) - SUM)/TEMP
   50    CONTINUE
C
C     TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.
C
      DO 60 J = 1, N
         WA1(J) = ZERO
         WA2(J) = DIAG(J)*X(J)
   60    CONTINUE
      QNORM = DENORM(N,WA2)
      IF (QNORM .LE. DELTA) GO TO 140
C
C     THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
C     NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.
C
      L = 1
      DO 80 J = 1, N
         TEMP = QTB(J)
         DO 70 I = J, N
            WA1(I) = WA1(I) + R(L)*TEMP
            L = L + 1
   70       CONTINUE
         WA1(J) = WA1(J)/DIAG(J)
   80    CONTINUE
C
C     CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR
C     THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO.
C
      GNORM = DENORM(N,WA1)
      SGNORM = ZERO
      ALPHA = DELTA/QNORM
      IF (GNORM .EQ. ZERO) GO TO 120
C
C     CALCULATE THE POINT ALONG THE SCALED GRADIENT
C     AT WHICH THE QUADRATIC IS MINIMIZED.
C
      DO 90 J = 1, N
         WA1(J) = (WA1(J)/GNORM)/DIAG(J)
   90    CONTINUE
      L = 1
      DO 110 J = 1, N
         SUM = ZERO
         DO 100 I = J, N
            SUM = SUM + R(L)*WA1(I)
            L = L + 1
  100       CONTINUE
         WA2(J) = SUM
  110    CONTINUE
      TEMP = DENORM(N,WA2)
      SGNORM = (GNORM/TEMP)/TEMP
C
C     TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.
C
      ALPHA = ZERO
      IF (SGNORM .GE. DELTA) GO TO 120
C
C     THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
C     FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
C     AT WHICH THE QUADRATIC IS MINIMIZED.
C
      BNORM = DENORM(N,QTB)
      TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
      TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
     1       + SQRT((TEMP-(DELTA/QNORM))**2
     2               +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2))
      ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP
  120 CONTINUE
C
C     FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
C     DIRECTION AND THE SCALED GRADIENT DIRECTION.
C
      TEMP = (ONE - ALPHA)*MIN(SGNORM,DELTA)
      DO 130 J = 1, N
         X(J) = TEMP*WA1(J) + ALPHA*X(J)
  130    CONTINUE
  140 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE DDOGLG.
C
      END
*DECK D1UPDT
      SUBROUTINE D1UPDT (M, N, S, LS, U, V, W, SING)
C***BEGIN PROLOGUE  D1UPDT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (R1UPDT-S, D1UPDT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N lower trapezoidal matrix S, an M-vector U,
C     and an N-vector V, the problem is to determine an
C     orthogonal matrix Q such that
C
C                   t
C           (S + U*V )*Q
C
C     is again lower trapezoidal.
C
C     This subroutine determines Q as the product of 2*(N - 1)
C     transformations
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     where GV(I), GW(I) are Givens rotations in the (I,N) plane
C     which eliminate elements in the I-th and N-th planes,
C     respectively. Q itself is not accumulated, rather the
C     information to recover the GV, GW rotations is returned.
C
C     The SUBROUTINE statement is
C
C       SUBROUTINE D1UPDT(M,N,S,LS,U,V,W,SING)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of S.
C
C       N is a positive integer input variable set to the number
C         of columns of S. N must not exceed M.
C
C       S is an array of length LS. On input S must contain the lower
C         trapezoidal matrix S stored by columns. On output S contains
C         the lower trapezoidal matrix produced as described above.
C
C       LS is a positive integer input variable not less than
C         (N*(2*M-N+1))/2.
C
C       U is an input array of length M which must contain the
C         vector U.
C
C       V is an array of length N. On input V must contain the vector
C         V. On output V(I) contains the information necessary to
C         recover the Givens rotation GV(I) described above.
C
C       W is an output array of length M. W(I) contains information
C         necessary to recover the Givens rotation GW(I) described
C         above.
C
C       SING is a LOGICAL output variable. SING is set TRUE if any
C         of the diagonal elements of the output S are zero. Otherwise
C         SING is set FALSE.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  D1UPDT
CCCCC DOUBLE PRECISION D1MACH
      INTEGER I, J, JJ, L, LS, M, N, NM1, NMJ
      DOUBLE PRECISION COS, COTAN, GIANT, ONE, P25, P5, S(*),
     1     SIN, TAN, TAU, TEMP, U(*), V(*), W(*), ZERO
      LOGICAL SING
      SAVE ONE, P5, P25, ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/
C
C     GIANT IS THE LARGEST MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  D1UPDT
      GIANT = D1MACH(2)
C
C     INITIALIZE THE DIAGONAL ELEMENT POINTER.
C
      JJ = (N*(2*M - N + 1))/2 - (M - N)
C
C     MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
C
      L = JJ
      DO 10 I = N, M
         W(I) = S(L)
         L = L + 1
   10    CONTINUE
C
C     ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
C     IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 NMJ = 1, NM1
         J = N - NMJ
         JJ = JJ - (M - J + 1)
         W(J) = ZERO
         IF (V(J) .EQ. ZERO) GO TO 50
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF V.
C
         IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20
            COTAN = V(N)/V(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 30
   20    CONTINUE
            TAN = V(J)/V(N)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
   30    CONTINUE
C
C        APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
C        NECESSARY TO RECOVER THE GIVENS ROTATION.
C
         V(N) = SIN*V(J) + COS*V(N)
         V(J) = TAU
C
C        APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
C
         L = JJ
         DO 40 I = J, M
            TEMP = COS*S(L) - SIN*W(I)
            W(I) = SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
C
      DO 80 I = 1, M
         W(I) = W(I) + V(N)*U(I)
   80    CONTINUE
C
C     ELIMINATE THE SPIKE.
C
      SING = .FALSE.
      IF (NM1 .LT. 1) GO TO 140
      DO 130 J = 1, NM1
         IF (W(J) .EQ. ZERO) GO TO 120
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF THE SPIKE.
C
         IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90
            COTAN = S(JJ)/W(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 100
   90    CONTINUE
            TAN = W(J)/S(JJ)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
  100    CONTINUE
C
C        APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
C
         L = JJ
         DO 110 I = J, M
            TEMP = COS*S(L) + SIN*W(I)
            W(I) = -SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
  110       CONTINUE
C
C        STORE THE INFORMATION NECESSARY TO RECOVER THE
C        GIVENS ROTATION.
C
         W(J) = TAU
  120    CONTINUE
C
C        TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
C
         IF (S(JJ) .EQ. ZERO) SING = .TRUE.
         JJ = JJ + (M - J + 1)
  130    CONTINUE
  140 CONTINUE
C
C     MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
C
      L = JJ
      DO 150 I = N, M
         S(L) = W(I)
         L = L + 1
  150    CONTINUE
      IF (S(JJ) .EQ. ZERO) SING = .TRUE.
      RETURN
C
C     LAST CARD OF SUBROUTINE D1UPDT.
C
      END
*DECK D1MPYQ
      SUBROUTINE D1MPYQ (M, N, A, LDA, V, W)
C***BEGIN PROLOGUE  D1MPYQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNSQ and DNSQE
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (R1MPYQ-S, D1MPYQ-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N matrix A, this subroutine computes A*Q where
C     Q is the product of 2*(N - 1) transformations
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     and GV(I), GW(I) are Givens rotations in the (I,N) plane which
C     eliminate elements in the I-th and N-th planes, respectively.
C     Q itself is not given, rather the information to recover the
C     GV, GW rotations is supplied.
C
C     The SUBROUTINE statement is
C
C       SUBROUTINE D1MPYQ(M,N,A,LDA,V,W)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A.
C
C       N IS a positive integer input variable set to the number
C         of columns of A.
C
C       A is an M by N array. On input A must contain the matrix
C         to be postmultiplied by the orthogonal matrix Q
C         described above. On output A*Q has replaced A.
C
C       LDA is a positive integer input variable not less than M
C         which specifies the leading dimension of the array A.
C
C       V is an input array of length N. V(I) must contain the
C         information necessary to recover the Givens rotation GV(I)
C         described above.
C
C       W is an input array of length N. W(I) must contain the
C         information necessary to recover the Givens rotation GW(I)
C         described above.
C
C***SEE ALSO  DNSQ, DNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  D1MPYQ
      INTEGER I, J, LDA, M, N, NM1, NMJ
      DOUBLE PRECISION A(LDA,*), COS, ONE, SIN, TEMP, V(*), W(*)
      SAVE ONE
      DATA ONE /1.0D0/
C
C     APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
C
C***FIRST EXECUTABLE STATEMENT  D1MPYQ
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 50
      DO 20 NMJ = 1, NM1
         J = N - NMJ
         IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
         IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(V(J)) .LE. ONE) SIN = V(J)
         IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 10 I = 1, M
            TEMP = COS*A(I,J) - SIN*A(I,N)
            A(I,N) = SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
C
      DO 40 J = 1, NM1
         IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
         IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(W(J)) .LE. ONE) SIN = W(J)
         IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 30 I = 1, M
            TEMP = COS*A(I,J) + SIN*A(I,N)
            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE D1MPYQ.
C
      END
      SUBROUTINE LOGFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LOGISTIC MAXIMUM LIKELIHOOD EQUATIONS.
C
C              SUM[i=1 to n][1+EXP{-(X(i)-ahat)/bhat}]**(-1)-N/2 = 0
C
C              (X(i)-ahat)/bhat)/SUM[i=1 to n][1+EXP{-(X(i)-ahat)}]**(-1)
C              - 0.5*SUM[i=1 to n][(X(i)-ahat)/bhat] - 0.5*N = 0
C
C              CALLED BY SNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--PARETO MAXIMUM LIKELIHOOD Y
C     REFERENCE--CHARLES ANTLE, LAWRENCE KLIMKO, AND WILLIAM
C                HARKNESS, (1970), "CONFIDENCE INTERVALS FOR THE
C                PARAMETERS OF THE LOGISTIC DISTRIBUTION", BIOMETRIKA,
C                PP. 397-402.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/10
C     ORIGINAL VERSION--OCTOBER   2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(NOBS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DA=X(1)
      DB=X(2)
      DO100I=1,NOBS
        DX=DBLE(XDATA(I))
        DTERM1=(DX - DA)/DB
        DTERM2=1.0D0 + DEXP(-DTERM1)
        DSUM1=DSUM1 + 1.0D0/DTERM2
        DSUM2=DSUM2 + DTERM1/DTERM2
        DSUM3=DSUM3 + DTERM1
  100 CONTINUE
C
      DTERM1=DSUM1 - 0.5D0*DN
      DTERM2=DSUM2 - 0.5D0*DSUM3 - 0.5D0*DN
C
C COMPUTE NONLINEAR FUNCTIONS
C
      FVEC(1) = DTERM1
      FVEC(2) = DTERM2
C
      RETURN
      END
      SUBROUTINE CAUFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              CAUCHY MAXIMUM LIKELIHOOD EQUATIONS (FROM
C              P. 310 OF JOHNSON, KOTZ, AND BALKRISHNAN (VOLUME 1).
C
C      SUM[i=1 to n][2*(X(i)-ahat)/(bhat^2+(X(i)-ahat)^2) = 0
C
C      N/BAT - SUM[i=1 to n][2*bhat/(bhat^2 + (X(i)-ahat))^2)] = 0
C
C              FOR COMPUTATIONAL PURPOSES, THESE EQUATIONS ARE
C              REWRITTEN AS:
C
C      SUM[i=1 to n][1/(1 + ((X(i) - THETAHAT)/LAMBDA^2)^2)] - N/2 = 0
C      SUM[i=1 to n][X(i)/(1 + ((X(i) - THETAHAT)/LAMBDA)^2)]
C                    - (N/2)*THETAHAT = 0
C
C              THE MAXIMUM LIKELIHOOD EQUATIONS GIVEN IN HAAS,
C              BAIN, AND ANTLE ARE
C
C      SUM[i=1 to n][((X(i)-AHAT)/BHAT)/(1+(X(I)-AHAT)/BHAT)^2)] = 0
C      SUM[i=1 to n][{1 + (X(i)-AHAT)/BHAT)^2}^(-1)] - (1/2)*N = 0
C    
C              CALLED BY SNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--CAUCHY MAXIMUM LIKELIHOOD Y
C     REFERENCE--GERALD HAAS, LEE BAIN, CHARLES ANTLE, (1970).
C                "INFERENCES FOR THE CAUCHY DISTRIBUTION BASED ON
C                MAXIMUM LIKELIHOOD ESTIMATORS", BIOMETRIKA,
C                PP. 403-408.
C              --"CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME I",
C                SECOND EDITION, JOHNSON, KOTZ, AND BALAKRISHNAN,
C                WILEY, 1994,, PP. 310-311.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/3
C     ORIGINAL VERSION--MARCH     2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  SET IFLAG = 0 FOR JOHNSON, KOTZ, BALAKRISHNAN FORM
C      IFLAG = 1 FOR HAAS, BAIN, AND ANTLE
C
C  COMPUTE SOME SUMS
C
      DN=DBLE(NOBS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DA=X(1)
      DB=X(2)
      IFLAG=0
C
      IF(IFLAG.EQ.0)THEN
        DO100I=1,NOBS
          DX=DBLE(XDATA(I))
          DSUM1=DSUM1 + 1.0D0/(1.0D0 + ((DX-DA)/DB)**2)
          DSUM2=DSUM2 + DX/(1.0D0 + ((DX-DA)/DB)**2)
  100   CONTINUE
        FVEC(1) = DSUM1 - DN/2.0D0
        FVEC(2) = DSUM2 - (DN/2.0D0)*DA
      ELSE
        DO200I=1,NOBS
          DX=(DBLE(XDATA(I))-DA)/DB
          DSUM1=DSUM1 + DX/(1.0D0 + DX*DX)
          DSUM2=DSUM2 + 1.0D0/(1.0D0 + DX*DX)
  200   CONTINUE
        FVEC(1) = DSUM1
        FVEC(2) = DSUM2 - 0.5D0*DN
      ENDIF
C
      RETURN
      END
      SUBROUTINE BETFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              BETA MAXIMUM LIKELIHOOD EQUATIONS.
C
C              DIGAMMA(PHAT) - DIGAMMA(PHAT + QHAT) -
C                 SUM[I=1 TO N][LOG((X(I)-A)/(B-A))] = 0
C
C              DIGAMMA(QHAT) - DIGAMMA(PHAT + QHAT) -
C                 SUM[I=1 TO N][LOG((B - X(I))/(B-A))] = 0
C
C              WITH A AND B DENOTING THE LOWER AND UPPER LIMIT
C              PARAMETERS, RESPECTIVELY.
C
C              WE FOLLOW THE TECHNIQUE OF SETTING A AND B TO THE
C              DATA MINIMUM AND MAXIMUM, RESPECTIVELY AND TREATING
C              THEM AS "KNOWN" AS OPPOSSED TO THE FULL 4-PARAMETER
C              MAXIMUM LIKELIHOOD SOLUTION.
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--BETA MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS: VOLUME 2", SECOND EDITION,
C                JOHN WILEY, P. 223.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DPSI
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DP
      DOUBLE PRECISION DQ
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /BETAML/ BETALL, BETAUL
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  ALLOW FOR USER SPECIFIED LOWER/UPPER LIMITS, OTHERWISE USE DATA
C  MINIMUM AND MAXIMUM
C
      IF(BETALL.EQ.CPUMIN .OR. BETAUL.EQ.CPUMIN)THEN
        A=XDATA(1)
        B=XDATA(1)
        DO100I=1,NOBS
          IF(XDATA(I).LT.A)A=XDATA(I)
          IF(XDATA(I).GT.B)B=XDATA(I)
  100   CONTINUE
      ELSE
        A=BETALL
        B=BETAUL
      ENDIF
C
C  COMPUTE SOME SUMS
C
      DA=DBLE(A)
      DB=DBLE(B)
C
      DN=DBLE(NOBS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DP=DBLE(X(1))
      DQ=DBLE(X(2))
C
      DTERM1=DPSI(DP)
      DTERM2=DPSI(DQ)
      DTERM3=DPSI(DP+DQ)
C
C  IN ORDER TO AVOID LOG OF NON-POSITIVE NUMBER, EXCLUDE VALUES
C  THAT ARE EQUAL TO A OR B
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      N1=0
      N2=0
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DTERM4=(DX - DA)/(DB - DA)
        DTERM5=(DB - DX)/(DB - DA)
        IF(DTERM4.GT.0.0D0)THEN
          DSUM1=DSUM1 + DLOG(DTERM4)
          N1=N1+1
        ENDIF
        IF(DTERM5.GT.0.0D0)THEN
          DSUM2=DSUM2 + DLOG(DTERM5)
          N2=N2+1
        ENDIF
  200 CONTINUE
C
      IF(N1.GT.0)THEN
        FVEC(1)=DTERM1 - DTERM3 - DSUM1/DBLE(N1)
      ELSE
        FVEC(1)=0.0
      ENDIF
      IF(N2.GT.0)THEN
        FVEC(2)=DTERM2 - DTERM3 - DSUM2/DBLE(N2)
      ELSE
        FVEC(2)=0.0
      ENDIF
C
CCCCC if(iflag.eq.0)then
CCCCC   print *,'nobs,a,b=',nobs,a,b
CCCCC   print *,'dp,dq=',dp,dq
CCCCC   print *,'dterm1,dterm2,dterm3=',dterm1,dterm2,dterm3
CCCCC   print *,'dsum1,dsum2=',dsum1,dsum2
CCCCC   print *,'fvec(1),fvec(2)=',fvec(1),fvec(2)
CCCCC endif
C
      RETURN
      END
      SUBROUTINE GPAFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              GENERALIZED PARETO MAXIMUM LIKELIHOOD EQUATIONS.
C
C              [1 + (1/N)*SUM[i=1 to N][LOG(1 - Chat*X(i)/Khat]*
C                 [(1/N)*SUM[i=1 to N][1/(1 + Chat*X(i)/Khat)] - 1 = 0
C                 SUM[I=1 TO N][LOG((X(I)-A)/(B-A))] = 0
C
C              Chat + (1/N)*SUM[i=1 to N][LOG(1 - Chat*X(i)/Khat] = 0
C
C              WITH C AND K DENOTING THE SHAPE PARAMETERS,
C              RESPECTIVELY.
C
C              NOTE THAT MAXIMUM LIKELIHOOD ESTIMATION ONLY WORKS
C              WELL IF C < 1/2.
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--GENERALIZED PARETO MAXIMUM LIKELIHOOD Y
C     REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994).  "CONTINUOUS
C                UNIVARIATE DISTRIBUTIONS: VOLUME 1", SECOND EDITION,
C                JOHN WILEY, PP. 614-619.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/11
C     ORIGINAL VERSION--NOVEMBER  2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DC=X(1)
      DK=X(2)
      DN=DBLE(NOBS)
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,NOBS
        DX=DBLE(XDATA(I))
        DSUM1=DSUM1 + DLOG(1.0D0 - DC*DX/DK)
        DSUM2=DSUM2 + 1.0D0/(1.0D0 + DC*DX/DK)
  200 CONTINUE
C
      FVEC(1)=(1.0D0 + (1.0D0/DN)*DSUM1)*((1.0D0/DN)*DSUM2) - 1.0D0
      FVEC(2)=DC + (1.0D0/DN)*DSUM1
C
      RETURN
      END