* SELECTED ROUTINES FROM STARPAC LIBRARY (FOR DIGITAL FILTERING * AND ARIMA MODELING). MODIFIED FOR DATAPLOT BY ALAN HECKERT * FEBRUARY, 1999. MODIFICATIONS ARE TO INCORPORATE I/O INTO * DATAPLOT SCHEME, NOT NUMERICAL MODIFICATIONS. *ABSCOM SUBROUTINE ABSCOM(N, V, W, ABSTOL, NFAIL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES THE NUMBER OF TIMES THE C ABSOLUTE DIFFERENCE BETWEEN V(I) AND W(I), I = 1, 2, ..., N, C IS GREATER THAN ABSTOL . C C WRITTEN BY - ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON) C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ABSTOL INTEGER + N,NFAIL C C ARRAY ARGUMENTS DOUBLE PRECISION + V(*),W(*) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ABSTOL C THE ABSOLUTE TOLERANCE USED IN THE COMPARISON. C INTEGER I C AN INDEXING VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAIL C THE TOTAL NUMBER OF FAILURES. C DOUBLE PRECISION V(N), W(N) C THE VALUES BEING COMPARED. C 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 NFAIL = 0 C DO 10 I = 1, N IF (ABS(V(I) - W(I)) .GT. ABSTOL) NFAIL = NFAIL + 1 10 CONTINUE C RETURN C END *AMFMN SUBROUTINE AMFMN (PAR, PV, Y, NPAR, N, NFAC, MSPECT, + PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, MBOL, N1, N2, NPRT, + SAVE, NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD, F, + FSD, NPARAR, NPARMA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN ROUTINE FOR COMPUTING AND PRINTING THE ARIMA C FORECASTS C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFCST,MBO,MBOL,N,N1,N2,NFAC,NFCST,NFCSTO,NPAR,NPARAR, + NPARDF,NPARMA,NPRT LOGICAL + SAVE C C ARRAY ARGUMENTS DOUBLE PRECISION + F(*),FCST(IFCST,*),FCSTSD(*),FSD(*),PAR(*),PARAR(*),PARDF(*), + PARMA(*),PV(N1:N2),T(*),TEMP(*),Y(*) INTEGER + IFCSTO(*),MSPECT(NFAC,4) C C LOCAL SCALARS DOUBLE PRECISION + CONST,PMU,RSD,RSS,T975,WSUM,WSUMT INTEGER + I,I1,IDF,IF,IFC,IFLAG,IFO,IFOMIN,J,K,NT LOGICAL + PAGE C C EXTERNAL FUNCTIONS DOUBLE PRECISION + PPFT,DDOT EXTERNAL PPFT,DDOT C C EXTERNAL SUBROUTINES EXTERNAL AMFHDR,AMFOUT,AMLST,DCOEF,MDLTS2,MODSUM,MULTBP C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION CONST C THE CONSTANT TERM IN THE MODEL, MODELING EITHER THE SERIES C MEAN OR A DETERMINISTIC TREND. C DOUBLE PRECISION F(NFCST) C THE FORECASTS. C DOUBLE PRECISION FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C DOUBLE PRECISION FCSTSD(NFCST) C THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS. C DOUBLE PRECISION FSD(NFCST) C THE STANDARD DEVIATIONS OF THE FORECASTS. C INTEGER I C AN INDEX VARIABLE. C INTEGER IF C AN INDEX VARIABLE. C INTEGER IFCST C THE FIRST DIMENSION OF THE ARRAY FCST. C INTEGER IFCSTO(NFCSTO) C THE INDICES OF THE ORIGINS FOR THE FORECASTS. C INTEGER IFLAG C AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS C WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1). C INTEGER IFO C THE INDEX OF THE ORIGIN BEING USED. C INTEGER IFOMIN C THE SMALLEST ORIGIN USED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER I1 C AN INDEX VALUE. C INTEGER J C AN INDEX VARIABLE. C INTEGER K C AN INDEX VARIABLE. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPECT(NFAC,4) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFCST C THE NUMBER OF FORECASTS. C INTEGER NFCSTO C THE NUMBER OF THE ORIGINS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C INTEGER NT C THE NUMBER OF PARAMETERS IN T, WHERE NT = MBOL C INTEGER N1 C THE LOWER BOUND FOR PV. C INTEGER N2 C THE UPPER BOUND FOR PV. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PARAR(MBO) C THE AUTOREGRESSIVE PARAMETERS C DOUBLE PRECISION PARDF(NPARDF) C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS. C DOUBLE PRECISION PARMA(MBO) C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C DOUBLE PRECISION PV(N1:N2) C THE PREDICTED VALUE OF THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION T(2*MBO) C A TEMPORARY WORK VECTOR. C DOUBLE PRECISION TEMP(MBO) C A TEMPORARY WORK VECTOR C DOUBLE PRECISION T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C DOUBLE PRECISION WSUM C THE SUM OF THE WEIGHTS SQUARED, USED TO COMPUTE THE C STANDARD DEVIATION OF THE FORECAST. C DOUBLE PRECISION WSUMT C A TEMPORARY STORAGE LOCATION FOR WSUM. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C C COMMON/ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 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 CCCCC CALL IPRINT (IPRT) C C COMPUTE DIFFERENCING PARAMETERS C CALL DCOEF (NFAC, MSPECT(1,2), MSPECT(1,4), NPARDF, PARDF, MBO, T) C C COMPUTE RESIDUALS, GIVEN VALUES OF PARAMETERS C CALL MDLTS2 (PAR, PV, Y, NPAR, N, NFAC, MSPECT, PMU, + PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, N1, N2, IFLAG) IDF = N - NPARDF - NPAR RSS = DDOT(N, PV(1), 1, PV(1), 1) RSD = SQRT(RSS / IDF) C C PRINT INITIAL SUMMARY C PAGE = .FALSE. IF (NPRT.EQ.0) GO TO 10 CALL AMFHDR(PAGE, .TRUE., 2) CALL MODSUM(NFAC, MSPECT) CALL AMLST(2, PAR, NPAR, NFAC, MSPECT, N, PAR, NPAR, PAR, + NPAR, PAR, NPAR, PAR, RSS, RSD, NPARDF, NPAR, IDF) PAGE = .TRUE. C 10 CONTINUE C C COMBINE PARDF AND PARAR INTO T C NT = NPARAR + NPARDF CALL MULTBP(PARAR, NPARAR, PARDF, NPARDF, T, NT, MBO) C C COMPUTE CONSTANT C CONST = 0.0D0 IF (PMU.NE.0.0D0) THEN IF (NPARAR.GE.1) THEN DO 20 J = 1, NPARAR CONST = CONST - PARAR(J) 20 CONTINUE END IF CONST = (1.0D0 + CONST) * PMU END IF C C FIND LOWEST ORIGIN C IFOMIN = IFCSTO(1) DO 30 IFO = 1, NFCSTO IFOMIN = MIN(IFOMIN, IFCSTO(IFO)) 30 CONTINUE C C SET TEMP TO BACKFORECAST OF Y IF NECESSARY C IF ((MBOL.GE.1) .AND. (IFOMIN.LT.MBOL)) THEN I1 = IFOMIN-MBOL+1 DO 60 I = 0, I1, -1 K = 1-I TEMP(K) = CONST DO 40 J = 1, MBOL IF (I+J.LE.N) THEN IF (I+J.GE.1) THEN TEMP(K) = TEMP(K) + T(J)*Y(I+J) ELSE TEMP(K) = TEMP(K) + T(J)*TEMP(MBOL-I-J) END IF END IF 40 CONTINUE IF (NPARMA.GE.1) THEN DO 50 J =1, NPARMA IF (I+J.LE.N) TEMP(K) = TEMP(K) - PARMA(J)*PV(I+J) 50 CONTINUE END IF 60 CONTINUE END IF C C COMPUTE WEIGHTS FOR COMPUTING STANDARD DEVIATIONS OF THE FORECAST C DO 65 J = 1, NFCST FSD(J) = 0.0D0 IF (MBOL.GE.1) THEN DO 64 I = 1, MBOL IF (J-I.GE.1) THEN FSD(J) = FSD(J) + T(I)*FSD(J-I) ELSE IF (J-I.EQ.0) FSD(J) = FSD(J) + T(I) END IF 64 CONTINUE END IF IF (J.LE.NPARMA) FSD(J) = FSD(J) - PARMA(J) 65 CONTINUE C C COMPUTE STANDARD DEVIATIONS OF FORECASTS C WSUM = 1.0D0 DO 66 I = 1, NFCST WSUMT =WSUM WSUM = WSUM + FSD(I)*FSD(I) FSD(I) = SQRT(WSUMT)*RSD 66 CONTINUE C C SET PERCENT POINT VALUE FOR 95 PERCENT CONFIDENCE LIMITS C T975 = PPFT(0.975D0, N-NPAR) C C COMPUTE FORECASTS FOR EACH ORIGIN C DO 100 IFO = 1, NFCSTO IFC = IFCSTO(IFO) IF ((IFC.LT.1) .OR. (IFC.GT.N)) IFC = N DO 90 IF = 1, NFCST F(IF) = CONST IF (MBOL.GE.1) THEN DO 70 J = 1, MBOL K = IF + IFC-J IF (K.LE.0) THEN F(IF) = F(IF) + T(J)*TEMP(1-K) ELSE IF (K.LE.IFC) THEN F(IF) = F(IF) + T(J)*Y(K) ELSE F(IF) = F(IF) + T(J)*F(IF-J) END IF END IF 70 CONTINUE END IF IF (NPARMA.GE.1) THEN DO 80 J = 1, NPARMA K = IF + IFC - J IF (K.LE.IFC) F(IF) = F(IF) - PARMA(J)*PV(K) 80 CONTINUE END IF IF (SAVE) FCST(IF,IFO) = F(IF) 90 CONTINUE C C PRINT RESULTS FROM THIS ORIGIN C C C WRITE INDEX, FORECAST, SD FORECAST, 95% CONFIDENCE INTERVAL TO C FILE. C DO2000I=1,NFCST NTEMP=N+I FLOW=F(I)-T975*FSD(I) FHIGH=F(I)+T975*FSD(I) WRITE(IOUNI5,2001)NTEMP,F(I),FSD(I),FLOW,FHIGH 2001 FORMAT(I5,1X,4E17.8) 2000 CONTINUE C IF (NPRT.NE.0) + CALL AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y, T975, + PAGE) C 100 CONTINUE C RETURN C END *EIAGEP SUBROUTINE EIAGEP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV, + NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE ERROR MESSAGES FOR ERAGT AND ERAGTM. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JUNE 10, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MSGTYP,NV,NVMX,YMMN LOGICAL + HEAD C C ARRAY ARGUMENTS CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE. C IF (MSGTYP.GE.3) THE MESSAGE PRINTED WILL USE NMMIN C OTHERWISE IT WILL USE YMMN. C IF (MSGTYP = 1 OR 3) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 2 OR 4) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE PARAMETERS NAME. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C INTEGER YMMN C THE MINIMUM ACCEPTABLE VALUE. 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 CCCCC CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C IF (MSGTYP.LE.2) + WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), YMMN, NV IF (MSGTYP.GE.3) THEN WRITE (ICOUT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV CALL DPWRST('XXX','BUG ') ENDIF C GO TO (10, 20, 30, 40), MSGTYP C 10 WRITE(ICOUT, 1010) (NMVAR(I),I=1,6), YMMN CALL DPWRST('XXX','BUG ') RETURN C 20 WRITE(ICOUT, 1020) (NMVAR(I),I=1,6), YMMN CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1021) NVMX CALL DPWRST('XXX','BUG ') RETURN C 30 WRITE(ICOUT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') RETURN C 40 WRITE(ICOUT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1041) NVMX CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT ( + ' THE NUMBER OF VALUES IN ARRAY ', 6A1, + ' LESS THAN ', I5, ' IS ', I6, '.') 1005 FORMAT ( + ' THE NUMBER OF VALUES IN ARRAY ', 6A1, + ' LESS THAN ', 8A1, ' IS ', I6, '.') 1010 FORMAT( + ' THE VALUES IN THE ARRAY ', 6A1, + ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.') 1020 FORMAT( + ' THE NUMBER OF VALUES IN THE ARRAY ', 6A1, + ' LESS THAN ', I5) 1021 FORMAT( + ' MUST BE LESS THAN ', I5, '.') 1030 FORMAT( + ' THE VALUES IN THE ARRAY ', 6A1, + ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.') 1040 FORMAT( + ' THE NUMBER OF VALUES IN THE ARRAY ', 6A1, + ' LESS THAN ',8A1) 1041 FORMAT( + ' MUST BE LESS THAN ', I5, '.') C END *HPFLT SUBROUTINE HPFLT (HLP, K, HHP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE HIPASS FILTER COEFFICIENTS C CORRESPONDING TO THE INPUT LOW PASS FILTER. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + K C C ARRAY ARGUMENTS DOUBLE PRECISION + HHP(K),HLP(K) C C LOCAL SCALARS INTEGER + I,KMID C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION HHP(K) C THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS C WILL BE RETURNED. C DOUBLE PRECISION HLP(K) C THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS C ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER K C THE NUMBER OF FILTER TERMS TO BE COMPUTED. C INTEGER KMID C THE MIDPOINT OF THE FILTER. 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 DO 20 I = 1, K HHP(I) = -HLP(I) 20 CONTINUE C KMID = (K + 1) / 2 C HHP(KMID) = HHP(KMID) + 1.0D0 C RETURN END *MADJ SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM) C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NF,P C C ARRAY ARGUMENTS DOUBLE PRECISION + J(N,P),URPARM(*),X(P) INTEGER + UIPARM(*) C C SUBROUTINE ARGUMENTS EXTERNAL UFPARM C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN 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 J(1,1) = 2.0D0*X(1) + X(2) J(1,2) = 2.0D0*X(2) + X(1) J(2,1) = COS(X(1)) J(2,2) = 0.0D0 J(3,1) = 0.0D0 J(3,2) = -SIN(X(2)) RETURN END *NLSUPK SUBROUTINE NLSUPK(PARE, NPARE, PAR, MASK, NPAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE UNPACKS A VECTOR PARE INTO A VECTOR PAR, BY C PLACING SUCCEDING ELEMENTS OF PARE INTO ELEMENTS OF PAR C WHICH CORRESPOND TO ELEMENTS OF MASK WITH THE VALUE 1. C OTHER ELEMENTS OF MASK SHOULD BE 0. THE NUMBER OF ELEMENTS C NPARE IN PARE SHOULD EQUAL THE NUMBER OF ELEMENTS OF C MASK WHICH ARE 1. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NPAR,NPARE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),PARE(NPAR) INTEGER + MASK(NPAR) C C LOCAL SCALARS INTEGER + I,JPK C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER I C AN INDEX VARIABLE. C INTEGER JPK C AN INDEX VARIABLE. C INTEGER MASK(NPAR) C INPUT PARAMETER. THE MASK GOVERNING THE PACKING OF PAR. C ELEMENTS OF MASK ARE 1 IF THE CORRESPONDING ELEMENT OF PAR C WAS ELIMINATED IN PARE, 0 IF IT WAS INCLUDED. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C DOUBLE PRECISION PARE(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS BEING OPTIMIZED, C NOT INCLUDING THOSE WHOSE VALUES ARE FIXED. C 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 COMMENCE BODY OF ROUTINE C JPK = 0 DO 20 I=1,NPAR IF (MASK(I).NE.0) GO TO 20 JPK = JPK + 1 PAR(I) = PARE(JPK) 20 CONTINUE RETURN END *STKCLR SUBROUTINE STKCLR (NALL0) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE IS AN ADDITION TO THE FRAMEWORK AREA MANIPULATION C ROUTINES. IT CLEARS ALL ALLOCATIONS MADE SINCE THE FIRST NALL0. C IT IS INTENDED FOR USE DURING ERROR OR FINAL EXITS FROM STARPAC C ROUTINES WHICH MAKE ALLOCATIONS, TO RELEASE ALL ALLOCATIONS C MADE SINCE THE NALL0 EXISTING ON ENTRY TO THE STARPAC ROUTINE, C WITHOUT KNOWING HOW MANY ALLOCATIONS MUST BE RELEASED. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NALL0 C C LOCAL SCALARS INTEGER + NALLN C C EXTERNAL FUNCTIONS INTEGER + STKST EXTERNAL STKST C C EXTERNAL SUBROUTINES EXTERNAL STKREL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER NALL0 C INPUT PARAMETER. THE NUMBER OF ALLOCATIONS TO BE PRESERVED C WHEN ALL LATER ONES ARE RELEASED. C INTEGER NALLN C THE TOTAL NUMBER OF ALLOCATIONS EXISTING BEFORE ANY ARE C RELEASED. C 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 COMMENCE BODY OF ROUTINE C NALLN = STKST(1) CALL STKREL (NALLN - NALL0) RETURN END *AIMES SUBROUTINE AIMES(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK, + IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT, + NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION C (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,LDSTAK,MIT,N,NFAC,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + Y(*) INTEGER + IFIXED(1),MSPEC(4,*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP LOGICAL + SAVE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXED(1) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C IF IFIXED(1).LT.0, THEN IFIXED(I)=DEFAULT,I=1,...,NPAR, AND THE C DIMENSION OF IFIXED WILL BE ASSUMED TO BE 1. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVAPRX C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE FOR C IVAPRX LE 0, VCV = THE DEFAULT OPTION C IVAPRX EQ 1, VCV = INVERSE(TRANSPOSE(J)*J) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 2, VCV = INVERSE(H) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 3, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 4, VCV = INVERSE(TRANSPOSE(J)*J) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 5, VCV = INVERSE(H) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 6, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H) C USING ONLY THE MODEL SUBROUTINE C IVAPRX GE 7, VCV = THE DEFAULT OPTION C WITH J REPRESENTING THE JACOBIAN AND H THE HESSIAN. C INTEGER IVCV C THE FIRST DIMENSION OF MATRIX VCV. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LIFIXD C THE DIMENSION OF VECTOR IFIXED. C INTEGER LPV C THE DIMENSION OF VECTOR PV. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSDPV C THE DIMENSION OF VECTOR SDPV. C INTEGER LSDRES C THE DIMENSION OF VECTOR SDRES. C INTEGER LSTP C THE DIMENSION OF VECTOR STP. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUE OF THE FIT. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION SCALE(NPAR) C THE TYPICAL SIZE OF THE PARAMETERS. C IF SCALE(1).LE.0, THEN SCALE(I)=DEFAULT,I=1,...,NPAR, AND THE C DIMENSION OF SCALE WILL BE ASSUMED TO BE 1. C DOUBLE PRECISION SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDRES(N) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION STOPP C THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED C RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR C DOUBLE PRECISION STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C DOUBLE PRECISION STP(NPAR) C THE STEP SIZE ARRAY. C IF STP(1).LE.0, THEN STP(I)=DEFAULT,I=1,...,NPAR, AND THE C DIMENSION OF STP WILL BE ASSUMED TO BE 1. C DOUBLE PRECISION VCV(IVCV,NPAR) C THE VARIANCE-COVARIANCE MATRIX. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS 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 NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'A','I','M','E','S',' '/ C C SET VARIOUS PROGRAM PARAMETERS C SAVE = .TRUE. C LIFIXD = NPAR IF (IFIXED(1).LE.-1) LIFIXD = 1 LSCALE = NPAR IF (SCALE(1).LE.0.0D0) LSCALE = 1 LSTP = NPAR IF (STP(1).LE.0.0D0) LSTP = 1 C CALL AMEDRV(Y, N, MSPEC, NFAC, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, SAVE, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CCCCC CALL IPRINT(IPRT) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1001) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1002) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1003) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1004) CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' THE CORRECT FORM OF THE CALL STATEMENT IS') 1001 FORMAT ( + ' CALL AIMES(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,') 1002 FORMAT ( + ' + IFIXED, STP, MIT, STOPSS, STOPP, SCALE,') 1003 FORMAT ( + ' + DELTA, IVAPRX, NPRT,') 1004 FORMAT ( + ' + NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)') END *AMFOUT SUBROUTINE AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y, + T975, PAGE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES ARIMA FORECASTING OUTPUT C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + T975 INTEGER + IFO,N,NFCST,NFCSTO LOGICAL + PAGE C C ARRAY ARGUMENTS DOUBLE PRECISION + F(*),FSD(*),Y(*) INTEGER + IFCSTO(*) C C LOCAL SCALARS DOUBLE PRECISION + FL,FU,SCALE,YMN,YMX INTEGER CCCCC+ I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPRT,IPY,IY,J + I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPY,IY,J C C LOCAL ARRAYS DOUBLE PRECISION + YLIM(4) CHARACTER + LINE(53)*1 C C EXTERNAL SUBROUTINES CCCCC EXTERNAL AMFHDR,IPRINT EXTERNAL AMFHDR C C INTRINSIC FUNCTIONS INTRINSIC INT,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION F(NFCST) C THE FORECASTS. C DOUBLE PRECISION FL C THE LOWER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST C DOUBLE PRECISION FSD(NFCST) C THE STANDARD DEVIATIONS OF THE FORECASTS. C DOUBLE PRECISION FU C THE UPPER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST C INTEGER I C AN INDEX VARIABLE. C INTEGER IEND C THE LAST LOCATION IN THE PLOT STRING. C INTEGER IF C AN INDEX VARIABLE. C INTEGER IFCSTO(NFCSTO) C THE INDICES OF THE ORIGINS FOR THE FORECASTS. C INTEGER IFO C THE INDEX OF THE ORIGIN BEING USED. C INTEGER ILIM C THE NUMBER OF LOCATIONS IN YLIM. C INTEGER INTER C THE NUMBER OF PLOT INTERVALS. C INTEGER IPF C THE LOCATION IN THE PLOT STRING OF THE FORECAST. C INTEGER IPFL C THE LOCATION IN THE PLOT STRING OF THE FORECAST LOWER C CONFIDENCE LIMIT. C INTEGER IPFU C THE LOCATION IN THE PLOT STRING OF THE FORECAST UPPER C CONFIDENCE LIMIT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IPY C THE LOCATION IN THE PLOT STRING OF THE OBSERVED VALUE. C INTEGER IY C AN INDEX VARIABLE. C INTEGER J C AN INDEX VARIABLE. C CHARACTER*1 LINE(53) C THE ARRAY OF SYMBOLS TO BE PLOTTED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFCST C THE NUMBER OF FORECASTS. C INTEGER NFCSTO C THE NUMBER OF THE ORIGINS. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION SCALE C THE PLOT SCALE. C DOUBLE PRECISION T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C DOUBLE PRECISION YLIM(4) C THE VALUES OF THE AXIS LABELS. C DOUBLE PRECISION YMN C THE MINIMUM VALUE TO BE PLOTTED. C DOUBLE PRECISION YMX C THE MAXIMUM VALUE TO BE PLOTTED. 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 SET VARIABLES FOR PLOTS C CCCCC CALL IPRINT(IPRT) INTER = 50 IEND = INTER + 1 ILIM = 4 C C COMPUTE SCALE FOR PLOT C YMN = F(NFCST)-T975*FSD(NFCST) YMX = F(NFCST)+T975*FSD(NFCST) IY = IFCSTO(IFO) DO 10 I = 1, NFCST YMN = MIN(YMN, F(I)-T975*FSD(I)) YMX = MAX(YMX, F(I)+T975*FSD(I)) IF ((IY.GE.1) .AND. (IY.LE.N)) THEN YMN = MIN(YMN, Y(IY)) YMX = MAX(YMX, Y(IY)) IY = IY + 1 END IF 10 CONTINUE IF (IFCSTO(IFO).GE.2) THEN DO 20 IY = MAX(IFCSTO(IFO)-4, 1), IFCSTO(IFO)-1 YMN = MIN(YMN, Y(IY)) YMX = MAX(YMX, Y(IY)) 20 CONTINUE END IF C SCALE = (YMX-YMN) / INTER C C PRINT PLOT HEADINGS C DO 30 I = 1, ILIM YLIM(I) = YMN + SCALE*I*10.0D0 30 CONTINUE C CALL AMFHDR(PAGE, .TRUE., 0) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1030) IFO 1030 FORMAT (' FORECASTS FOR ORIGIN ', I2) 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,1001) YMN, YLIM(2), YLIM(4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1002) YLIM(1), YLIM(4), YMX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1003) CALL DPWRST('XXX','BUG ') 1000 FORMAT ( + 82X, ' --------------------95 PERCENT') 1001 FORMAT ( + 1X, 3(G15.8, 5X), 21X, + ' --------------CONFIDENCE LIMITS', + ' ---------ACTUAL') 1002 FORMAT ( + 11X, 2(G15.8, 5X), G15.8, + ' ------FORECASTS ----------LOWER', + ' ----------UPPER -------IF KNOWN') 1003 FORMAT ( + 9X, 5('I---------'), 'I', 6X, + ' ------------[X] ------------[(]', + ' ------------[)] ------------[*]') C C BEGIN PLOTTING C DO 80 I=MAX(IFCSTO(IFO)-4,1), IFCSTO(IFO)+NFCST IF (I.NE.IFCSTO(IFO)) THEN DO 40 J = 1, IEND LINE(J) = ' ' 40 CONTINUE ELSE DO 50 J = 1, IEND LINE(J) = '.' 50 CONTINUE END IF IF (I.LE.IFCSTO(IFO)) THEN IPY = INT(((Y(I)-YMN) / SCALE) + 1.5D0) LINE(IPY) = '*' WRITE (ICOUT, 1020) I, (LINE(J),J=1,IEND), I, Y(I) 1020 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 49X, G15.8) CALL DPWRST('XXX','BUG ') ELSE IF = I-IFCSTO(IFO) FL = F(IF) - T975*FSD(IF) FU = F(IF) + T975*FSD(IF) IF (I.LE.N) THEN IPFL = INT(((FL-YMN) / SCALE) + 1.5D0) IPFU = INT(((FU-YMN) / SCALE) + 1.5D0) DO 60 J = IPFL, IPFU LINE(J) = '-' 60 CONTINUE LINE(IPFL) = '(' LINE(IPFU) = ')' IPY = INT(((Y(I)-YMN) / SCALE) + 1.5D0) LINE(IPY) = '*' IPF = INT(((F(IF)-YMN) / SCALE) + 1.5D0) IF (IPF.NE.IPY) THEN LINE(IPF) = 'X' ELSE LINE(IPF) = '2' END IF WRITE (ICOUT, 1010) I, (LINE(J),J=1,IEND), I, + F(IF), FL, FU, Y(I) CALL DPWRST('XXX','BUG ') ELSE IPFL = INT(((FL-YMN) / SCALE) + 1.5D0) IPFU = INT(((FU-YMN) / SCALE) + 1.5D0) DO 70 J = IPFL, IPFU LINE(J) = '-' 70 CONTINUE LINE(IPFL) = '(' LINE(IPFU) = ')' IPF = INT(((F(IF)-YMN) / SCALE) + 1.5D0) LINE(IPF) = 'X' WRITE (ICOUT, 1010) I, (LINE(J),J=1,IEND), I, + F(IF), FL, FU 1010 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 4(1X, G15.8)) CALL DPWRST('XXX','BUG ') END IF END IF 80 CONTINUE C RETURN C C FORMAT STATEMENTS C C END *EISEQ SUBROUTINE EISEQ(NMSUB, NMVAR1, NVAL, NEQ, MSGTYP, HEAD, ERROR, + NMVAR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE VALUE NVAL IS C OQUAL TO NEQ AND PRINTS A DIAGNOSTIC IF IT IS NOT. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MSGTYP,NEQ,NVAL LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE C PRINTED, WHERE IF ERROR IS TRUE AND C MSGTYP = 1 THE INPUT VALUE WAS NOT EQUAL TO THE NUMBER OF PARAM C SPECIFIED BY MSPEC (ARIMA ESTIMATION AND FORECASTING C INTEGER NEQ C THE ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR1(8) C THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED. C CHARACTER*1 NMVAR2(8) C THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED C AGAINST. C INTEGER NVAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C 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 ERROR = .FALSE. C IF (NVAL .EQ. NEQ) RETURN C ERROR = .TRUE. C CCCCC CALL IPRINT (IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE (ICOUT, 1000) (NMVAR1(I), I=1,6), NVAL CALL DPWRST('XXX','BUG ') C C PRINT MESSAGE FOR ARIMA ROUTINES C WRITE (ICOUT, 1010) (NMVAR1(I), I=1,6) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1011) NEQ CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1012) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1013) CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', I5, '.') 1010 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE GREATER THAN OR EQUAL TO') 1011 FORMAT( + 1X, I5, ' = ONE PLUS THE SUM OF MSPEC(1,J)+MSPEC(3,J) FOR', + ' J = 1, ..., NFAC,') 1012 FORMAT( + 6X,' = ONE PLUS THE NUMBER OF AUTOREGRESSIVE PARAMETERS PLUS') 1013 FORMAT( + 9X, ' THE NUMBER OF MOVING AVERAGE PARAMETERS.') C END *ICNTI INTEGER FUNCTION ICNTI (IV, NIV, I) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COUNTS THE NUMBER OF OCCURENCES OF I IN IV. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING LAB/BOULDER C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - APRIL 20, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + I,NIV C C ARRAY ARGUMENTS INTEGER + IV(NIV) C C LOCAL SCALARS INTEGER + J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C INPUT PARAMETER. THE INTEGER TO COUNT OCCURENCES OF. C INTEGER IV(NIV) C INPUT PARAMETER. THE VECTOR IN WHICH TO COUNT. C INTEGER J C LOOP PARAMETER. C INTEGER NIV C INPUT PARAMETER. THE LENGTH OF IV. C C COMMENCE BODY OF ROUTINE 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 ICNTI = 0 DO 10 J = 1, NIV IF (IV(J) .EQ. I) ICNTI = ICNTI + 1 10 CONTINUE RETURN END *MADR SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM) C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NF,P C C ARRAY ARGUMENTS DOUBLE PRECISION + R(N),URPARM(*),X(P) INTEGER + UIPARM(*) C C SUBROUTINE ARGUMENTS EXTERNAL UFPARM C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN 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 R(1) = X(1)**2 + X(2)**2 + X(1)*X(2) R(2) = SIN(X(1)) R(3) = COS(X(2)) RETURN END *OBSSM2 SUBROUTINE OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, IFIRST, ILAST) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBOUTINE LISTS THE DATA SUMMARY FOR THE ARIMA ESTIMATION C SUBROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFIRST,ILAST,N C C ARRAY ARGUMENTS DOUBLE PRECISION + PVT(N),RES(N),SDPVT(N),SDREST(N),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + FPLM INTEGER + I C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIRST, ILAST C THE FIRST AND LAST INDICES TO BE LISTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDREST(N) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C 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 FPLM = D1MACH(2) C CCCCC CALL IPRINT(IPRT) C DO 140 I=IFIRST,ILAST C C PRINT DATA SUMMARY. C IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).NE.FPLM)) THEN WRITE (IOUNI2, 1060) I, Y(I), PVT(I), SDPVT(I), RES(I), + SDREST(I) ENDIF IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).EQ.FPLM)) THEN WRITE (IOUNI2, 1050) I, Y(I), PVT(I), SDPVT(I), RES(I) ENDIF IF ((SDPVT(I).EQ.FPLM) .AND. (SDREST(I).EQ.FPLM)) THEN WRITE (IOUNI2, 1080) I, Y(I), PVT(I), RES(I) ENDIF C 140 CONTINUE C RETURN C C FORMAT STATEMENTS C 1050 FORMAT (I4, 4E16.8, 4X, 'NC *') 1060 FORMAT (I4, 4E16.8, 1X, F7.2) 1080 FORMAT (I4, 2E16.8, 7X, 'NC *', 4X, E15.8, 4X, 'NC *') END *STKGET INTEGER FUNCTION STKGET(NITEMS, ITYPE) C C LATEST REVISION - 03/15/90 (JRD) C C ALLOCATES SPACE OUT OF THE INTEGER ARRAY ISTAK (IN COMMON C BLOCK CSTAK) FOR AN ARRAY OF LENGTH NITEMS AND OF TYPE C DETERMINED BY ITYPE AS FOLLOWS C C 1 - LOGICAL C 2 - INTEGER C 3 - REAL C 4 - DOUBLE PRECISION C 5 - COMPLEX C C ON RETURN, THE ARRAY WILL OCCUPY C C STAK(STKGET), STAK(STKGET+1), ..., STAK(STKGET-NITEMS+1) C C WHERE STAK IS AN ARRAY OF TYPE ITYPE EQUIVALENCED TO ISTAK. C C (FOR THOSE WANTING TO MAKE MACHINE DEPENDENT MODIFICATIONS C TO SUPPORT OTHER TYPES, CODES 6, 7, 8, 9, 10, 11 AND 12 HAVE C BEEN RESERVED FOR 1/4 LOGICAL, 1/2 LOGICAL, 1/4 INTEGER, C 1/2 INTEGER, QUAD PRECISION, DOUBLE COMPLEX AND QUAD C COMPLEX, RESPECTIVELY.) C C THE USE OF THE FIRST FIVE WORDS IS DESCRIBED BELOW. C C ISTAK( 1) - LOUT, THE NUMBER OF CURRENT ALLOCATIONS. C ISTAK( 2) - LNOW, THE CURRENT ACTIVE LENGTH OF THE STACK. C ISTAK( 3) - LUSED, THE MAXIMUM VALUE OF ISTAK(2) ACHIEVED. C ISTAK( 4) - LMAX, THE MAXIMUM LENGTH THE STACK. C ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING. C C THE NEXT FIVE WORDS CONTAIN INTEGERS DESCRIBING THE AMOUNT C OF STORAGE ALLOCATED BY THE FORTRAN SYSTEM TO THE VARIOUS C DATA TYPES. THE UNIT OF MEASUREMENT IS ARBITRARY AND MAY C BE WORDS, BYTES OR BITS OR WHATEVER IS CONVENIENT. THE C VALUES CURRENTLY ASSUMED CORRESPOND TO AN ANS FORTRAN C ENVIRONMENT. FOR SOME MINI-COMPUTER SYSTEMS THE VALUES MAY C HAVE TO BE CHANGED (SEE I0TK00). C C ISTAK( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL C ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER C ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL C ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION C ISTAK(10) - THE NUMBER OF UNITS ALLOCATED TO COMPLEX C C THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK FUNCTION ISTKGT C C ADAPTED BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ITYPE,NITEMS C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,LBOOK,LMAX,LNOW,LOUT,LUSED C C LOCAL ARRAYS INTEGER + ISIZE(5),ISTAK(12) C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),ISIZE(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER I C THE LOCATION OF A POINTER TO THE END OF THE PREVIOUS ALLOCATION C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF IERR .EQ. 0, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISIZE(5) C THE NUMBER OF WORDS IN EACH OF THE VARIOUS DATA TYPES. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ITYPE C THE TYPE OF ARRAY OF LENGTH NITEMS TO BE ALLOCATED. C INTEGER LBOOK C THE NUMBER OF WORDS USED FOR BOOKEEPING. C INTEGER LMAX C THE MAXIMUM LENGTH OF THE STACK. C INTEGER LNOW C THE CURRENT ACTIVE LENGTH OF THE STACK. C INTEGER LOUT C THE NUMBER OF CURRENT ALLOCATIONS. C INTEGER LUSED C THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED. C INTEGER NITEMS C THE LENGTH OF THE ARRAY OF ITYPE TO BE ALLOCATED. C 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 STKGET = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 I = ( (STKGET-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3 C C STACK OVERFLOW IS AN UNRECOVERABLE ERROR. C IF (I .LE. LMAX) GO TO 10 C IERR = 1 CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT, 1000) CALL DPWRST('XXX','BUG ') RETURN C 10 CONTINUE C C ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION. C ISTAK(I ) CONTAINS A POINTER TO THE END OF THE PREVIOUS C ALLOCATION. C ISTAK(I-1) = ITYPE ISTAK(I ) = LNOW LOUT = LOUT+1 LNOW = I LUSED = MAX(LUSED, LNOW) C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT(' DSTAK IS TOO SHORT.') C END *AIMFS SUBROUTINE AIMFS(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, + NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST, FCSTSD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION C (CONTROL CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFCST,LDSTAK,N,NFAC,NFCST,NFCSTO,NPAR,NPRT C C ARRAY ARGUMENTS DOUBLE PRECISION + FCST(*),FCSTSD(*),PAR(*),Y(*) INTEGER + IFCSTO(*),MSPEC(4,*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + NFCSTU LOGICAL + SAVE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMFCNT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C DOUBLE PRECISION FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C DOUBLE PRECISION FCSTSD(NFCST) C THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFCST C THE FIRST DIMENSION OF THE ARRAY FCST. C INTEGER IFCSTO(NFCSTO) C THE INDICES OF THE ORIGINS FOR THE FORECASTS. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFCST C THE NUMBER OF FORECASTS. C INTEGER NFCSTO C THE NUMBER OF THE ORIGINS. C INTEGER NFCSTU C THE NUMBER OF FORCASTES ACTUALLY USED. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR 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 SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'A','I','M','F','S',' '/ C C SET VARIOUS PROGRAM PARAMETERS C ISUBRO='AMES' IBUGA3='OFF' IFOUND='NO' IERROR='OFF' CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) SAVE = .TRUE. C IF ((NFCST.GE.1) .AND. (NFCST.LE.N)) THEN NFCSTU = NFCST ELSE NFCSTU = (N/10)+1 END IF C CALL AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, NFCSTU, + MAX(1,NFCSTO), IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE) C ISUBRO='AMES' IBUGA3='OFF' IFOUND='NO' IERROR='OFF' CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1001) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1001) CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT ( + ' THE CORRECT FORM OF THE CALL STATEMENT IS') 1001 FORMAT ( + ' CALL AIMFS (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,') 1002 FORMAT ( + ' + NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST,', + ' FCSTSD)') END *AMLST SUBROUTINE AMLST (IAMHD, PAR, NPAR, NFAC, MSPECT, N, VCVL, + LVCVL, SCALE, LSCALE, STPT, LSTPT, IFIXD, RSS, RSD, NPARDF, + NPARE, IDF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE PARAMETER SUMMARY OUTPUT FROM THE C ARIMA FORECASTING SUBROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + RSD,RSS INTEGER + IAMHD,IDF,LSCALE,LSTPT,LVCVL,N,NFAC,NPAR,NPARDF,NPARE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),SCALE(*),STPT(*),VCVL(*) INTEGER + IFIXD(*),MSPECT(NFAC,4) C C LOCAL SCALARS DOUBLE PRECISION + FPLM,T975 INTEGER CCCCC+ IPARMN,IPARMX,IPRT,LBLTYP + IPARMN,IPARMX,LBLTYP C C EXTERNAL FUNCTIONS DOUBLE PRECISION + PPFT EXTERNAL PPFT C C EXTERNAL SUBROUTINES EXTERNAL AMLST1 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER IAMHD C THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST C TO BE GENERATED C IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE C ESTIMATION ROUTINES. C IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE C FORECASTING ROUTINES. C IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE C ESTIMATION ROUTINES. C INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IPARMN C THE SMALLEST PARAMETER INDEX INCLUDED IN THIS TERM. C INTEGER IPARMX C THE LARGEST PARAMETER INDEX INCLUDED IN THIS TERM. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSTPT C THE DIMENSION OF VECTOR STPT. C INTEGER LVCVL C THE DIMENSION OF VECTOR VCVL. C INTEGER MSPECT(NFAC,4) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION STPT(LSTPT) C THE STEP SIZE ARRAY. C DOUBLE PRECISION T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C DOUBLE PRECISION VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR COMMON/STARPC/IRESDF 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 FPLM = D1MACH(2) C CCCCC CALL IPRINT(IPRT) C C PRINT HEADING FOR INFORMATION ABOUT PARAMETERS C WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') C IF (IAMHD .EQ. 1) THEN WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1003) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1004) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1104) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1204) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1304) CALL DPWRST('XXX','BUG ') ENDIF 1003 FORMAT( + 'DEFAULT SCALING USED FOR ALL PARAMETERS.') 1004 FORMAT ( + 56X, ' ##STEP SIZE FOR') 1104 FORMAT ( + 39X, ' ######PARAMETER', ' ##APPROXIMATING') 1204 FORMAT ( + ' #################PARAMETER DESCRIPTION STARTING VALUES', + ' #####DERIVATIVE') 1304 FORMAT ( + ' INDEX #########TYPE ##ORDER ##FIXED ##########(PAR)', + ' ##########(STP)') IF (IAMHD .EQ. 2) THEN WRITE(ICOUT, 1005) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1105) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1205) CALL DPWRST('XXX','BUG ') ENDIF 1005 FORMAT( + 30X, ' ######PARAMETER') 1105 FORMAT( + ' ########PARAMETER DESCRIPTION ######ESTIMATES') 1205 FORMAT( + ' INDEX #########TYPE ##ORDER ##########(PAR)') IF (IAMHD .EQ. 3) THEN WRITE(ICOUT, 1006) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1206) CALL DPWRST('XXX','BUG ') ENDIF 1006 FORMAT( + 15X,'PARAMETER STD DEV OF',' ###PAR/',3X, + '##################APPROXIMATE') 1106 FORMAT( + 15X,'ESTIMATES', + ' ####PARAMETER ####(SD', + ' 95 PERCENT CONFIDENCE LIMITS') 1206 FORMAT( + ' TYPE ORD ###(OF PAR)', + ' ####ESTIMATES', + ' ##(PAR) #######LOWER ######UPPER') WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') ISUBRO='AMES' IBUGA3='OFF' IFOUND='NO' IERROR='OFF' CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) C C PRINT MODEL SUMMARY INFORMATION C IPARMN = 1 IPARMX = 0 T975 = PPFT(0.95D0, N-NPAR) C C PRINT AUTOREGRESSIVE TERMS C LBLTYP = 1 CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL, + SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD) C C PRINT MEAN OR TREND TERM C LBLTYP = 2 CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, 1, VCVL, LVCVL, + SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD) C C PRINT MOVING AVERAGE TERMS C LBLTYP = 3 CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL, + SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD) C WRITE(ICOUT, 1001) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1160) N CALL DPWRST('XXX','BUG ') IF (IAMHD.GE.2) THEN WRITE (ICOUT, 1040) RSS CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 2040) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1041) RSD CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1042) N, NPARDF, NPARE, IDF CALL DPWRST('XXX','BUG ') AIC=REAL(N)*LOG(REAL(RSD)**2) + 2.0*REAL(NPAR) WRITE (ICOUT, 1045) AIC CALL DPWRST('XXX','BUG ') IORDAR=MSPECT(1,1) IORDMA=MSPECT(3,1) AN=REAL(N) AP=REAL(IORDAR) AQ=REAL(IORDMA) AFACT=2.0*(AP + AQ + 1.0)*AN/(AN - AP - AQ - 2.0) AICC=REAL(N)*LOG(REAL(RSD)**2) + AFACT WRITE (ICOUT, 1046) AICC CALL DPWRST('XXX','BUG ') IRESDF=IDF ENDIF ISUBRO='AMES' IBUGA3='OFF' IFOUND='NO' IERROR='OFF' CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) RETURN C C FORMAT STATEMENTS C 1001 FORMAT(1X) 1040 FORMAT ( + ' RESIDUAL SUM OF SQUARES ', 8X, G15.7) 2040 FORMAT ( + ' (BACKFORECASTS INCLUDED)') 1041 FORMAT ( + ' RESIDUAL STANDARD DEVIATION ', 8X, G15.7) 1042 FORMAT ( + ' BASED ON DEGREES OF FREEDOM', + 1X, I4, ' - ', I3, ' - ', I3, ' = ', I4) 1045 FORMAT ( + ' AKAIKE INFORMATION CRITERION (AIC) ', 8X, G15.7) 1046 FORMAT ( + ' AKAIKE INFORMATION CRITERION (AICC) ', 8X, G15.7) 1160 FORMAT (' NUMBER OF OBSERVATIONS', 18X, '(N)', 1X, I5) END *EISGE SUBROUTINE EISGE(NMSUB, NMVAR1, NVAL, NMIN, MSGTYP, HEAD, ERROR, + NMVAR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE VALUE NVAL IS GREATER THAN C OR EQUAL TO NMIN AND PRINTS A DIAGNOSTIC IF IT IS NOT. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 29, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MSGTYP,NMIN,NVAL LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE C PRINTED, WHERE IF ERROR IS TRUE AND C MSGTYP = 1 THE INPUT VALUE WAS TOO SMALL BASED C ON LIMITS IMPOSED BY STARPAC C MSGTYP = 2 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT C ARGUMENTS. C MSGTYP = 3 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT C ARGUMENTS, WHERE THE VALUE INDICATES THE FIRST C DIMENSION OF A DIMENSIONED ARRAY C N.B. IT IS ASSUMED THAT THE DIMENSION NAME IS THE C ARRAY NAME PRECEDED BY THE LETTER I. IF THE C ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME C SHOULD OMIT THE LAST LETTER. THE DIMENSION C NAME WILL BE PRINTED USING (NMVAR(I),I=1,6), C AND THE ARRAY NAME USING (NMVAR(I),I=2,7). C MSGTYP = 4 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT C ARGUMENTS, WHERE THE VALUE INDICATES THE SECOND C DIMENSION OF A DIMENSIONED ARRAY C N.B. IT IS ASSUMED THAT THE DIMENSION NAME IS THE C ARRAY NAME PRECEDED BY THE LETTER J. IF THE C ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME C SHOULD OMIT THE LAST LETTER. THE DIMENSION C NAME WILL BE PRINTED USING (NMVAR(I),I=1,6), C AND THE ARRAY NAME USING (NMVAR(I),I=2,7). C MSGTYP = 5 THE ARGUMENT BEING CHECKED IS LDSTAK. C NO LONGER USED. C MSGTYP = 6 THE ARGUMENT INDICATES THE FIRST DIMENSION OF C AN ARRAY BEING CHECKED AGAINST THE NUMBER OF C UNFIXED PARAMETERS. C MSGTYP = 7 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT C ARGUMENTS, WHERE THE VALUE INDICATES THE C DIMENSION OF A VECTOR. C N.B. IT IS ASSUMED THAT THE DIMENSION NAME IS THE C ARRAY NAME PRECEDED BY THE LETTER L. IF THE C ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME C SHOULD OMIT THE LAST LETTER. THE DIMENSION C NAME WILL BE PRINTED USING (NMVAR(I),I=1,6), C AND THE ARRAY NAME USING (NMVAR(I),I=2,7). C MSGTYP = 8 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT C ARGUMENTS, WHERE THE VALUE INDICATES THE C DIMENSION OF THE VECTORS ACOV AND NLPPA. C MSGTYP = 9 THE INPUT VALUE WAS TOO SMALL BASED ON LIMITS C IMPOSED BY STARPAC, WHERE THE VALUE INDICATES THE C DIMENSION OF A VECTOR. C N.B. IT IS ASSUMED THAT THE DIMENSION NAME IS THE C ARRAY NAME PRECEDED BY THE LETTER L. IF THE C ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME C SHOULD OMIT THE LAST LETTER. THE DIMENSION C NAME WILL BE PRINTED USING (NMVAR(I),I=1,6), C AND THE ARRAY NAME USING (NMVAR(I),I=2,7). C INTEGER NMIN C THE MINIMUM ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR1(8) C THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED. C CHARACTER*1 NMVAR2(8) C THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED C AGAINST. C INTEGER NVAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C 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 ERROR = .FALSE. C IF (NVAL .GE. NMIN) RETURN C ERROR = .TRUE. C CCCCC CALL IPRNT (IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1000) (NMVAR1(I), I=1,6), NVAL CALL DPWRST('XXX','BUG ') C GO TO (20, 30, 40, 50, 60, 70, 80, 90, 100), MSGTYP C C PRINT MESSAGE FOR VALUE TOO SMALL BASED ON LIMITS IMPOSED C BY STARPAC. C 20 WRITE (ICOUT, 1010) (NMVAR1(I), I=1,6), NMIN CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL BASED ON OTHER INPUT C ARGUMENTS. C 30 WRITE (ICOUT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C FIRST DIMENSION OF A DIMENSIONED ARRAY. C 40 WRITE (ICOUT, 1030) (NMVAR1(I), I=2,7) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1031) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C SECOND DIMENSION OF A DIMENSIONED ARRAY. C 50 WRITE (ICOUT, 1040) (NMVAR1(I), I=2,7) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1041) (NMVAR1(I), I=1,6), + (NMVAR2(I), I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHEN ARGUMENT IS LDSTAK. C 60 WRITE(ICOUT, 1050) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1051) NMIN CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C FIRST DIMENSION OF A DIMENSIONED ARRAY CHECK AGAINST THE NUMBER OF C UNFIXED PARAMETERS. C 70 WRITE (ICOUT, 1060) (NMVAR1(I), I=2,7) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1061) (NMVAR1(I), I=1,6) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF A VECTOR. C 80 WRITE (ICOUT, 1070) (NMVAR1(I), I=2,7) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1071) (NMVAR1(I), I=1,6),(NMVAR2(I), I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF THE VECTORS ACOV AND NLPPA. C 90 WRITE (ICOUT, 1080) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1081) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF A VECTOR. C 100 WRITE (ICOUT, 1090) (NMVAR1(I), I=2,7) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1091) (NMVAR1(I), I=1,6),NMIN CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' THE INPUT VALUE OF ',6A1,' IS ',I5,'.') 1010 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE GREATER THAN OR EQUAL TO ', I5, '.') 1020 FORMAT( + ' THE VALUE OF THE ARGUMENT ',6A1, + ' MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') 1030 FORMAT( + ' THE FIRST DIMENSION OF ', 6A1, + ', AS INDICATED BY THE ARGUMENT') 1031 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') 1040 FORMAT( + ' THE SECOND DIMENSION OF ', 6A1, + ', AS INDICATED BY THE ARGUMENT') 1041 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') 1050 FORMAT( + ' THE DIMENSION OF THE DOUBLE PRECISION VECTOR DSTAK, AS', + ' INDICATED BY') 1051 FORMAT( + ' THE ARGUMENT LDSTAK, MUST BE GREATER THAN OR EQUAL TO ', + I5, '.') 1060 FORMAT( + ' THE FIRST DIMENSION OF ', 6A1, + ', AS INDICATED BY THE ARGUMENT') 1061 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', + 'THE NUMBER OF UNFIXED PARAMETERS.') 1070 FORMAT( + ' THE LENGTH OF ', 6A1, + ', AS INDICATED BY THE ARGUMENT') 1071 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') 1080 FORMAT( + ' THE LENGTH OF ACOV AND NLPPA', + ', AS INDICATED BY THE ARGUMENT') 1081 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') 1090 FORMAT( + ' THE LENGTH OF ', 6A1, + ', AS INDICATED BY THE ARGUMENT') 1091 FORMAT( + 1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', I6, '.') C END *ICOPY SUBROUTINE ICOPY(N,ISX,INCX,ISY,INCY) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE IS A ADAPTATION OF THE BLAS SUBROUTINE DCOPY, C MODIFIED TO HANDLE INTEGER ARRAYS. C C COPY INTEGER ISX TO INTEGER ISY. C FOR I = 0 TO N-1, COPY ISX(LX+I*INCX) TO ISY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + INCX,INCY,N C C ARRAY ARGUMENTS INTEGER + ISX(N),ISY(N) C C LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEXING VARIABLE. C INTEGER INCX, INCY C THE INCREMENT USED FOR THE COPY FROM ONE VARIABLE TO THE OTHER. C INTEGER ISX(N) C THE ARRAY TO BE COPIED FROM. C INTEGER ISY(N) C THE ARRAY TO BE COPIED TO. C INTEGER IX, IY C INDEX VARIABLES. C INTEGER M C THE VALUE OF N MODULO 7. C INTEGER MP1 C THE VALUE OF M + 1. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE ARRAYS ISX AND ISY. C INTEGER NS C THE VALUE OF N * INCX. C 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 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N ISY(IY) = ISX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M ISY(I) = ISX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 ISY(I) = ISX(I) ISY(I + 1) = ISX(I + 1) ISY(I + 2) = ISX(I + 2) ISY(I + 3) = ISX(I + 3) ISY(I + 4) = ISX(I + 4) ISY(I + 5) = ISX(I + 5) ISY(I + 6) = ISX(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX ISY(I) = ISX(I) 70 CONTINUE RETURN END *MATPRF SUBROUTINE MATPRF(X, Y, NC, MODE, CODE, LENGTH, MASK, LMASK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS A SQUARE MATRIX STORED IN SYMMETRIC C FORM. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C BASED ON THE JULY 1982 VERSION OF MATPRT, BY LINDA L. MITCHELL. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + CODE,LENGTH,LMASK,MODE,NC C C ARRAY ARGUMENTS DOUBLE PRECISION + X(LENGTH),Y(LENGTH) INTEGER + MASK(LMASK) C C LOCAL SCALARS DOUBLE PRECISION + SQXII,SQYII INTEGER + I,I0,II,IK,IMASK,J,JMASK,K,KI,KK,KM,KMAX,KN,L,NF, + NLINE C C LOCAL ARRAYS DOUBLE PRECISION + XLINE(10),YLINE(10) INTEGER + INDW(10) C C EXTERNAL FUNCTIONS INTEGER + INPERL EXTERNAL INPERL C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CODE C IF 1 -SINGLE PRINTED, X ONLY (Y IS DUMMY ARG) C 2 -DOUBLE PRINTED LINE, BOTH X AND Y C INTEGER I C ROW NUMBER C INTEGER II C THE INDEX OF THE (I,I)TH ELEMENT OF THE VCV MATRIX C INTEGER IK C THE INDEX OF THE (I,K)TH ELEMENT OF THE VCV MATRIX C INTEGER I0 C THE INDEX OF THE ((I,I)-1)TH ELEMENT OF THE VCV MATRIX C INTEGER IMASK C INDEX IN MASK FOR LABELLING OF THE ROW DIMENSION. C INTEGER INDW(10) C A WORK VECTOR FOR THE INDICES TO BE PRINTED FOR THE C MATRIX. C INTEGER IPRT C THE OUTPUT UNIT NUMBER C INTEGER J C FIRST COLUMN IN THE SET TO BE PRINTED C INTEGER JMASK C INDEX IN MASK FOR LABELLING OF THE COLUMN DIMENSION. C INTEGER K C COLUMN NUMBER IN THE POSSIBLE SET OF NF C INTEGER KI C THE INDEX OF THE (K,I)TH ELEMENT OF THE VCV MATRIX C INTEGER KK C THE INDEX OF THE (K,K)TH ELEMENT OF THE VCV MATRIX C INTEGER KM C LAST COLUMN IN THE SET C LIMITED TO VALUES OF J-1 PLUS A NUMBER BETWEEN 1 AND C NF (INCLUSIVE) C INTEGER KMAX C INDEX IN INDW OF THE LARGEST INDEX TO BE PRINTED FOR C MATRIX. C INTEGER KN C LAST COLUMN TO PRINT WHEN PRINTING LOWER TRIANGLE C INTEGER L C FIRST ROW TO PRINT FOR THIS SET C INTEGER LMASK C LENGTH OF MASK. C INTEGER LENGTH C LENGTH OF X AND Y C INTEGER MASK(LMASK) C MASK VECTOR FOR VCV. THE INDEX OF THE ITH ELEMENT OF C MASK EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF VCV C IN OF THE ITH ROW AND ITH COLUMN. C INTEGER MODE C IF 0, LOWER TRIANGULAR PART PRINTED C 1, LOWER TRIANGULAR PART IS PRINTED WITH C SQUARE ROOTS OF THE DIAGONAL C 2, LOWER TRIANGLE PRINTED AS CORRELATION MATRIX C WITH SQUARE ROOTS ON THE DIAGONAL C 3, FULL MATRIX PRINTED C 4, FULL MATRIX PRINTED WITH CORRELATION MATRIX C PRINTED BELOW THE DIAGONAL C INTEGER NC C ROW AND COLUMN DIMENSION OF X C INTEGER NF C THE NUMBER OF COLUMNS THAT CAN BE PRINTED, GIVEN C THE WIDTH IWIDTH OF THE OUTPUT DEVICE. C INTEGER NLINE C THE NUMBER OF VALUES TO BE PRINTED EACH LINE. C DOUBLE PRECISION SQXII, SQYII C THE SQUARE ROOT OF THE (I,I)TH ELEMENT OF X AND Y. C DOUBLE PRECISION X(LENGTH) C INPUT SYMMETRIC ARRAY STORED ROW WISE C DOUBLE PRECISION XLINE(10) C THE CURRENT VALUES BEING PRINTED FROM ARRAY X. C DOUBLE PRECISION Y(LENGTH) C ARRAY TO BE PRINTED ON THE SECOND LEVEL IF CODE=2 C DOUBLE PRECISION YLINE(10) C THE CURRENT VALUES BEING PRINTED FROM ARRAY Y. C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 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 C BODY OF ROUTINE C CCCCC CALL IPRINT(IPRT) C NF = INPERL(0) C L = 1 JMASK = 0 C C SELECT INITIAL COLUMN TO PRINT THIS PASS OF THE REPORT C DO 90 J=1,NC,NF KN = MIN(NC,J+NF-1) KMAX = MIN(NC-J+1,NF) C C GENERATE VECTOR OF COLUMN HEAD LABELS C DO 20 K=1,KMAX 10 IF (JMASK.GE.LMASK) GO TO 100 JMASK = JMASK + 1 IF (MASK(JMASK).NE.0) GO TO 10 INDW(K) = JMASK 20 CONTINUE C C PRINT VECTOR OF COLUMN HEAD LABELS C WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1000) (INDW(K),K=1,KMAX) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1030) CCCCC CALL DPWRST('XXX','BUG ') IF (MODE.LE.2) L = INDW(1) C C PRINT ALL ROWS IN COLUMN RANGE FOR THIS PASS C IMASK = L - 1 DO 80 I=L,NC KM = KN IF (MODE.LE.2) KM = J + MIN(I-L,NF-1) NLINE = 0 I0 = I*(I-1)/2 II = I0 + I SQXII = SQRT(X(II)) IF (CODE.EQ.2) THEN SQYII = SQRT(Y(II)) ELSE SQYII = 1.0D0 END IF DO 60 K=J,KM NLINE = NLINE + 1 IF (K.GT.I) GO TO 30 IK = I0 + K XLINE(NLINE) = X(IK) IF (CODE.EQ.2) YLINE(NLINE) = Y(IK) GO TO 40 30 KI = K*(K-1)/2 + I XLINE(NLINE) = X(KI) IF (CODE.EQ.2) YLINE(NLINE) = Y(KI) 40 IF (((MODE.NE.1) .AND. (MODE.NE.2)) .OR. (I.NE.K)) GO TO + 50 XLINE(NLINE) = SQXII IF (CODE.EQ.2) YLINE(NLINE) = SQXII 50 IF (((MODE.NE.2) .AND. (MODE.NE.4)) .OR. (K.GE.I)) GO TO + 60 KK = K*(K-1)/2 + K XLINE(NLINE) = XLINE(NLINE)/(SQXII*SQRT(X(KK))) IF (CODE.EQ.2) + YLINE(NLINE) = YLINE(NLINE)/(SQYII*SQRT(Y(KK))) 60 CONTINUE 70 IF (IMASK.GE.LMASK) GO TO 100 IMASK = IMASK + 1 IF (MASK(IMASK).NE.0) GO TO 70 WRITE (IOUNI4,1010) IMASK, (XLINE(K),K=1,NLINE) CCCCC CALL DPWRST('XXX','BUG ') IF (CODE.EQ.2) THEN WRITE (IOUNI4,1020) (YLINE(K),K=1,NLINE) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (CODE.EQ.2) THEN WRITE (IOUNI4,1030) CCCCC CALL DPWRST('XXX','BUG ') ENDIF 80 CONTINUE 90 CONTINUE RETURN C 100 CONTINUE WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1040) CCCCC CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C C 999 FORMAT(1X) 1000 FORMAT (' ', 'COLUMN ', 7(I9, 8X)) 1010 FORMAT (' ', I6, 1X, 7(3X, G14.7)) 1020 FORMAT (' ', 5X, 7(3X, G14.7)) 1030 FORMAT (' ') 1040 FORMAT (' ERROR IN STARPAC. MATPRF TRIES TO ACCESS MORE', + ' ELEMENTS THAN EXIST IN MASK.') END *PARCHK SUBROUTINE PARCHK(IV, N, NN, P, V) C C LATEST REVISION - 03/15/90 (JRD) C C C *** CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + V(33) INTEGER + IV(21) C C LOCAL SCALARS DOUBLE PRECISION + BIG,MACHEP,TINY,VK,ZERO INTEGER + D0INIT,DTYPE,DTYPE0,EPSLON,I,ICH,INITS,IV1,JTINIT,JTOL0, + JTOL1,JTOLP,K,L,M,NVDFLT,OLDN,OLDNN,OLDP,PARPRT,PARSV1, + PRUNIT,PU C C LOCAL ARRAYS DOUBLE PRECISION + VM(27),VX(27) CHARACTER + CNGD(12)*1,DFLT(12)*1,VN(8,27)*1,WHICH(12)*1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + RMDCON EXTERNAL RMDCON C C EXTERNAL SUBROUTINES EXTERNAL DFAULT,VCOPY C C INTEGER IV(21), N, NN, P C DOUBLE PRECISION V(33) C DIMENSION IV(*), V(*) C C EXTERNAL DFAULT, RMDCON, VCOPY C DOUBLE PRECISION RMDCON C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES. C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS. C VCOPY -- COPIES ONE VECTOR TO ANOTHER. C C *** LOCAL VARIABLES *** C C INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU C CHARACTER*1 CNGD(12), WHICH(12) C CHARACTER*1 DFLT(12), VN(8,27) C DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO C C *** IV AND V SUBSCRIPTS *** C C INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0, C 1 JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT 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 BIG/0.0D0/, NVDFLT/27/, TINY/1.0D0/, ZERO/0.0D0/ C DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/, + INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/, + OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/, + PARSV1/51/, PRUNIT/21/ C DATA + VN(1,1),VN(2,1),VN(3,1),VN(4,1),VN(5,1),VN(6,1),VN(7,1),VN(8,1) + /'E', 'P', 'S', 'L', 'O', 'N', '.', '.'/ DATA + VN(1,2),VN(2,2),VN(3,2),VN(4,2),VN(5,2),VN(6,2),VN(7,2),VN(8,2) + /'P', 'H', 'M', 'N', 'F', 'C', '.', '.'/ DATA + VN(1,3),VN(2,3),VN(3,3),VN(4,3),VN(5,3),VN(6,3),VN(7,3),VN(8,3) + /'P', 'H', 'M', 'X', 'F', 'C', '.', '.'/ DATA + VN(1,4),VN(2,4),VN(3,4),VN(4,4),VN(5,4),VN(6,4),VN(7,4),VN(8,4) + /'D', 'E', 'C', 'F', 'A', 'C', '.', '.'/ DATA + VN(1,5),VN(2,5),VN(3,5),VN(4,5),VN(5,5),VN(6,5),VN(7,5),VN(8,5) + /'I', 'N', 'C', 'F', 'A', 'C', '.', '.'/ DATA + VN(1,6),VN(2,6),VN(3,6),VN(4,6),VN(5,6),VN(6,6),VN(7,6),VN(8,6) + /'R', 'D', 'F', 'C', 'M', 'N', '.', '.'/ DATA + VN(1,7),VN(2,7),VN(3,7),VN(4,7),VN(5,7),VN(6,7),VN(7,7),VN(8,7) + /'R', 'D', 'F', 'C', 'M', 'X', '.', '.'/ DATA + VN(1,8),VN(2,8),VN(3,8),VN(4,8),VN(5,8),VN(6,8),VN(7,8),VN(8,8) + /'T', 'U', 'N', 'E', 'R', '1', '.', '.'/ DATA + VN(1,9),VN(2,9),VN(3,9),VN(4,9),VN(5,9),VN(6,9),VN(7,9),VN(8,9) + /'T', 'U', 'N', 'E', 'R', '2', '.', '.'/ DATA + VN(1,10),VN(2,10),VN(3,10),VN(4,10),VN(5,10),VN(6,10),VN(7,10), + VN(8,10) + /'T', 'U', 'N', 'E', 'R', '3', '.', '.'/ DATA + VN(1,11),VN(2,11),VN(3,11),VN(4,11),VN(5,11),VN(6,11),VN(7,11), + VN(8,11) + /'T', 'U', 'N', 'E', 'R', '4', '.', '.'/ DATA + VN(1,12),VN(2,12),VN(3,12),VN(4,12),VN(5,12),VN(6,12),VN(7,12), + VN(8,12) + /'T', 'U', 'N', 'E', 'R', '5', '.', '.'/ DATA + VN(1,13),VN(2,13),VN(3,13),VN(4,13),VN(5,13),VN(6,13),VN(7,13), + VN(8,13) + /'A', 'F', 'C', 'T', 'O', 'L', '.', '.'/ DATA + VN(1,14),VN(2,14),VN(3,14),VN(4,14),VN(5,14),VN(6,14),VN(7,14), + VN(8,14) + /'R', 'F', 'C', 'T', 'O', 'L', '.', '.'/ DATA + VN(1,15),VN(2,15),VN(3,15),VN(4,15),VN(5,15),VN(6,15),VN(7,15), + VN(8,15) + /'X', 'C', 'T', 'O', 'L', '.', '.', '.'/ DATA + VN(1,16),VN(2,16),VN(3,16),VN(4,16),VN(5,16),VN(6,16),VN(7,16), + VN(8,16) + /'X', 'F', 'T', 'O', 'L', '.', '.', '.'/ DATA + VN(1,17),VN(2,17),VN(3,17),VN(4,17),VN(5,17),VN(6,17),VN(7,17), + VN(8,17) + /'L', 'M', 'A', 'X', '0', '.', '.', '.'/ DATA + VN(1,18),VN(2,18),VN(3,18),VN(4,18),VN(5,18),VN(6,18),VN(7,18), + VN(8,18) + /'D', 'L', 'T', 'F', 'D', 'J', '.', '.'/ DATA + VN(1,19),VN(2,19),VN(3,19),VN(4,19),VN(5,19),VN(6,19),VN(7,19), + VN(8,19) + /'D', '0', 'I', 'N', 'I', 'T', '.', '.'/ DATA + VN(1,20),VN(2,20),VN(3,20),VN(4,20),VN(5,20),VN(6,20),VN(7,20), + VN(8,20) + /'D', 'I', 'N', 'I', 'T', '.', '.', '.'/ DATA + VN(1,21),VN(2,21),VN(3,21),VN(4,21),VN(5,21),VN(6,21),VN(7,21), + VN(8,21) + /'J', 'T', 'I', 'N', 'I', 'T', '.', '.'/ DATA + VN(1,22),VN(2,22),VN(3,22),VN(4,22),VN(5,22),VN(6,22),VN(7,22), + VN(8,22) + /'D', 'L', 'T', 'F', 'D', 'C', '.', '.'/ DATA + VN(1,23),VN(2,23),VN(3,23),VN(4,23),VN(5,23),VN(6,23),VN(7,23), + VN(8,23) + /'D', 'F', 'A', 'C', '.', '.', '.', '.'/ DATA + VN(1,24),VN(2,24),VN(3,24),VN(4,24),VN(5,24),VN(6,24),VN(7,24), + VN(8,24) + /'R', 'L', 'I', 'M', 'I', 'T', '.', '.'/ DATA + VN(1,25),VN(2,25),VN(3,25),VN(4,25),VN(5,25),VN(6,25),VN(7,25), + VN(8,25) + /'C', 'O', 'S', 'M', 'I', 'N', '.', '.'/ DATA + VN(1,26),VN(2,26),VN(3,26),VN(4,26),VN(5,26),VN(6,26),VN(7,26), + VN(8,26) + /'D', 'E', 'L', 'T', 'A', '0', '.', '.'/ DATA + VN(1,27),VN(2,27),VN(3,27),VN(4,27),VN(5,27),VN(6,27),VN(7,27), + VN(8,27) + /'F', 'U', 'Z', 'Z', '.', '.', '.', '.'/ C DATA VM(1)/1.0D-3/, VM(2)/-0.99D0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/, + VM(5)/1.2D0/, VM(6)/1.0D-2/, VM(7)/1.2D0/, VM(8)/0.0D0/, + VM(9)/0.0D0/, VM(10)/1.0D-3/, VM(11)/-1.0D0/, VM(15)/0.0D0/, + VM(16)/0.0D0/, VM(19)/0.0D0/, VM(20)/-10.0D0/, VM(21)/0.0D0/, + VM(23)/0.0D0/, VM(24)/1.0D10/, VM(27)/1.01D0/ DATA VX(1)/0.9D0/, VX(2)/-1.0D-3/, VX(3)/1.0D1/, VX(4)/0.8D0/, + VX(5)/1.0D2/, VX(6)/0.8D0/, VX(7)/1.0D2/, VX(8)/0.5D0/, + VX(9)/0.5D0/, VX(10)/1.0D0/, VX(11)/1.0D0/, VX(14)/0.1D0/, + VX(15)/1.0D0/, VX(16)/1.0D0/, VX(18)/1.0D0/, VX(22)/1.0D0/, + VX(23)/1.0D0/, VX(25)/1.0D0/, VX(26)/1.0D0/, VX(27)/1.0D2/ C DATA CNGD(1), CNGD(2), CNGD(3), CNGD(4), CNGD(5), CNGD(6) + / '-', '-', '-', 'C', 'H', 'A'/ DATA CNGD(7), CNGD(8), CNGD(9), CNGD(10), CNGD(11), CNGD(12) + / 'N', 'G', 'E', 'D', ' ', 'V'/ DATA DFLT(1), DFLT(2), DFLT(3), DFLT(4), DFLT(5), DFLT(6) + / 'N', 'O', 'N', 'D', 'E', 'F'/ DATA DFLT(7), DFLT(8), DFLT(9), DFLT(10), DFLT(11), DFLT(12) + / 'A', 'U', 'L', 'T', ' ', 'V'/ C C....................................................................... C IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) CCCCC PU = IV(PRUNIT) PU=6 IV1 = IV(1) IF (IV1 .NE. 12) GO TO 30 IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20 IV(1) = 16 IF (PU .NE. 0) THEN WRITE(ICOUT,9999) CALL DPWRST('XXX','BUG ') 9999 FORMAT(1X) WRITE(ICOUT,10) NN, N, P 10 FORMAT('***** BAD NN, N, OR P... NN =',I5,5H, N =,I5, + 5H, P =,I5) CALL DPWRST('XXX','BUG ') ENDIF GO TO 999 20 K = IV(21) CALL DFAULT(IV(21), V(33)) IV(21) = K IV(DTYPE0) = IV(DTYPE+20) IV(OLDN) = N IV(OLDNN) = NN IV(OLDP) = P DO 25 ICH = 1, 12 WHICH(ICH) = DFLT(ICH) 25 CONTINUE GO TO 80 30 IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP)) + GO TO 50 IV(1) = 17 IF (PU .NE. 0) THEN WRITE(ICOUT,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN, + N, P 40 FORMAT(' ///// (NN,N,P) CHANGED FROM (',I5,',',I5,',',I3, + ') TO (',I5,',',I5,',',I3,').') CALL DPWRST('XXX','BUG ') ENDIF GO TO 999 C 50 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70 IV(1) = 50 IF (PU .NE. 0) THEN WRITE(ICOUT,60) IV1 60 FORMAT('****** IV(1) =',I5,' SHOULD BE BETWEEN 0 AND 12.') CALL DPWRST('XXX','BUG ') ENDIF GO TO 999 C 70 DO 75 ICH = 1, 12 WHICH(ICH) = CNGD(ICH) 75 CONTINUE C 80 IF (BIG .GT. TINY) GO TO 90 TINY = RMDCON(1) MACHEP = RMDCON(3) BIG = RMDCON(6) VM(12) = MACHEP VX(12) = BIG VM(13) = TINY VX(13) = BIG VM(14) = MACHEP VM(17) = TINY VX(17) = BIG VM(18) = MACHEP VX(19) = BIG VX(20) = BIG VX(21) = BIG VM(22) = MACHEP VX(24) = RMDCON(5) VM(25) = MACHEP VM(26) = MACHEP 90 M = 0 IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110 M = 18 IF (PU .NE. 0) THEN WRITE(ICOUT,100) IV(INITS) 100 FORMAT(25H****** INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0, + 7H AND 2.) CALL DPWRST('XXX','BUG ') ENDIF 110 K = EPSLON DO 140 I = 1, NVDFLT VK = V(K) IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130 M = K IF (PU .NE. 0) THEN WRITE(ICOUT,120) (VN(ICH, I), ICH=1, 8), + (VN(ICH, I), ICH=1, 8), + K, VK, VM(I), VX(I) 120 FORMAT(8H****** ,8A1,5H.. V(,I2,3H) =,D11.3,7H SHOULD, + ' BE BETWEEN',D11.3,4H AND,D11.3) CALL DPWRST('XXX','BUG ') ENDIF 130 K = K + 1 140 CONTINUE C IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170 C C *** CHECK JTOL VALUES *** C JTOLP = JTOL0 + P DO 160 I = JTOL1, JTOLP IF (V(I) .GT. ZERO) GO TO 160 K = I - JTOL0 IF (PU .NE. 0) THEN WRITE(ICOUT,150) K, I, V(I) 150 FORMAT(12H****** JTOL(,I3,6H) = V(,I3,3H) =,D11.3, + 20H SHOULD BE POSITIVE.) CALL DPWRST('XXX','BUG ') ENDIF M = I 160 CONTINUE C 170 IF (M .EQ. 0) GO TO 180 IV(1) = M GO TO 999 C 180 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999 IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200 M = 1 WRITE(ICOUT,190) 190 FORMAT(' NONDEFAULT VALUES....') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,191) IV(INITS) 191 FORMAT(20H INITS..... IV(25) =,I3) CALL DPWRST('XXX','BUG ') 200 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 210 IF (M .EQ. 0) THEN WRITE(ICOUT,215) (WHICH(ICH), ICH=1, 12) CALL DPWRST('XXX','BUG ') ENDIF M = 1 WRITE(ICOUT,205) IV(DTYPE) 205 FORMAT(20H DTYPE..... IV(16) =,I3) CALL DPWRST('XXX','BUG ') 210 K = EPSLON L = PARSV1 DO 240 I = 1, NVDFLT IF (V(K) .EQ. V(L)) GO TO 230 IF (M .EQ. 0) THEN WRITE(ICOUT,215) (WHICH(ICH), ICH = 1, 12) 215 FORMAT (' ',12A1,'ALUES....') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9999) CALL DPWRST('XXX','BUG ') ENDIF M = 1 WRITE (ICOUT,220) (VN(ICH, I), ICH = 1, 8), K, V(K) 220 FORMAT (1X, 8A1, 5H.. V(, I2, 3H) =, D15.7) CALL DPWRST('XXX','BUG ') 230 K = K + 1 L = L + 1 240 CONTINUE IV(DTYPE0) = IV(DTYPE) CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON)) IF (IV1 .NE. 12) GO TO 999 IF (V(JTINIT) .GT. ZERO) GO TO 260 JTOLP = JTOL0 + P WRITE(ICOUT,250) 250 FORMAT(24H (INITIAL) JTOL ARRAY...) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,251) (V(I), I = JTOL1, JTOLP) 251 FORMAT((1X,6D12.3)) CALL DPWRST('XXX','BUG ') 260 IF (V(D0INIT) .GT. ZERO) GO TO 999 K = JTOL1 + P L = K + P - 1 WRITE(ICOUT,270) 270 FORMAT(22H (INITIAL) D0 ARRAY...) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,271) (V(I), I = K, L) 271 FORMAT(1X,6D12.3) CALL DPWRST('XXX','BUG ') C 999 RETURN C *** LAST CARD OF PARCHK FOLLOWS *** END *STKREL SUBROUTINE STKREL(NUMBER) C C LATEST REVISION - 03/15/90 (JRD) C C DE-ALLOCATES THE LAST (NUMBER) ALLOCATIONS MADE IN THE STACK C BY STKGET. C C ERROR STATES - C C 1 - NUMBER .LT. 0 C 2 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION C 4 - THE POINTER AT ISTAK(LNOW) OVERWRITTEN C C THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK FUNCTION ISTKGT C C ADAPTED BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NUMBER C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER CCCCC+ IN,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED + IN,LBOOK,LMAX,LNOW,LOUT,LUSED C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF IERR .EQ. 0, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IN C ... C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LBOOK C THE NUMBER OF WORDS USED FOR BOOKEEPING. C INTEGER LMAX C THE MAXIMUM LENGTH OF THE STACK. C INTEGER LNOW C THE CURRENT ACTIVE LENGTH OF THE STACK. C INTEGER LOUT C THE NUMBER OF CURRENT ALLOCATIONS. C INTEGER LUSED C THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED. C INTEGER NUMBER C THE NUMBER OF ALLOCATIONS TO BE FREED FROM THE STACK. 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 IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) GO TO 20 C IN = NUMBER 10 IF (IN.EQ.0) RETURN C IF (LNOW.LE.LBOOK) GO TO 30 C C CHECK TO MAKE SURE THE BACK POINTERS ARE MONOTONE. C IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) GO TO 40 C LOUT = LOUT-1 LNOW = ISTAK(LNOW) IN = IN-1 GO TO 10 C C PRINT ERROR MESSAGES C 20 IERR = 1 CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1000) 1000 FORMAT (' ***** ERROR *****') CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1002) 1002 FORMAT (' DSTAK BOOKKEEPING ELEMENTS HAVE BEEN OVERWRITTEN.') CALL DPWRST('XXX','BUG ') RETURN C 30 IERR = 1 CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1010) 1010 FORMAT (' ***** ERROR *****') CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1012) 1012 FORMAT ( + ' ATTEMPT HAS BEEN MADE TO DE-ALLOCATE A NON-EXISTANT,', + ' ALLOCATION IN DSTAK.') CALL DPWRST('XXX','BUG ') RETURN C 40 IERR = 1 CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1020) LOUT 1020 FORMAT (' ***** ERROR *****') CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1022) LOUT 1022 FORMAT( + ' THE POINTER FOR ALLOCATION NUMBER ', I3, ' HAS BEEN', + ' OVERWRITTEN.') CALL DPWRST('XXX','BUG ') C RETURN END *AMDRV SUBROUTINE AMDRV (MDLTS3, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, + IXM, NRESTS, RESTS, D, WEIGHT, WT, LWT, STPT, LSTPT, SCL, LSCL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE NUMERICAL APPROXIMATIONS TO THE C DERIVATIVE MATRIX (JACOBIAN). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,LSCL,LSTPT,LWT,M,N,NPAR,NRESTS LOGICAL + DONE,WEIGHT C C ARRAY ARGUMENTS DOUBLE PRECISION + D(NRESTS,*),PAR(*),RESTS(*),SCL(*),STPT(*),WT(*),XM(IXM,*) INTEGER + IFIXD(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDLTS3 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + PJ,STPJ INTEGER + I,J,JPK C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION D(NRESTS,NPAR) C THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN). C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL. C LOGICAL DONE C THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL C COMPUTATION OF THE JACOBIAN OR NOT. C INTEGER I C AN INDEX VARIABLE. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER J C AN INDEX VARIABLE. C INTEGER JPK C AN INDEX VARIABLE. C INTEGER LSCL C THE DIMENSION OF VECTOR SCL. C INTEGER LSTPT C THE DIMENSION OF VECTOR STPT. C INTEGER LWT C THE DIMENSION OF VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDLTS3 C THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL C RESIDUALS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PJ C A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER. C DOUBLE PRECISION RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C DOUBLE PRECISION SCL(LSCL) C THE SCALE VALUES. C DOUBLE PRECISION STPT(LSTPT) C THE STEP SIZE ARRAY. C DOUBLE PRECISION STPJ C THE JTH STEP SIZE. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. 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 COMPUTE FINITE-DIFFERENCE JACOBIAN OF THE OPTIMIZED PARAMETERS C JPK = 0 C DO 20 J=1,NPAR C IF (IFIXD(J).NE.0) GO TO 20 C JPK = JPK + 1 C PJ = PAR(J) IF (SCL(JPK).NE.0.0D0) THEN STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*MAX(ABS(PAR(J)),1.0D0/ + ABS(SCL(JPK))) ELSE IF (PAR(J).NE.0.0D0) THEN STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*ABS(PAR(J)) ELSE STPJ = STPT(J) END IF END IF C STPJ = STPJ + PAR(J) STPJ = STPJ - PAR(J) C PAR(J) = PJ + STPJ CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, D(1,J)) C DO 10 I=1,NRESTS D(I,JPK) = (-RESTS(I)+D(I,J))/STPJ 10 CONTINUE C PAR(J) = PJ C 20 CONTINUE C RETURN C END *AMLST1 SUBROUTINE AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL, + SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE PARAMETERS FOR THE ARIMA ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + T975 INTEGER + IAMHD,IPARMN,IPARMX,LBLTYP,LSCALE,LSTPT,LVCVL,NFAC,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),SCALE(*),STPT(*),VCVL(*) INTEGER + IFIXD(*),MSPECT(NFAC,4) C C LOCAL SCALARS DOUBLE PRECISION + FPLM,PLL,PUL,RATIO,SDPAR INTEGER CCCCC+ IPRT,J,K,L,LL,LPAR,ORDER + J,K,L,LL,LPAR,ORDER C C LOCAL ARRAYS CHARACTER + FIXED(3)*1 C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES CCCCC EXTERNAL FIXPRT,IPRINT EXTERNAL FIXPRT C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 FIXED(3) C THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT. C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER IAMHD C THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST C TO BE GENERATED C IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE C ESTIMATION ROUTINES. C IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE C FORECASTING ROUTINES. C IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE C ESTIMATION ROUTINES. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IPARMN C THE SMALLEST PARAMETER INDEX INCLUDED IN THIS TERM. C INTEGER IPARMX C THE LARGEST PARAMETER INDEX INCLUDED IN THIS TERM. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER LVCVL C THE DIMENSION OF VECTOR VCVL. C INTEGER J C AN INDEX VARIABLE. C INTEGER L C AN INDEX VARIABLE. C INTEGER LBLTYP C THE TYPE OF LABLE TO BE PRINTED, WHERE C 1 INDICATES THE TERM IS AUTOREGRESSIVE AND C 2 INDICATES THE TERM IS MOVING AVERAGE C INTEGER LL C AN INDEX VARIABLE. C INTEGER LPAR C AN INDEX VARIABLE. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSTPT C THE DIMENSION OF VECTOR STPT. C INTEGER MSPECT(NFAC,4) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER ORDER C THE ORDER OF B FOR THE PARAMETER BEING PRINTED C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PLL C THE LOWER CONFIDENCE LIMIT FOR A GIVEN PARAMETER. C DOUBLE PRECISION PUL C THE UPPER CONFIDENCE LIMIT FOR A GIVEN PARAMETER. C DOUBLE PRECISION RATIO C THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION SDPAR C THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE. C DOUBLE PRECISION STPT(LSTPT) C THE STEP SIZE ARRAY. C DOUBLE PRECISION T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C DOUBLE PRECISION VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. 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 FPLM = D1MACH(2) C CCCCC CALL IPRINT(ICOUT) C C PRINT NEXT SET OF TERMS C LPAR = 0 DO 1 J=1,IPARMX IF (IFIXD(J).EQ.0) LPAR = LPAR + 1 1 CONTINUE DO 40 J=1,NFAC IF (IAMHD.EQ.3.AND.LBLTYP.EQ.1)THEN WRITE(ICOUT,601) J CALL DPWRST('XXX','BUG ') 601 FORMAT(' FACTOR ',I1) ENDIF IF ((MSPECT(J,LBLTYP).EQ.0) .AND. (LBLTYP.NE.2)) GO TO 40 IF (LBLTYP.NE.2) IPARMX = IPARMX + MSPECT(J,LBLTYP) IF (LBLTYP.EQ.2) IPARMX = IPARMX + 1 ORDER = 0 DO 30 L = IPARMN, IPARMX ORDER = ORDER + MSPECT(J,4) IF (IAMHD.EQ.2) THEN IF (LBLTYP.EQ.1) THEN WRITE(ICOUT, 1010) L, J, ORDER, PAR(L) CALL DPWRST('XXX','BUG ') 1010 FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,E17.8) ELSEIF (LBLTYP.EQ.2) THEN WRITE(ICOUT, 1014) L, PAR(L) CALL DPWRST('XXX','BUG ') 1014 FORMAT(1X, I5, 13X, 'MU', 4X, ' ###' ,E17.8) ELSEIF (LBLTYP.EQ.3) THEN WRITE(ICOUT, 1015) L, J, ORDER, PAR(L) CALL DPWRST('XXX','BUG ') 1015 FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,E17.8) ENDIF GOTO30 ENDIF CALL FIXPRT(IFIXD(L), FIXED) IF (IAMHD.EQ.1) THEN IF (IFIXD(L).EQ.0) THEN IF (LBLTYP.EQ.1) THEN WRITE(ICOUT, 1000) L,J,ORDER,(FIXED(K),K=1,3),PAR(L), + STPT(L) CALL DPWRST('XXX','BUG ') 1000 FORMAT(1X,I5,2X,'AR (FACTOR',I2,')',4X,I5,6X,3A1,2E17.8) ELSEIF (LBLTYP.EQ.2) THEN WRITE(ICOUT, 1004) L, (FIXED(K),K=1,3), PAR(L),STPT(L) CALL DPWRST('XXX','BUG ') 1004 FORMAT(1X, I5, 13X, 'MU', 4X, ' ###' ,6X,3A1,2E17.8) ELSEIF (LBLTYP.EQ.3) THEN WRITE(ICOUT, 1005) L,J,ORDER,(FIXED(K),K=1,3),PAR(L), + STPT(L) CALL DPWRST('XXX','BUG ') 1005 FORMAT(1X,I5,2X,'MA (FACTOR',I2,')',4X,I5,6X,3A1,2E17.8) ENDIF ELSE IF (LBLTYP.EQ.1) THEN WRITE(ICOUT, 1000) L,J,ORDER,(FIXED(K),K=1,3),PAR(L) CALL DPWRST('XXX','BUG ') ELSEIF (LBLTYP.EQ.2) THEN WRITE(ICOUT, 1004) L, (FIXED(K),K=1,3), PAR(L) CALL DPWRST('XXX','BUG ') ELSEIF (LBLTYP.EQ.3) THEN WRITE(ICOUT, 1005) L,J,ORDER,(FIXED(K),K=1,3),PAR(L) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF (IAMHD.EQ.3) THEN IF (IFIXD(L).NE.0) THEN IF (LBLTYP.EQ.1) THEN WRITE(ICOUT, 3000) ORDER,PAR(L) CALL DPWRST('XXX','BUG ') 3000 FORMAT(2X,'*AR',1X,I2,1X,2E15.8,F8.2,2E15.8) ELSEIF (LBLTYP.EQ.2) THEN WRITE(ICOUT, 3004) PAR(L) CALL DPWRST('XXX','BUG ') 3004 FORMAT(2X,'*MU',' ### ' ,2E15.8,F8.2, + 2E16.8) ELSEIF (LBLTYP.EQ.3) THEN WRITE(ICOUT, 3005) ORDER,(FIXED(K),K=1,3),PAR(L) CALL DPWRST('XXX','BUG ') 3005 FORMAT(2X,'*MA',1X,I2,1X,2E15.8,F8.2,2E16.8) ENDIF ELSE C LPAR = LPAR + 1 RATIO = FPLM LL = LPAR*(LPAR-1)/2 + LPAR IF (VCVL(LL).GT.0.0D0) RATIO = PAR(L)/SQRT(VCVL(LL)) SDPAR = SQRT(VCVL(LL)) PLL = PAR(L) - T975*SDPAR PUL = PAR(L) + T975*SDPAR CCCCC WRITE(ICOUT, 1003) SDPAR, RATIO, PLL, PUL CCCCC CALL DPWRST('XXX','BUG ') C1003 FORMAT ('+', 55X, 4(2X, E15.8)) WRITE(IOUNI1, 1013) PAR(L), SDPAR, RATIO, PLL, PUL 1013 FORMAT (5(1X, E16.8)) IF (LBLTYP.EQ.1) THEN WRITE(ICOUT, 2000) ORDER,PAR(L), + SDPAR, RATIO, PLL, PUL CALL DPWRST('XXX','BUG ') 2000 FORMAT(3X,'AR',1X,I2,1X,2E15.8,F8.2,2E16.8) ELSEIF (LBLTYP.EQ.2) THEN WRITE(ICOUT, 2004) PAR(L), SDPAR, RATIO, PLL, PUL CALL DPWRST('XXX','BUG ') 2004 FORMAT(3X,'MU',' ## ' ,2E15.8,F8.2,2E16.8) ELSEIF (LBLTYP.EQ.3) THEN WRITE(ICOUT, 2005) ORDER,PAR(L),SDPAR,RATIO,PLL,PUL CALL DPWRST('XXX','BUG ') 2005 FORMAT(3X,'MA',1X,I2,1X,2E15.8,F8.2,2E16.8) ENDIF ENDIF ENDIF 30 CONTINUE IPARMN = IPARMX + 1 40 CONTINUE C RETURN END *EISII SUBROUTINE EISII(NMSUB, NMVAR, IVAL, IVALMN, IVALMX, MSGTYP, + HEAD, ERROR, NMMIN, NMMAX) C C LATEST REVISION - 03/15/90 (JRD) C C THE ROUTINE CHECKS WHETHER THE VALUE IVAL IS WITHIN THE C THE RANGE IVALMN (INCLUSIVE) TO IVALMX (INCLUSIVE), AND PRINTS A C DIAGNOSTIC IF IT IS NOT. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 29, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVAL,IVALMN,IVALMX,MSGTYP LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C INTEGER IVALMN, IVALMX C THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE C ARGUMENT MUST LIE. C INTEGER MSGTYP C AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE C PRINTED, WHERE IF ERROR IS .TRUE. AND C MSGTYP = 1 THE INPUT VALUE WAS OUTSIDE THE RANGE DETERMINED C FROM OTHER INPUT ARGUMENTS C MSGTYP = 2 THE INPUT VALUE WAS OUTSIDE THE RANGE IMPOSED BY C STARPAC C CHARACTER*1 NMMAX(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MAXIMUM. C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE ARGUMENTS NAME. C 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 ERROR = .FALSE. C IF (((IVALMN.LE.IVAL) .AND. (IVAL.LE.IVALMX)) .OR. + (IVALMX.LT.IVALMN)) RETURN C ERROR = .TRUE. CCCCC CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.2) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), IVAL CALL DPWRST('XXX','BUG ') ENDIF C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) CALL DPWRST('XXX','BUG ') ENDIF C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1020) (NMVAR(I),I=1,6), IVALMN, IVALMX CALL DPWRST('XXX','BUG ') ENDIF C C PRINT MESSAGE FOR AOV ROUTINES C IF (MSGTYP .EQ. 3) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1030) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1031) CALL DPWRST('XXX','BUG ') ENDIF RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', I6, '.') 1010 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE BETWEEN', 1X, 8A1, + ' AND ', 8A1, ', INCLUSIVE.') 1020 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE BETWEEN', 1X, I6, + ' AND ', I6, ', INCLUSIVE.') 1030 FORMAT(' THE NUMBER OF DISTINCT GROUPS (NG) MUST BE BETWEEN') 1031 FORMAT( +' TWO AND ONE LESS THAN THE NUMBER OF POSITIVE TAG VALUES.') C END *IMDCON INTEGER FUNCTION IMDCON(K) C C LATEST REVISION - 03/15/90 (JRD) C C *** RETURN INTEGER MACHINE-DEPENDENT CONSTANTS *** C C *** K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER. *** C *** K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER. *** C *** K = 3 MEANS RETURN INPUT UNIT NUMBER. *** C (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.) C C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + K C C LOCAL ARRAYS INTEGER + MDCON(3) C C EXTERNAL FUNCTIONS CCCCC INTEGER CCCCC+ I1MACH CCCCC EXTERNAL I1MACH 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 MDCON(1) = I1MACH(2) MDCON(2) = I1MACH(3) MDCON(3) = I1MACH(1) C IMDCON = MDCON(K) RETURN C *** LAST CARD OF IMDCON FOLLOWS *** END *MDLTS1 SUBROUTINE MDLTS1 (PAR, NPAR, XM, N, M, IXM, RESTS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR ESTIMATING BOX-JENKINS C ARIMA MODELS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,M,N,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),RESTS(NRESTS),XM(IXM,M) C C SCALARS IN COMMON INTEGER + IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS, + PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + PMU INTEGER + I,I1 C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL SUBROUTINES EXTERNAL MDLTS2 C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER I C AN INDEX VARIABLE. C INTEGER IFLAG C AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS C WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1). C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C DOUBLE PRECISION RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. C 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 C COMPUTE RESIDUALS C CALL MDLTS2 (PAR, RESTS, XM(1,1), NPAR, N, NFACT, ISTAK(MSPECT), + PMU, RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR), + RSTAK(PARMA), MBO, N-NRESTS+1, N, IFLAG) C C COMPUTE PREDICTED VALUES C I1=NRESTS-N DO 20 I = 1,N I1=I1+1 RESTS(I) = XM(I1,1)-RESTS(I1) 20 CONTINUE C RETURN END *PPFNML DOUBLE PRECISION FUNCTION PPFNML(P) C C LATEST REVISION - 03/15/90 (JRD) C C THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE C NORPPF, WITH MODIFICATIONS TO FACILITATE CONVERSION TO C DOUBLE PRECISION AUTOMATICALLY USING THE NAG, INC. CODE APT, AND C TO CORRESPOND TO STARPAC CONVENTIONS. C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE NORMAL (GAUSSIAN) C DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C ERROR CHECKING--NONE C RESTRICTIONS--P SHOULD BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVELY. C REFERENCES--ODEH AND EVANS, THE PERCENTAGE POINTS C OF THE NORMAL DISTRIBUTION, ALGORTIHM 70, C APPLIED STATISTICS, 1974, PAGES 96-97. C --EVANS, ALGORITHMS FOR MINIMAL DEGREE C POLYNOMIAL AND RATIONAL APPROXIMATION, C M. SC. THESIS, 1972, UNIVERSITY C OF VICTORIA, B. C., CANADA. C --HASTINGS, APPROXIMATIONS FOR DIGITAL C COMPUTERS, 1955, 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 C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON 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 C DISTRIBUTIONS--1, 1970, PAGES 40-111. C --THE KELLEY STATISTICAL TABLES, 1948. C --OWEN, HANDBOOK OF STATISTICAL TABLES, C 1962, PAGES 3-16. C --PEARSON AND HARTLEY, BIOMETRIKA TABLES C FOR STATISTICIANS, VOLUME 1, 1954, C PAGES 104-113. C COMMENTS--THE CODING AS PRESENTED BELOW C IS ESSENTIALLY IDENTICAL TO THAT C PRESENTED BY ODEH AND EVANS C AS ALGORTIHM 70 OF APPLIED STATISTICS. C THE PRESENT AUTHOR HAS MODIFIED THE C ORIGINAL ODEH AND EVANS CODE WITH ONLY C MINOR STYLISTIC CHANGES. C --AS POINTED OUT BY ODEH AND EVANS C IN APPLIED STATISTICS, C THEIR ALGORITHM REPRESENTES A C SUBSTANTIAL IMPROVEMENT OVER THE C PREVIOUSLY EMPLOYED C HASTINGS APPROXIMATION FOR THE C NORMAL PERCENT POINT FUNCTION-- C THE ACCURACY OF APPROXIMATION C BEING IMPROVED FROM 4.5*(10**-4) C TO 1.5*(10**-8). C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1976. C C MODIFIED BY --JANET R. DONALDSON, DECEMBER 7, 1981 C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORDAO C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + P C C LOCAL SCALARS DOUBLE PRECISION + ADEN,ANUM,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T C C INTRINSIC FUNCTIONS INTRINSIC LOG,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ADEN, ANUM C * C DOUBLE PRECISION P C THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED C DOUBLE PRECISION P0, P1, P2, P3, P4 C VARIOUS PARAMETERS USED IN THE APPROXIMATIONS. C DOUBLE PRECISION Q0, Q1, Q2, Q3, Q4 C VARIOUS ADDITIONAL PARAMETERS USED IN THE APPROXIMATIONS. C DOUBLE PRECISION R C * C DOUBLE PRECISION T C * C 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 P0, P1, P2, P3, P4 + /-.322232431088D0, -1.0D0, -.342242088547D0, + -.204231210245D-1,-.453642210148D-4/ DATA Q0, Q1, Q2, Q3, Q4 + /.993484626060D-1, .588581570495D0, + .531103462366D0, .103537752850D0, .38560700634D-2/ C C IF (P.NE.0.5D0) GO TO 30 PPFNML = 0.0D0 RETURN C 30 R = P IF (P.GT.0.5D0) R = 1.0D0 - R T = SQRT(-2.0D0*LOG(R)) ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) PPFNML = T + (ANUM/ADEN) C IF (P.LT.0.5D0) PPFNML = -PPFNML C RETURN C END *STKSET SUBROUTINE STKSET (NITEMS, ITYPE) C C LATEST REVISION - 03/15/90 (JRD) C C INITIALIZES THE STACK TO NITEMS OF TYPE ITYPE C C THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK SUBROUTINE ISTKIN C C ADAPTED BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ITYPE,NITEMS C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + LBOOK,LMAX,LNOW,LOUT,LUSED C C LOCAL ARRAYS INTEGER + ISIZE(5),ISTAK(12) C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),LOUT) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),ISIZE(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISIZE(5) C THE NUMBER OF WORDS IN EACH OF THE VARIOUS DATA TYPES. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ITYPE C THE TYPE OF ARRAY OF LENGTH NITEMS TO BE ALLOCATED. C INTEGER LBOOK C THE NUMBER OF WORDS USED FOR BOOKEEPING. C INTEGER LMAX C THE MAXIMUM LENGTH OF THE STACK. C INTEGER LNOW C THE CURRENT ACTIVE LENGTH OF THE STACK. C INTEGER LOUT C THE NUMBER OF CURRENT ALLOCATIONS. C INTEGER LUSED C THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED. C INTEGER NITEMS C THE LENGTH OF THE ARRAY OF ITYPE TO BE ALLOCATED. C 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 HERE TO INITIALIZE C C SET DATA SIZES APPROPRIATE FOR A STANDARD CONFORMING C FORTRAN SYSTEM USING THE FORTRAN "STORAGE UNIT" AS THE C MEASURE OF SIZE. C C LOGICAL ISIZE(1) = 1 C INTEGER ISIZE(2) = 1 C DOUBLE PRECISION ISIZE(3) = 1 C DOUBLE PRECISION ISIZE(4) = 2 C COMPLEX ISIZE(5) = 2 C LBOOK = 10 LNOW = LBOOK LUSED = LBOOK LMAX = MAX( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 ) LOUT = 0 C RETURN C END *AMECNT SUBROUTINE AMECNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRV, APRXDV, + DRV, PAR, NPAR, RES, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, + STOPP, SCALE, LSCALE, DELTA, IVAPRX, RSD, PV, LPV, SDPV, + LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, NPARE, + NLHDR, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT, NRESTS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,IXM,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,M, + MIT,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS LOGICAL + APRXDV,HLFRPT,PAGE,SAVE,WEIGHT,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*), + VCV(IVCV,*),WT(*),XM(IXM,*),Y(*) INTEGER + IFIXED(*),IPTOUT(5) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL,NLDRV,NLHDR C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + D,IFIXD,IFP,IIWORK,IRWORK,IWORK,LVCVL,NALL0,PARE,PVI, + RESTS,RWORK,SDPVI,SDRESI,VCVL C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL AMEMN,CPYASF,CPYVII,DCOPY,SETIV,STKCLR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL APRXDV C THE VARIABLE USED TO INDICATE WHETHER NUMERICAL C APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT C (FALSE). C INTEGER D C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE ARRAY IN WHICH THE NUMERICAL DERIVATIVES WITH RESPECT TO C EACH PARAMETER ARE STORED. C DOUBLE PRECISION DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE C CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE C INITIAL SUMMARY (TRUE) OR NOT (FALSE). C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD C THE STARTING LOCATION IN ISTAK OF C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IFIXED(LIFIXD) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. IF C IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED. IF IFIXED(I).EQ C THEN PAR(I) WILL BE HELD FIXED. C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IIWORK C THE DIMENSION OF THE INTEGER WORK VECTOR IWORK. C INTEGER IPTOUT(5) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER IRWORK C THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IVAPRX C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE C IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED C IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED C INTEGER IVCV C THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV. C INTEGER IWORK C THE STARTING LOCATION IN ISTAK OF C THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LIFIXD C THE ACTUAL LENGTH OF THE VECTOR IFIXED. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSCALE C THE ACTUAL LENGTH OF THE VECTOR SCALE. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LSTP C THE ACTUAL LENGTH OF THE VECTOR STP. C INTEGER LVCVL C THE LENGTH OF THE VECTOR CONTAINING C THE LOWER HALF OF THE VCV MATRIX, STORED ROW WISE. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATE. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C NUMBER OF ALLOCATIONS ON ENTRY. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C EXTERNAL NLDRV C THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES. C EXTERNAL NLHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE ESTIMATED. C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARE C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE CURRENT ESTIMATES OF THE PARAMETERS, BUT ONLY C THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED). C DOUBLE PRECISION PV(LPV) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C INTEGER PVI C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE PREDICTED VALUES. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C INTEGER RESTS C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE RESIDUALS FROM THE ARIMA MODEL. C DOUBLE PRECISION RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER RWORK C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION SCALE(LSCALE) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C INTEGER SDPVI C THE STARTING LOCATION IN RWORK OF C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C INTEGER SDRESI C THE STARTING LOCATION IN RWORK OF THE C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION STOPP C THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED C RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR C DOUBLE PRECISION STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C DOUBLE PRECISION STP(LSTP) C THE STEP SIZE ARRAY. C DOUBLE PRECISION VCV(IVCV,NPAR) C THE VARIANCE-COVARIANCE MATRIX. C INTEGER VCVL C THE STARTING LOCATION IN RWORK OF C THE VARIANCE-COVARIANCE MATRIX. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C DOUBLE PRECISION Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C 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 SET VARIOUS PROGRAM VALUES C NALL0 = STKST(1) C IFP = 4 C IERR = 0 C C SUBDIVIDE WORK AREA FOR LEAST SQUARES ANALYSIS C IIWORK = NPARE + 60 IRWORK = 94 + 2*NRESTS + NPARE*(3*NPARE+33)/2 C IFIXD = STKGET(NPAR,2) IWORK = STKGET(IIWORK,2) C D = STKGET(NRESTS*NPAR,IFP) PARE = STKGET(NPARE,IFP) RESTS = STKGET(NRESTS,IFP) PVI = RESTS RWORK = STKGET(IRWORK,IFP) C IF (IERR.EQ.1) RETURN C C SET VALUES FOR IFIXD C IF (IFIXED(1).GE.0) CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1) IF (IFIXED(1).LT.0) CALL SETIV(ISTAK(IFIXD), NPAR, 0) C CALL AMEMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, NRESTS, + APRXDV, ISTAK(IFIXD), PAR, RSTAK(PARE), NPAR, RES, PAGE, + WIDE, HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, + DELTA, IVAPRX, IPTOUT, NDIGIT, RSD, RSTAK(RESTS), SDPVI, + SDRESI, VCVL, LVCVL, RSTAK(D), ISTAK(IWORK), IIWORK, + RSTAK(RWORK), IRWORK, NLHDR, NPARE, RSTAK(PVI)) C IF (.NOT.SAVE) GO TO 10 C SDPVI = RWORK + SDPVI - 1 SDRESI = RWORK + SDRESI - 1 VCVL = RWORK + VCVL - 1 C CALL DCOPY(N, RSTAK(PVI), 1, PV, 1) CALL DCOPY(N, RSTAK(SDPVI), 1, SDPV, 1) CALL DCOPY(N, RSTAK(SDRESI), 1, SDRES, 1) CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV) C 10 CALL STKCLR(NALL0) C RETURN C END *ASSESS SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0) C C LATEST REVISION - 03/15/90 (JRD) C C C *** ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2) *** C C *** PURPOSE *** C C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM- C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING C BELOW. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),STEP(P),STLSTG(P),V(*),X(P),X0(P) INTEGER + IV(*) C C LOCAL SCALARS DOUBLE PRECISION + EMAX,GTS,HALF,ONE,RELDX1,RFAC1,TEMP,TWO,XMAX,ZERO INTEGER + AFCTOL,DECFAC,DST0,DSTNRM,DSTSAV,F,F0,FDIF,FLSTGD,GTSLST, + GTSTEP,I,INCFAC,IRC,LMAX0,MLSTGD,MODEL,NFC,NFCALL,NFGCAL, + NREDUC,PLSTGD,PREDUC,RADFAC,RADINC,RDFCMN,RDFCMX,RELDX, + RESTOR,RFCTOL,STAGE,STGLIM,STPPAR,SWITCH,TOOBIG,TUNER1, + TUNER2,TUNER3,XCTOL,XFTOL,XIRC LOGICAL + GOODX C C EXTERNAL FUNCTIONS DOUBLE PRECISION CCCCC+ D1MACH,RELDST + RELDST CCCCC EXTERNAL D1MACH,RELDST EXTERNAL RELDST C C EXTERNAL SUBROUTINES EXTERNAL VCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C-------------------------- PARAMETER USAGE -------------------------- C C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF IV VALUES REFERENCED. C D (IN) SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW. C P (IN) NUMBER OF PARAMETERS BEING OPTIMIZED. C STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED. IT IS UN- C CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A C BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG C WILL HAVE BEEN COPIED TO STEP. C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE C CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC- C TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE C BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA- C TION). IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION C VALUE, THEN STEP IS RESTORED FROM STLSTG AND C X = X0 + STEP IS RECOMPUTED. C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION C BELOW OF V VALUES REFERENCED. C X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC- C TIVE FUNCTION HAS JUST BEEN EVALUATED. IF AN EARLIER C STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS C RESTORED TO THE CORRESPONDING EARLIER VALUE. OTHERWISE, C IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE, C THEN X IS RESTORED TO X0. C X0 (IN) INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE C START OF THE CURRENT ITERATION). C C *** IV VALUES REFERENCED *** C C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION, C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE C UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS. C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE C FOLLOWING VALUES... C 1 = SWITCH MODELS OR TRY SMALLER STEP. C 2 = SWITCH MODELS OR ACCEPT STEP. C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT C TESTS. C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED. C 5 = RECOMPUTE STEP (USING THE SAME MODEL). C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT C EVAULATE THE OBJECTIVE FUNCTION. C 7 = X-CONVERGENCE (SEE V(XCTOL)). C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)). C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE. C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)). C 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)). C 12 = FALSE CONVERGENCE (SEE V(XFTOL)). C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT. C RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11. C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL). C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION. C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION, C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT. C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION. C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED. C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER C OF DECREASES) SO FAR THIS ITERATION. C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN C WHICH CASE ASSESS SETS IV(RESTOR) = 1. C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE C CURRENT ITERATION. C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER. C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL, C IN WHICH CASE ASSESS SETS IV(SWITCH) = 1. C IV(TOOBIG) (IN) IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED C OVERFLOW). C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS. C C *** V VALUES REFERENCED *** C C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS C THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10. C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS C NONZERO. C V(DSTNRM) (IN) THE 2-NORM OF D*STEP. C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP. C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED, C I.E., FOR V(NREDUC) .GE. 0). C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC- C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE, C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE. C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE). C V(FLSTGD) (I/O) SAVED VALUE OF V(F). C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION. C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP. C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT. C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS. C V(LMAX0) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND). C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9, C OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF C V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE- C TURNS WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, C THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR C A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6). C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C NEWTON STEP. IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E., C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR C USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED. C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP. C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR C CURRENT STEP. C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS, C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED. C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1. C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0. C V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED C BY FUNCTION RELDST AS C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) / C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P). C IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM- C PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X C AND STEP. OTHERWISE IT IS COMPUTED USING THE INPUT C VALUES. C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE- C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN C ASSESS RETURNS WITH IV(IRC) = 8 OR 9. SEE ALSO V(LMAX0). C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP. C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED C VALUE = 0.1. C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED C VALUE = 10**-4. C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75. C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN C ASSESS RETURNS IV(IRC) = 7 OR 9. C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL), C THEN ASSESS RETURNS WITH IV(IRC) = 12. C C------------------------------- NOTES ------------------------------- C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER, C OR LEVENBERG-MARQUARDT STEPS. C C *** ALGORITHM NOTES *** C C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS, C ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS. C C *** USAGE NOTES *** C C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O C VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER- C ANCES SHOULD BE CHANGED. C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN C CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH C CASE THE STOPPING TESTS WILL BE REPEATED. C C *** REFERENCES *** C C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1980), C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM, C SUBMITTED TO ACM TRANS. MATH. SOFTWARE. C C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY C P. RABINOWITZ, GORDON AND BREACH, LONDON. C C *** HISTORY *** C C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY. C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS C PRESENT FORM (FALL 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C------------------------ EXTERNAL QUANTITIES ------------------------ C C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL RELDST, VCOPY C DOUBLE PRECISION D1MACH, RELDST C C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C C/ C *** NO COMMON BLOCKS *** C C-------------------------- LOCAL VARIABLES -------------------------- C C LOGICAL GOODX C INTEGER I, NFC C DOUBLE PRECISION EMAX, GTS, HALF, ONE, RELDX1, RFAC1, C + TEMP, TWO, XMAX, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0, C 1 GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL, C 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN, C 3 RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR, C 4 SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL, C 5 XIRC 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 INITIALIZATIONS *** C DATA HALF/0.5D0/, ONE/1.0D0/, TWO/2.0D0/, ZERO/0.0D0/ C DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/, + NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/, + STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/ DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, + DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/, + GTSLST/14/, GTSTEP/4/, INCFAC/23/, + LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/, + RADFAC/16/, RDFCMN/24/, RDFCMX/25/, + RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/, + TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C NFC = IV(NFCALL) IV(SWITCH) = 0 IV(RESTOR) = 0 RFAC1 = ONE GOODX = .TRUE. I = IV(IRC) IF (I .GE. 1 .AND. I .LE. 12) + GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I IV(IRC) = 13 GO TO 999 C C *** INITIALIZE FOR NEW ITERATION *** C 10 IV(STAGE) = 1 IV(RADINC) = 0 V(FLSTGD) = V(F0) IF (IV(TOOBIG) .EQ. 0) GO TO 90 IV(STAGE) = -1 IV(XIRC) = I GO TO 60 C C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS *** C *** FIRST DECIDE WHICH *** C 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30 C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED *** C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION *** IV(STAGE) = IV(STGLIM) IV(RADINC) = -1 GO TO 90 C C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. *** C 30 IV(STAGE) = IV(STAGE) + 1 C C *** NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH *** C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. *** C 40 IF (IV(STAGE) .GT. 0) GO TO 50 C C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. *** C IF (IV(TOOBIG) .NE. 0) GO TO 60 C C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. *** C IV(STAGE) = -IV(STAGE) I = IV(XIRC) GO TO (20, 30, 90, 90, 70), I C 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70 C C *** HANDLE OVERSIZE STEP *** C IF (IV(RADINC) .GT. 0) GO TO 80 IV(STAGE) = -IV(STAGE) IV(XIRC) = IV(IRC) C 60 V(RADFAC) = V(DECFAC) IV(RADINC) = IV(RADINC) - 1 IV(IRC) = 5 GO TO 999 C 70 IF (V(F) .LT. V(FLSTGD)) GO TO 90 C C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. *** C IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80 IV(MODEL) = IV(MLSTGD) IV(SWITCH) = 1 C C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F). C 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 90 IV(RESTOR) = 1 V(F) = V(FLSTGD) V(PREDUC) = V(PLSTGD) V(GTSTEP) = V(GTSLST) IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV) V(DSTNRM) = V(DSTSAV) NFC = IV(NFGCAL) GOODX = .FALSE. C C C *** COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP *** C 90 RELDX1 = RELDST(P, D, X, X0) C C *** RESTORE X AND STEP IF NECESSARY *** C IF (GOODX) GO TO 105 DO 100 I = 1, P STEP(I) = STLSTG(I) X(I) = X0(I) + STLSTG(I) 100 CONTINUE C 105 V(FDIF) = V(F0) - V(F) TEMP = 0.0 IF (V(PREDUC).GT.D1MACH(1)/V(TUNER2)) TEMP = V(TUNER2) * V(PREDUC) IF (V(FDIF).GT.TEMP) GO TO 120 C C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE C *** -- SO TRY NEW MODEL OR SMALLER RADIUS C V(RELDX) = RELDX1 IF (V(F) .LT. V(F0)) GO TO 110 IV(MLSTGD) = IV(MODEL) V(FLSTGD) = V(F) V(F) = V(F0) CALL VCOPY(P, X, X0) IV(RESTOR) = 1 GO TO 115 110 IV(NFGCAL) = NFC 115 IV(IRC) = 1 IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130 IV(IRC) = 5 IV(RADINC) = IV(RADINC) - 1 GO TO 130 C C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED *** C 120 IV(NFGCAL) = NFC RFAC1 = ONE IF (GOODX) V(RELDX) = RELDX1 V(DSTSAV) = V(DSTNRM) IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200 C C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS C *** OR ACCEPT STEP WITH DECREASED RADIUS. C IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125 C *** CONSIDER SWITCHING MODELS *** IV(IRC) = 2 GO TO 130 C C *** ACCEPT STEP WITH DECREASED RADIUS *** C 125 IV(IRC) = 4 C C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR *** C 130 IV(XIRC) = IV(IRC) EMAX = V(GTSTEP) + V(FDIF) V(RADFAC) = HALF * RFAC1 IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * MAX(V(RDFCMN), + HALF * V(GTSTEP)/EMAX) C C *** DO FALSE CONVERGENCE TEST *** C 140 IF (V(RELDX) .LE. V(XFTOL)) GO TO 160 IV(IRC) = IV(XIRC) IF (V(F) .LT. V(F0)) GO TO 230 GO TO 300 C 160 IV(IRC) = 12 GO TO 310 C C *** HANDLE GOOD FUNCTION DECREASE *** C 200 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260 C C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS. C IF (IV(RADINC) .LT. 0) GO TO 260 IF (IV(RESTOR) .EQ. 1) GO TO 260 C C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON C *** STEP. C V(RADFAC) = V(RDFCMX) GTS = V(GTSTEP) IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS) + V(RADFAC) = MAX(V(INCFAC), HALF*GTS/(GTS + V(FDIF))) IV(IRC) = 4 IF (V(STPPAR) .EQ. ZERO) GO TO 300 C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH C *** A LARGER RADIUS. IV(IRC) = 5 IV(RADINC) = IV(RADINC) + 1 C C *** SAVE VALUES CORRESPONDING TO GOOD STEP *** C 230 V(FLSTGD) = V(F) IV(MLSTGD) = IV(MODEL) CALL VCOPY(P, STLSTG, STEP) V(DSTSAV) = V(DSTNRM) IV(NFGCAL) = NFC V(PLSTGD) = V(PREDUC) V(GTSLST) = V(GTSTEP) GO TO 300 C C *** ACCEPT STEP WITH RADIUS UNCHANGED *** C 260 V(RADFAC) = ONE IV(IRC) = 3 GO TO 300 C C *** COME HERE FOR A RESTART AFTER CONVERGENCE *** C 290 IV(IRC) = IV(XIRC) IF (V(DSTSAV) .GE. ZERO) GO TO 310 IV(IRC) = 12 GO TO 310 C C *** PERFORM CONVERGENCE TESTS *** C 300 IV(XIRC) = IV(IRC) 310 IF (ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10 IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999 EMAX = 0.0 IF (ABS(V(F0)).GT.D1MACH(1)/V(RFCTOL)) + EMAX = V(RFCTOL) * ABS(V(F0)) IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX) + IV(IRC) = 11 IF (V(DST0) .LT. ZERO) GO TO 320 I = 0 IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR. + (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2 IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)) I = I + 1 IF (I .GT. 0) IV(IRC) = I + 6 C C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR C *** CONVERGENCE TEST. C 320 IF (ABS(IV(IRC)-3) .GT. 1 .AND. IV(IRC) .NE. 12) GO TO 999 IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330 IF (V(PREDUC) .GE. EMAX) GO TO 999 IF (V(DST0) .LT. ZERO) GO TO 340 IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999 GO TO 340 330 IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999 XMAX = V(LMAX0) / V(DSTNRM) IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999 340 IF (V(NREDUC) .LT. ZERO) GO TO 370 C C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST *** C V(GTSLST) = V(GTSTEP) V(DSTSAV) = V(DSTNRM) IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV) V(PLSTGD) = V(PREDUC) IV(IRC) = 6 CALL VCOPY(P, STLSTG, STEP) GO TO 999 C C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) *** C 360 V(GTSTEP) = V(GTSLST) V(DSTNRM) = ABS(V(DSTSAV)) CALL VCOPY(P, STEP, STLSTG) IV(IRC) = IV(XIRC) IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12 V(NREDUC) = -V(PREDUC) V(PREDUC) = V(PLSTGD) 370 IF (-V(NREDUC) .LE. V(RFCTOL) * ABS(V(F0))) IV(IRC) = 11 C 999 RETURN C C *** LAST CARD OF ASSESS FOLLOWS *** END *ERIODD SUBROUTINE ERIODD(NMSUB, NMVAR, NVAL, MSGTYP, HEAD, ERROR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS ERROR TO TRUE IF THE VALUE NVAL IS NOT EVEN C OR ODD, AS SPECIFIED BY THE PARAMETER ODD. IN ADDITION, IF THIS C IS THE FIRST ERROR FOUND FOR THE CALLING SUBROUTINE NMSUB , IE C IF HEAD IS TRUE, THEN A HEADING FOR THE CALLING SUBROUTINE C IS ALSO PRINTED OUT. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MSGTYP,NVAL LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C A VARIABLE USED TO INDICATE THE TYPE OF MESSAGE TO BE C PRINTED, WHERE IF C MSGTYP = 1, THE INPUT VALUE SHOULD BE ODD AND C MSGTYP = 2, THE INPUT VALUE SHOULD BE EVEN. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THE CALLING SUBROUTINE. C CHARACTER*1 NMVAR(8) C THE ARRAY CONTAINING THE NAME OF THE VARIABLE BEING CHECKED. C INTEGER NVAL C THE VALUE OF THE VARIABLE BEING CHECKED. C 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 ERROR = .FALSE. C IF (MSGTYP .EQ. 2) GO TO 10 C C CHECK FOR ODD C IF (MOD(NVAL, 2) .EQ. 1) RETURN C CCCCC CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,1010) (NMVAR(I),I =1,6), (NMVAR(I), I = 1, 6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) NVAL CALL DPWRST('XXX','BUG ') ERROR = .TRUE. RETURN C 10 CONTINUE C C CHECK FOR EVEN C IF (MOD(NVAL, 2) .EQ. 0) RETURN C CALL EHDR(NMSUB, HEAD) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1020) (NMVAR(I),I=1,6), (NMVAR(I), I = 1, 6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021) NVAL CALL DPWRST('XXX','BUG ') ERROR = .TRUE. RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1010 FORMAT( + ' THE VALUE OF THE VARIABLE ', 6A1, + ' MUST BE ODD. THE INPUT VALUE OF ', 6A1) 1011 FORMAT( + ' IS ', I5, '.') 1020 FORMAT( + ' THE VALUE OF THE VARIABLE ', 6A1, + ' MUST BE EVEN. THE INPUT VALUE OF ', 6A1) 1021 FORMAT( + ' IS ', I5, '.') C END *INPERL INTEGER FUNCTION INPERL (IDUM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE NUMBER OF VECTOR ELEMENTS THAT CAN C BE PRINTED IN A LINE OF OUTPUT ON THE STANDARD OUTPUT FILE. C C ASSUMPTIONS RE - C C 1) MAXIMUM WIDTH OF LINE TO USE (IMAXW) IS 132. C 2) NUMBER OF CHARACTERS NOT VECTOR ELEMENTS PER LINE C (IOCPL) IS 15. C 2) WIDTH OF FIELD FOR AN ELEMENT, INCLUDING SPACING C BETWEEN ELEMENTS (IEW) IS 15. C 4) MAXIMUM ELEMENTS PER LINE (IMAXE) IS 7. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 29, 1982 C EXTRACTED FROM EARLIER LSTVEC. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IDUM C C LOCAL SCALARS INTEGER + IEW,IMAXE,IMAXW,IOCPL,IWIDTH C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IDUM C INPUT PARAMETER. UNUSED ARGUMENT. C INTEGER IEW C WIDTH OF A FIELD FOR PRINTING OUT A VECTOR ELEMENT, C INCLUDING SPACES BETWEEN ADJACENT ELEMENTS. C INTEGER IMAXE C MAXIMUM NUMBER OF ARRAY ELEMENTS PER LINE. C INTEGER IMAXW C MAXIMUM NUMBER OF CHARACTERS TO ALLOW PER LINE. C INTEGER IOCPL C NUMBER OF CHARACTERS TO BE INTRODUCED TO LINE IN ADDITION C TO CHARACTERS IN THE ELEMENT FIELDS. C INTEGER IWIDTH C NUMBER OF CHARACTERS IN A LINE ON THE STANDARD OUTPUT FILE. C C 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 INITIALIZATIONS C CCCCC DATA IEW /15/, IMAXE /7/, IMAXW /132/, IOCPL /15/ DATA IEW /15/, IMAXE /7/, IMAXW /80/, IOCPL /15/ C C COMMENCE BODY OF ROUTINE C CCCCC IWIDTH = 132 IWIDTH = 80 INPERL = (MIN(IWIDTH, IMAXW) - IOCPL)/IEW INPERL = MIN(INPERL, IMAXE) RETURN END *MDLTS2 SUBROUTINE MDLTS2 (PAR, RESTS, Y, NPAR, N, NFAC, MSPECT, PMU, + PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, N1, N2, IFLAG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MODEL ROUTINE FOR PACKS SPECIFICATION OF C BOX-JENKINS MODELS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + PMU INTEGER + IFLAG,MBO,N,N1,N2,NFAC,NPAR,NPARDF C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),PARAR(*),PARDF(*),PARMA(*),RESTS(N1:N2),T(*), + TEMP(*),Y(N) INTEGER + MSPECT(NFAC,4) C C LOCAL SCALARS DOUBLE PRECISION + FPLPM,RESMAX,WTEST INTEGER + I,IMOD,IMOD1,IPAR,IPQ,ISTART,J,K,L,MAXORD,MBO1,NP,NPARAR, + NPARMA LOGICAL + PARLE1 C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,MOD,SIGN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION FPLPM C THE FLOATING POINT LARGEST POSITIVE MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IFLAG C AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS C WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1). C INTEGER IMOD C AN INDEX VARIABLE. C INTEGER IPAR C AN INDEX VARIABLE. C INTEGER IPQ C AN INDEX VARIABLE. C INTEGER ISTART C *** C INTEGER J C AN INDEX VARIABLE. C INTEGER K C AN INDEX VARIABLE. C INTEGER L C AN INDEX VARIABLE. C INTEGER MAXORD C THE LARGEST BACK ORDER. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBO1 C THE VALUE MBO+1 C INTEGER MSPECT(NFAC,4) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NP C THE NUMBER OF PARAMETERS IN THE EXPANDED TERM. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER N1 C THE LOWER BOUND FOR RESTS. C INTEGER N2 C THE UPPER BOUND FOR RESTS. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PARAR(MBO) C THE AUTOREGRESSIVE PARAMETERS C DOUBLE PRECISION PARDF(NPARDF) C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS. C LOGICAL PARLE1 C A FLAG INDICATING WHETHER ALL OF THE MOVING AVERAGE PARAMETERS C ARE LESS THAN OR EQUAL TO 1 (PARLE1 = .TRUE.) OR NOT C (PARLE1 = .FALSE.) C DOUBLE PRECISION PARMA(MBO) C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C DOUBLE PRECISION RESMAX C THE LARGEST POSSIBLE RESIDUAL WHICH WILL STILL AVOID OVERFLOW. C DOUBLE PRECISION RESTS(N1:N2) C THE PREDICTED VALUE OF THE FIT. C DOUBLE PRECISION T(2*MBO) C A TEMPORARY WORK VECTOR. C DOUBLE PRECISION TEMP(MBO) C A TEMPORARY WORK VECTOR C DOUBLE PRECISION WTEST C THE TEST VALUE USED TO DETERMINE IF THE DIFFERENCED SERIES C BACK FORECAST IS EFFECTIVELY ZERO OR NOT. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C 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 FPLPM = D1MACH(2) C C ZERO THE PARAMETER ARRAYS PARAR AND PARMA C DO 10 I=1,MBO T(I) = 0.0D0 TEMP(I) = 0.0D0 10 CONTINUE C NP = 0 IPAR = 0 NPARAR = 0 ISTART = 0 C C EXPAND THE MODEL AND STORE AUTOREGRESSIVE PARAMETERS IN PARAR C AND MOVING AVERAGE PARAMETERS IN PARMA C DO 110 IPQ = 1, 3, 2 DO 100 L=1,NFAC IF (MSPECT(L,IPQ).EQ.0) GO TO 100 MAXORD = MSPECT(L,IPQ)*MSPECT(L,4) DO 90 K = MSPECT(L,4), MAXORD, MSPECT(L,4) IPAR = IPAR + 1 TEMP(K) = TEMP(K) + PAR(IPAR) DO 80 I = 1, NP TEMP(K+I) = TEMP(K+I) - T(I)*PAR(IPAR) 80 CONTINUE 90 CONTINUE NP = NP + MAXORD DO 95 K = 1, NP T(K) = TEMP(K) 95 CONTINUE 100 CONTINUE IF (IPQ.NE.3) THEN IPAR = IPAR + 1 PMU = PAR(IPAR) NPARAR = NP DO 105 K =1, NPARAR PARAR(K) = T(K) T(K) = 0.0D0 TEMP(K) = 0.0D0 105 CONTINUE NP = 0 END IF 110 CONTINUE NPARMA = NP PARLE1 = .TRUE. DO 115 K =1, NPARMA PARMA(K) = T(K) IF (ABS(PARMA(K)).GT.1.0D0) PARLE1 = .FALSE. 115 CONTINUE C C COMPUTE FITTED VALUES AND RESIDUALS FOR MODEL. C C COMPUTE W, THE DIFFERENCED SERIES MINUS ITS MEAN, AND STORE IN C RESTS(NPARDF+1) TO RESTS(N2) C DO 140 I = NPARDF+1, N2, 1 RESTS(I) = Y(I) - PMU DO 130 J = 1,NPARDF RESTS(I) = RESTS(I) - PARDF(J)*Y(I-J) 130 CONTINUE 140 CONTINUE WTEST = ABS(RESTS(NPARDF+1))*0.01 C C BACK FORECAST THE ERROR, E, FOR I = N-NPARAR TO NPARDF+1, AND C THE DIFFERENCED SERIES FOR I = NPARDF TO N1 C MBO1 = MBO+1 IFLAG = 0 DO 170 I = N2-NPARAR,NPARDF+1,-1 IMOD = MOD(I+1-N1,MBO1) + 1 T(IMOD) = RESTS(I) DO 150 J = 1,NPARAR T(IMOD) = T(IMOD) - PARAR(J)*RESTS(I+J) 150 CONTINUE DO 160 J = 1,NPARMA IF ((I+J.GT.NPARDF) .AND. (I+J.LE.N)) + T(IMOD) = T(IMOD) + PARMA(J)*T(MOD(I+J+1-N1,MBO1)+1) 160 CONTINUE 170 CONTINUE DO 175 I = NPARDF,N1,-1 IMOD = MOD(I+1-N1,MBO1) + 1 RESTS(I) = 0.0D0 DO 163 J = 1,NPARAR RESTS(I) = RESTS(I) + PARAR(J)*RESTS(I+J) 163 CONTINUE DO 166 J = 1,NPARMA IF ((I+J.GT.NPARDF) .AND. (I+J.LE.N)) + RESTS(I) = RESTS(I) - + PARMA(J)*T(MOD(I+J+1-N1,MBO1)+1) 166 CONTINUE ISTART = I IF ((ISTART.LE.1) .AND. (ABS(RESTS(I)).LE.WTEST)) GO TO 180 175 CONTINUE IFLAG = 1 C C COMPUTE RESIDUALS AND STORE VALUES IN RESTS C 180 CONTINUE DO 210 I = ISTART,N2,1 IMOD = MOD(I+1-N1,MBO1) + 1 T(IMOD) = RESTS(I) DO 190 J = 1,NPARAR IF (I-J.GE.ISTART) T(IMOD) = T(IMOD) - PARAR(J)*RESTS(I-J) 190 CONTINUE C IF (PARLE1) THEN C C COMPUTE RESIDUALS WHERE THERE IS NO CHANCE OF OVERFLOW C DO 200 J = 1,NPARMA IF (I-J.GE.ISTART) + T(IMOD) = T(IMOD) + PARMA(J)*T(MOD(I-J+1-N1,MBO1)+1) 200 CONTINUE ELSE C C COMPUTE RESIDUALS WHERE THERE IS A CHANCE OF OVERFLOW C DO 205 J = 1,NPARMA IF (I-J.GE.ISTART) THEN IMOD1 = MOD(I-J+1-N1,MBO1)+1 IF (PARMA(J).NE.0.0D0 .AND. T(IMOD1).NE.0.0D0) THEN IF (LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT. + LOG(FPLPM) + .AND. + (SIGN(1.0D0,T(IMOD)).NE. + SIGN(1.0D0,PARMA(J)*T(IMOD1)) + .OR. + LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT. + LOG(FPLPM-ABS(T(IMOD))))) THEN T(IMOD) = T(IMOD) + PARMA(J)*T(IMOD1) ELSE GO TO 300 END IF END IF END IF 205 CONTINUE END IF IF (I-MBO.GE.ISTART) THEN RESTS(I-MBO) = T(MOD(I-MBO+1-N1,MBO1)+1) END IF 210 CONTINUE DO 220 I = N-MBO+1,N RESTS(I) = T(MOD(I-MBO+2-N1,MBO1)+1) 220 CONTINUE C DO 230 I = N1, ISTART-1 RESTS(I) = 0.0D0 230 CONTINUE C RETURN C C SET RESIDUALS TO LARGEST POSSIBLE VALUE C 300 RESMAX = SQRT(FPLPM/(N2-N1+1)) DO 310 I=N1,N2 RESTS(I) = RESMAX 310 CONTINUE C RETURN C END *PPFT DOUBLE PRECISION FUNCTION PPFT(P, IDF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE C TPPF, WITH MODIFICATIONS TO FACILITATE CONVERSION TO C DOUBLE PRECISION AUTOMATICALLY USING THE NAG, INC. CODE APT, C AND TO CORRESPOND TO STARPAC CONVENTIONS. C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE STUDENT"S T DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM PARAMETER = IDF. C THE STUDENT"S T DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL X, C AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C ERROR CHECKING--NONE C RESTRICTIONS--IDF SHOULD BE A POSITIVE INTEGER VARIABLE. C --P SHOULD BE BETWEEN 0.0D0 (EXCLUSIVELY) C AND 1.0D0 (EXCLUSIVELY). C COMMENT--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 OTHER SMALL VALUES OF IDF (IDF BETWEEN 3 AND 6, C INCLUSIVELY), THE APPROXIMATION C OF THE T PERCENT POINT BY THE FORMULA C GIVEN IN THE REFERENCE BELOW IS AUGMENTED C BY 3 ITERATIONS OF NEWTON"S METHOD FOR C ROOT DETERMINATION. C THIS IMPROVES THE ACCURACY--ESPECIALLY FOR C VALUES OF 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 C DISTRIBUTIONS--2, 1970, PAGE 102, C FORMULA 11. C --FEDERIGHI, "EXTENDED TABLES OF THE C PERCENTAGE POINTS OF STUDENT"S T C DISTRIBUTION, JOURNAL OF THE C AMERICAN STATISTICAL ASSOCIATION, C 1969, PAGES 683-688. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 120-123. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C ORIGINAL VERSION--OCTOBER 1975. C UPDATED --NOVEMBER 1975. C C MODIFIED BY --JANET R. DONALDSON, DECEMBER 7, 1981 C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + P INTEGER + IDF C 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,PI,PPFN, + S,SQRT2,TERM1,TERM2,TERM3,TERM4,TERM5,Z INTEGER + IPASS,MAXIT C C EXTERNAL FUNCTIONS DOUBLE PRECISION + PPFNML EXTERNAL PPFNML C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC ATAN,COS,SIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ARG C * C DOUBLE PRECISION B21 C * C DOUBLE PRECISION B31, B32, B33, B34 C * C DOUBLE PRECISION B41, B42, B43, B44, B45 C * C DOUBLE PRECISION B51, B52, B53, B54, B55, B56 C * C DOUBLE PRECISION C, CON C * C DOUBLE PRECISION DF C THE DEGREES OF FREEDOM. C DOUBLE PRECISION D1, D3, D5, D7, D9 C * C INTEGER IDF C THE (INTEGER) DEGREES OF FREEDOM. C INTEGER IPASS C * C INTEGER MAXIT C * C DOUBLE PRECISION P C THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED. C DOUBLE PRECISION PI C THE VALUE OF PI. C DOUBLE PRECISION PPFN C THE NORMAL PERCENT POINT VALUE. C DOUBLE PRECISION S C * C DOUBLE PRECISION SQRT2 C THE SQUARE ROOT OF TWO. C * C DOUBLE PRECISION TERM1, TERM2, TERM3, TERM4, TERM5 C * C DOUBLE PRECISION Z C * C 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 DEFINE CONSTANTS USED IN THE APPROXIMATIONS C 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/ C CALL GETPI(PI) C SQRT2 = SQRT(2.0D0) C DF = IDF MAXIT = 5 C IF (IDF.GE.3) GO TO 50 IF (IDF.EQ.1) GO TO 30 IF (IDF.EQ.2) GO TO 40 PPFT = 0.0D0 RETURN C C TREAT THE IDF = 1 (CAUCHY) CASE C 30 ARG = PI*P PPFT = -COS(ARG)/SIN(ARG) RETURN C C TREAT THE IDF = 2 CASE C 40 TERM1 = SQRT2/2.0D0 TERM2 = 2.0D0*P - 1.0D0 TERM3 = SQRT(P*(1.0D0-P)) PPFT = TERM1*TERM2/TERM3 RETURN C C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE C 50 PPFN = PPFNML(P) D1 = PPFN D3 = PPFN**3 D5 = PPFN**5 D7 = PPFN**7 D9 = PPFN**9 TERM1 = D1 TERM2 = (1.0D0/B21)*(D3+D1)/DF TERM3 = (1.0D0/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) TERM4 = (1.0D0/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) TERM5 = (1.0D0/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) PPFT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 IF (IDF.GE.7) RETURN IF (IDF.EQ.3) GO TO 60 IF (IDF.EQ.4) GO TO 80 IF (IDF.EQ.5) GO TO 100 IF (IDF.EQ.6) GO TO 120 RETURN C C AUGMENT THE RESULTS FOR THE IDF = 3 CASE C 60 CON = PI*(P-0.5D0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 70 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - (Z+S*C-CON)/(2.0D0*C*C) 70 CONTINUE PPFT = SQRT(DF)*S/C RETURN C C AUGMENT THE RESULTS FOR THE IDF = 4 CASE C 80 CON = 2.0D0*(P-0.5D0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 90 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((1.0D0+0.5D0*C*C)*S-CON)/(1.5D0*C*C*C) 90 CONTINUE PPFT = SQRT(DF)*S/C RETURN C C AUGMENT THE RESULTS FOR THE IDF = 5 CASE C 100 CON = PI*(P-0.5D0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 110 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - (Z+(C+(2.0D0/3.0D0)*C*C*C)*S-CON)/((8.0D0/3.0D0)*C**4) 110 CONTINUE PPFT = SQRT(DF)*S/C RETURN C C AUGMENT THE RESULTS FOR THE IDF = 6 CASE C 120 CON = 2.0D0*(P-0.5D0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 130 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((1.0D0+0.5D0*C*C+0.375D0*C**4)*S-CON)/ + ((15.0D0/8.0D0)*C**5) 130 CONTINUE PPFT = SQRT(DF)*S/C RETURN C END *STKST INTEGER FUNCTION STKST (NFACT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE REPLACES INTEGER FUNCTION ISTKST IN THE FRAMEWORK C FOR USE WITH STARPAC. RETURNS ONE OF FOUR STATISTICS ON THE C STATE OF THE CSTAK STACK. C C IMPORTANT - THIS ROUTINE ASSUMES THAT THE STACK IS INITIALIZED. C IT DOES NOT CHECK TO SEE IF IT IS. IN FACT, THERE C IS NO WAY THAT IT COULD CHECK. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 14, 1983 C BASED ON FRAMEWORK ROUTINE ISTKST. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NFACT C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS C C LOCAL ARRAYS INTEGER + ISTAK(12),ISTATS(4) C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(1),ISTATS(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IPRT C THE NUMBER OF THE STANDARD OUTPUT UNIT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISTATS(4) C INTEGER ARRAY INCLUDING THE FOUR STACK STATISTICS. C INTEGER NFACT C 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 C COMMENCE BODY OF ROUTINE C IF (NFACT .GT. 0 .AND. NFACT .LT. 6) GO TO 10 C C REPORT ERROR STATUS C CCCCC CALL IPRINT (IPRT) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE (ICOUT, 1000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1001) I1MACH(2) CALL DPWRST('XXX','BUG ') STKST = 0 RETURN C C REPORT TRUE VALUE OF A STATISTIC, ASSUMING STACK IS C DEFINED. C 10 STKST = ISTATS(NFACT) RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' ***** ERROR *****') 1001 FORMAT (' ILLEGAL STACK STATISTIC', I5, ' REQUESTED.') END *AMEDRV SUBROUTINE AMEDRV(Y, N, MSPEC, NFAC, PAR, NPAR, + RES, LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, + SCALE, LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, + SDRES, LSDRES, VCV, IVCV, NMSUB, SAVE, NPARE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP, + MIT,N,NFAC,NPAR,NPARE,NPRT LOGICAL + SAVE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + Y(*) INTEGER + IFIXED(*),MSPEC(4,*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA, + NRESTS,PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + EXMPT INTEGER + IFP,IS,ISUBHD,IXM,LDSMIN,LWT,M,NALL0,NDIGIT,NETA,NNZW,STPT LOGICAL + APRXDV,HLFRPT,PAGE,PRTFXD,WEIGHT,WIDE C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12),WT(1) INTEGER + IPTOUT(5),ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + ICNTI,STKGET,STKST EXTERNAL ICNTI,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL AMECNT,AMEER,AMEHDR,AMESTP,BACKOP,CPYVII, + DCOEF,DRV,LDSCMP,MDLTS1,MDLTS3,NLDRVN,PRTCNT,DCOPY, + STKCLR,STKSET,STPAMO C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL AMEHDR C THE ROUTINE USED TO PRINT THE HEADING C LOGICAL APRXDV C THE VARIABLE USED TO INDICATE WHETHER NUMERICAL C APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C DOUBLE PRECISION EXMPT C THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED C NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXEMPTED C FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE C CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE C INITIAL SUMMARY (TRUE) OR NOT (FALSE). C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXED(LIFIXD) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IFLAG C ... C INTEGER IFP C AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE, C WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE. C INTEGER IPTOUT(5) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER IS C A VALUE USED TO DETERMINE THE AMOUNT OF WORK SPACE NEEDED C BASED ON WHETHER STEP SIZES ARE INPUT OR ARE TO BE CALCULATED. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IVAPRX C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE FOR C IVAPRX LE 0, VCV = THE DEFAULT OPTION C IVAPRX EQ 1, VCV = INVERSE(TRANSPOSE(J)*J) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 2, VCV = INVERSE(H) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 3, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 4, VCV = INVERSE(TRANSPOSE(J)*J) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 5, VCV = INVERSE(H) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 6, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H) C USING ONLY THE MODEL SUBROUTINE C IVAPRX GE 7, VCV = THE DEFAULT OPTION C WITH J REPRESENTING THE JACOBIAN AND H THE HESSIAN. C INTEGER IVCV C THE FIRST DIMENSION OF MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LIFIXD C THE DIMENSION OF VECTOR IFIXED. C INTEGER LPV C THE DIMENSION OF VECTOR PV. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSDPV C THE DIMENSION OF VECTOR SDPV. C INTEGER LSDRES C THE DIMENSION OF VECTOR SDRES. C INTEGER LSTP C THE DIMENSION OF VECTOR STP. C INTEGER LWT C THE DIMENSION OF VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C EXTERNAL MDLTS1 C THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL C PREDICTED VALUES. C EXTERNAL MDLTS3 C THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL C RESIDUALS. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C NUMBER OF STACK ALLOCATIONS OUTSTANDING. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C EXTERNAL NLDRVN C THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C LOGICAL PRTFXD C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE C OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE C PARAMETER IS FIXED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PV(LPV) C THE PREDICTED VALUE OF THE FIT. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION STOPP C THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED C RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR C DOUBLE PRECISION STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C DOUBLE PRECISION STP(LSTP) C THE STEP SIZE ARRAY. C EXTERNAL STPAMO C THE ROUTINE USED TO PRINT THE OUTPUT FROM THE STEP SIZE SELECTI C ROUTINES. C INTEGER STPT C THE STARTING LOCATION IN /CSTAK/ OF VECTOR STPT CONTAINING C THE STEP SIZE ARRAY. C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C DOUBLE PRECISION VCV(IVCV,NPAR) C THE VARIANCE-COVARIANCE MATRIX. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(1) C THE USER SUPPLIED WEIGHTS, UNUSED WHEN WEIGHT = FALSE. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR 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 WEIGHT = .FALSE. WT(1) = 1.0D0 LWT = 1 C HLFRPT = .FALSE. APRXDV = .TRUE. PRTFXD = .TRUE. EXMPT = -1.0D0 NETA = 0 C WIDE = .TRUE. PAGE = .FALSE. C NDIGIT = 5 C C COMPUTE BACK OPERATORS C CALL BACKOP(MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR) NNZW = N - NPARDF C C SET UP FOR ERROR CHECKING C IERR = 0 NPARE = NPAR IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) NPARE = + ICNTI(IFIXED,NPAR,0) IS = 0 IF (STP(1).LE.0.0D0) IS = 1 C CALL LDSCMP(25, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE) + 4*NFAC, + 0, 0, 0, 'D', 5*MBO + + MAX(IS*(10*N+6*MBO+606), + 94+4*(N+MBO+101)+NPARE*(3*NPARE+35)/2), + LDSMIN) C CALL AMEER(NMSUB, N, NPAR, NPARE, LDSTAK, + LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, MSPEC, NFAC) C IF (IERR.NE.0) RETURN C CALL STKSET(LDSTAK, 4) C C SET PRINT CONTROL VALUES C CALL PRTCNT(NPRT, NDIGIT, IPTOUT) C C SUBDIVIDE WORKSPACE FOR STEP SIZES C NALL0 = STKST(1) C IFP = 4 C STPT = STKGET(NPAR,IFP) C PARDF = STKGET(MBO, IFP) PARAR = STKGET(MBO, IFP) PARMA = STKGET(MBO, IFP) T = STKGET(2*MBO, IFP) C TEMP = T + MBO C NFACT = NFAC MSPECT = STKGET(4*NFAC, 2) C C SET UP FOR MODEL C APRXDV = .TRUE. M = 1 IXM = N NRESTS = MBO + 101 + N C CALL CPYVII(NFAC, MSPEC(1,1), 4, ISTAK(MSPECT), 1) CALL CPYVII(NFAC, MSPEC(2,1), 4, ISTAK(MSPECT+NFAC), 1) CALL CPYVII(NFAC, MSPEC(3,1), 4, ISTAK(MSPECT+2*NFAC), 1) CALL CPYVII(NFAC, MSPEC(4,1), 4, ISTAK(MSPECT+3*NFAC), 1) CALL DCOEF (NFAC, ISTAK(MSPECT+NFAC), ISTAK(MSPECT+3*NFAC), + NPARDF, RSTAK(PARDF), MBO, RSTAK(T)) C C COPY SUPPLIED STEP SIZES TO WORK SPACE C CALL DCOPY(LSTP, STP, 1, RSTAK(STPT), 1) C IF (IERR.NE.0) GO TO 10 C C SELECT STEP SIZES, IF DESIRED C ISUBHD = 1 IF (STP(1).LE.0.0D0) CALL AMESTP(Y, N, M, IXM, MDLTS3, PAR, NPAR, + RSTAK(STPT), EXMPT, NETA, SCALE, LSCALE, IPTOUT(1), AMEHDR, + PAGE, WIDE, ISUBHD, HLFRPT, PRTFXD, IFIXED, LIFIXD, STPAMO, + NRESTS-N) C ISUBRO='AMES' IBUGA3='OFF' IFOUND='NO' IERROR='OFF' CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) CALL AMECNT(Y, WT, LWT, Y, N, M, IXM, MDLTS1, NLDRVN, APRXDV, DRV, + PAR, NPAR, RES, IFIXED, LIFIXD, RSTAK(STPT), NPAR, MIT, + STOPSS, STOPP, SCALE, LSCALE, DELTA, IVAPRX, RSD, PV, LPV, + SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, + NPARE, AMEHDR, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT, NRESTS) C CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR) 10 CONTINUE C CALL STKCLR(NALL0) C RETURN C END *BACKOP SUBROUTINE BACKOP (MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR) C C LATEST REVISION - 03/15/90 (JRD) C C COMPUTE NUMBER OF BACK ORDER TERMS FOR ARIMA MODEL C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MBO,MBOL,NFAC,NPARAR,NPARDF,NPARMA C C ARRAY ARGUMENTS INTEGER + MSPEC(4,*) C C LOCAL SCALARS INTEGER + J C C INTRINSIC FUNCTIONS INTRINSIC MAX C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER J C AN INDEX VARIABLE. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C C COMPUTE DEGREE OF BACK OPERATOR RESULTING FROM THE NDF C DIFFERENCING FACTORS (= ND DOT IOD). C 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 NPARAR = 0 NPARDF = 0 NPARMA = 0 IF (NFAC .EQ. 0) GO TO 20 DO 10 J = 1, NFAC NPARAR = NPARAR + MSPEC(1,J)*MSPEC(4,J) NPARDF = NPARDF + MSPEC(2,J)*MSPEC(4,J) NPARMA = NPARMA + MSPEC(3,J)*MSPEC(4,J) 10 CONTINUE C 20 CONTINUE C MBOL = NPARDF + NPARAR MBO = MAX(MBOL,NPARMA) C RETURN C END *ERSII SUBROUTINE ERSII(NMSUB, NMVAR, VAL, VALMN, VALMX, MSGTYP, HEAD, + ERROR, NMMIN, NMMAX) C C LATEST REVISION - 03/15/90 (JRD) C C THE ROUTINE CHECKS WHETHER THE VALUE VAL IS WITHIN THE C THE RANGE VALMN (INCLUSIVE) TO VALMX (INCLUSIVE), AND PRINTS A C DIAGNOSTIC IF IT IS NOT. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JUNE 10, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + VAL,VALMN,VALMX INTEGER + MSGTYP LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE C PRINTED, WHERE IF ERROR IS .TRUE. AND C MSGTYP = 1 THE INPUT VALUE WAS OUTSIDE THE RANGE DETERMINED C FROM OTHER INPUT ARGUMENTS C MSGTYP = 2 THE INPUT VALUE WAS OUTSIDE THE RANGE IMPOSED BY C STARPAC C CHARACTER*1 NMMAX(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MAXIMUM. C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE ARGUMENTS NAME. C DOUBLE PRECISION VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C DOUBLE PRECISION VALMN, VALMX C THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE C ARGUMENT MUST LIE. 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 ERROR = .FALSE. C IF (((VALMN.LE.VAL) .AND. (VAL.LE.VALMX)) .OR. + (VALMX.LT.VALMN)) RETURN C ERROR = .TRUE. CALL EHDR(NMSUB, HEAD) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), VAL CALL DPWRST('XXX','BUG ') C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) CALL DPWRST('XXX','BUG ') ENDIF C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX CALL DPWRST('XXX','BUG ') ENDIF RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', G15.8, '.') 1010 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE BETWEEN', 1X, 8A1, + ' AND ', 8A1, ', INCLUSIVE.') 1020 FORMAT( + ' THE VALUE OF THE ARGUMENT ', 6A1, + ' MUST BE BETWEEN', 1X, G15.8, + ' AND ', G15.8, ', INCLUSIVE.') C END *ITSMRY SUBROUTINE ITSMRY(D, IV, P, V, X) C C LATEST REVISION - 03/15/90 (JRD) C C *** PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),V(*),X(P) INTEGER + IV(*) C C LOCAL SCALARS DOUBLE PRECISION + NRELDF,OLDF,PRELDF,RELDF,ZERO INTEGER + COV1,COVMAT,COVPRT,COVREQ,DSTNRM,F,F0,FDIF,G,G1,I,I1,ICH, + II,IV1,J,M,NEEDHD,NF,NFCALL,NFCOV,NG,NGCALL,NGCOV,NITER, + NREDUC,OL,OUTLEV,PREDUC,PRNTIT,PRUNIT,PU,RELDX,SIZE, + SOLPRT,STATPR,STPPAR,SUSED,X0PRT C C LOCAL ARRAYS CHARACTER + MODEL1(3,6)*1,MODEL2(4,6)*1 C C INTRINSIC FUNCTIONS INTRINSIC ABS C C *** PARAMETER DECLARATIONS *** C C INTEGER IV(1), P C DOUBLE PRECISION D(P), V(1), X(P) C DIMENSION IV(*), V(*) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C C INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU C CHARACTER*1 MODEL1(3, 6), MODEL2(4, 6) C DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO C C/ C *** NO EXTERNAL FUNCTIONS OR SUBROUTINES *** C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G, C 1 NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC, C 2 OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT, C 3 STATPR, STPPAR, SUSED, X0PRT C C *** IV SUBSCRIPT VALUES *** C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 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 COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/, + NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/, + NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/, + PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/, + X0PRT/24/ C C *** V SUBSCRIPT VALUES *** C DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/, + PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/ C DATA MODEL1(1, 1), MODEL1(2, 1), MODEL1(3, 1) + / ' ', ' ', ' ' / DATA MODEL1(1, 2), MODEL1(2, 2), MODEL1(3, 2) + / ' ', ' ', ' ' / DATA MODEL1(1, 3), MODEL1(2, 3), MODEL1(3, 3) + / ' ', ' ', ' ' / DATA MODEL1(1, 4), MODEL1(2, 4), MODEL1(3, 4) + / ' ', ' ', ' ' / DATA MODEL1(1, 5), MODEL1(2, 5), MODEL1(3, 5) + / ' ', 'G', ' ' / DATA MODEL1(1, 6), MODEL1(2, 6), MODEL1(3, 6) + / ' ', 'S', ' ' / DATA MODEL2(1, 1), MODEL2(2, 1), MODEL2(3, 1), MODEL2(4, 1) + / ' ', 'G', ' ', ' ' / DATA MODEL2(1, 2), MODEL2(2, 2), MODEL2(3, 2), MODEL2(4, 2) + / ' ', 'S', ' ', ' ' / DATA MODEL2(1, 3), MODEL2(2, 3), MODEL2(3, 3), MODEL2(4, 3) + / 'G', '-', 'S', ' ' / DATA MODEL2(1, 4), MODEL2(2, 4), MODEL2(3, 4), MODEL2(4, 4) + / 'S', '-', 'G', ' ' / DATA MODEL2(1, 5), MODEL2(2, 5), MODEL2(3, 5), MODEL2(4, 5) + / '-', 'S', '-', 'G' / DATA MODEL2(1, 6), MODEL2(2, 6), MODEL2(3, 6), MODEL2(4, 6) + / '-', 'G', '-', 'S' / DATA ZERO/0.0D0/ C C----------------------------------------------------------------------- C CCCCC PU = IV(PRUNIT) CCCCC IF (PU .EQ. 0) GO TO 999 PU=6 IV1 = IV(1) OL = IV(OUTLEV) IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140 IF (OL .EQ. 0) GO TO 20 IF (IV1 .GE. 12) GO TO 20 IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20 IF (IV1 .GT. 2) GO TO 10 IV(PRNTIT) = IV(PRNTIT) + 1 IF (IV(PRNTIT) .LT. ABS(OL)) GO TO 999 10 NF = IV(NFCALL) - ABS(IV(NFCOV)) IV(PRNTIT) = 0 RELDF = ZERO PRELDF = ZERO OLDF = V(F0) IF (OLDF .LE. ZERO) GO TO 12 RELDF = V(FDIF) / OLDF PRELDF = V(PREDUC) / OLDF 12 IF (OL .GT. 0) GO TO 15 C C *** PRINT SHORT SUMMARY LINE *** C IF (IV(NEEDHD) .EQ. 1) THEN WRITE(IOUNI3, 1010) 1010 FORMAT(12H IT NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IV(NEEDHD) = 0 WRITE(IOUNI3,1017)IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX) CCCCC CALL DPWRST('XXX','BUG ') GO TO 20 C C *** PRINT LONG SUMMARY LINE *** C 15 IF (IV(NEEDHD) .EQ. 1) THEN WRITE(IOUNI3,1015) 1015 FORMAT(12H IT NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX, + 4X,15HMODEL STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IV(NEEDHD) = 0 M = IV(SUSED) NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF WRITE(IOUNI3,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX), + (MODEL1(ICH, M), ICH = 1, 3), + (MODEL2(ICH, M), ICH = 1, 4), + V(STPPAR), V(SIZE), V(DSTNRM), NRELDF 1017 FORMAT(1X,I5,I6,4D11.3,7A1,4D11.3) CCCCC CALL DPWRST('XXX','BUG ') C 20 GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1 C 30 WRITE(IOUNI3,1030) 1030 FORMAT(26H ***** X-CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 35 WRITE(IOUNI3,1035) 1035 FORMAT(42H ***** RELATIVE FUNCTION CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 40 WRITE(IOUNI3,1040) 1040 FORMAT(49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 45 WRITE(IOUNI3,1045) 1045 FORMAT(42H ***** ABSOLUTE FUNCTION CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 50 WRITE(IOUNI3,1050) 1050 FORMAT(33H ***** SINGULAR CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 60 WRITE(IOUNI3,1060) 1060 FORMAT(30H ***** FALSE CONVERGENCE *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 70 WRITE(IOUNI3,1070) 1070 FORMAT(38H ***** FUNCTION EVALUATION LIMIT *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 80 WRITE(IOUNI3,1080) 1080 FORMAT(28H ***** ITERATION LIMIT *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 90 WRITE(IOUNI3,1090) 1090 FORMAT(18H ***** STOPX *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 180 C 110 WRITE(IOUNI3,1100) 1100 FORMAT(45H ***** INITIAL SUM OF SQUARES OVERFLOWS *****) CCCCC CALL DPWRST('XXX','BUG ') C GO TO 150 C 120 WRITE(IOUNI3,1120) 1120 FORMAT(37H ***** BAD PARAMETERS TO ASSESS *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 999 C 130 WRITE(IOUNI3,1130) 1130 FORMAT(36H ***** J COULD NOT BE COMPUTED *****) CCCCC CALL DPWRST('XXX','BUG ') IF (IV(NITER) .GT. 0) GO TO 190 GO TO 150 C 140 WRITE(IOUNI3,1140) IV1 1140 FORMAT(14H ***** IV(1) =,I5,6H *****) CCCCC CALL DPWRST('XXX','BUG ') GO TO 999 C C *** INITIAL CALL ON ITSMRY *** C 150 IF (IV(X0PRT) .NE. 0) THEN WRITE(IOUNI3,1150) 1150 FORMAT(23H I INITIAL X(I),7X,4HD(I)) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,1151) (I, X(I), D(I), I = 1, P) 1151 FORMAT(1X,I5,D17.6,D14.3) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IV1 .GE. 13) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0) THEN WRITE(IOUNI3,1010) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (OL .GT. 0) THEN WRITE(IOUNI3,1015) CCCCC CALL DPWRST('XXX','BUG ') ENDIF WRITE(IOUNI3,1160) V(F) 1160 FORMAT(12H 0 1,D11.3,11X,D11.3) CCCCC CALL DPWRST('XXX','BUG ') GO TO 999 C C *** PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION *** C 180 IV(NEEDHD) = 1 IF (IV(STATPR) .EQ. 0) GO TO 190 OLDF = V(F0) PRELDF = ZERO NRELDF = ZERO IF (OLDF .LE. ZERO) GO TO 185 PRELDF = V(PREDUC) / OLDF NRELDF = V(NREDUC) / OLDF 185 NF = IV(NFCALL) - IV(NFCOV) NG = IV(NGCALL) - IV(NGCOV) WRITE(IOUNI3,1180) V(F), V(RELDX) 1180 FORMAT(9H FUNCTION,D17.6,8H RELDX,D20.6) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 1181 FORMAT(12H FUNC. EVALS, + I8,9X,'GRAD. EVALS',I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,1182) PRELDF, NRELDF 1182 FORMAT( + ' PRELDF',D19.6,3X,'NPRELDF',D18.6) CCCCC CALL DPWRST('XXX','BUG ') C IF (IV(NFCOV) .GT. 0) THEN WRITE(IOUNI3,1185) IV(NFCOV) 1185 FORMAT(' ',I4,' EXTRA FUNC. EVALS FOR COVARIANCE.') CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IV(NGCOV) .GT. 0) THEN WRITE(IOUNI3,1186) IV(NGCOV) 1186 FORMAT(1X,I4,' EXTRA GRAD. EVALS FOR COVARIANCE.') CCCCC CALL DPWRST('XXX','BUG ') ENDIF C 190 IF (IV(SOLPRT) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 G1 = IV(G) WRITE(IOUNI3,1190) 1190 FORMAT(' I FINAL X(I)',8X,'D(I)',10X,'G(I)'/) CCCCC CALL DPWRST('XXX','BUG ') DO 200 I = 1, P WRITE(IOUNI3,1200) I, X(I), D(I), V(G1) CCCCC CALL DPWRST('XXX','BUG ') G1 = G1 + 1 200 CONTINUE 1200 FORMAT(1X,I5,D17.6,2D14.3) C 210 IF (IV(COVPRT) .EQ. 0) GO TO 999 COV1 = IV(COVMAT) IV(NEEDHD) = 1 IF (COV1) 220, 230, 240 220 IF (-1 .EQ. COV1) THEN WRITE(IOUNI3,1220) 1220 FORMAT(43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (-2 .EQ. COV1) THEN WRITE(IOUNI3,1225) 1225 FORMAT(52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) CCCCC CALL DPWRST('XXX','BUG ') ENDIF GO TO 999 C 230 WRITE(IOUNI3,1230) 1230 FORMAT(45H +++++ COVARIANCE MATRIX NOT COMPUTED ++++++) CCCCC CALL DPWRST('XXX','BUG ') GO TO 999 C 240 I = ABS(IV(COVREQ)) IF (I .LE. 1) THEN WRITE(IOUNI3,1241) 1241 FORMAT(48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (I .EQ. 2) THEN WRITE(IOUNI3,1242) 1242 FORMAT(27H COVARIANCE = SCALE * H**-1/) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (I .GE. 3) THEN WRITE(IOUNI3,1243) 1243 FORMAT(36H COVARIANCE = SCALE * (J**T * J)**-1/) CCCCC CALL DPWRST('XXX','BUG ') ENDIF II = COV1 - 1 IF (OL .LE. 0) GO TO 260 DO 250 I = 1, P I1 = II + 1 II = II + I WRITE(IOUNI3,1250) I, (V(J), J = I1, II) CCCCC CALL DPWRST('XXX','BUG ') 250 CONTINUE 1250 FORMAT(4H ROW,I3,2X,9D12.4/(9X,9D12.4)) GO TO 999 C 260 DO 270 I = 1, P I1 = II + 1 II = II + I WRITE(IOUNI3,1270) I, (V(J), J = I1, II) CCCCC CALL DPWRST('XXX','BUG ') 270 CONTINUE 1270 FORMAT(4H ROW,I3,2X,5D12.4/(9X,5D12.4)) C 999 RETURN C *** LAST CARD OF ITSMRY FOLLOWS *** END *MDLTS3 SUBROUTINE MDLTS3 (PAR, NPAR, XM, N, M, IXM, RESTS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR ESTIMATING BOX-JENKINS C ARIMA MODELS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,M,N,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),RESTS(NRESTS),XM(IXM,M) C C SCALARS IN COMMON INTEGER + IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS, + PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + PMU C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL SUBROUTINES EXTERNAL MDLTS2 C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IFLAG C AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS C WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1). C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C DOUBLE PRECISION RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. C C 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 COMPUTE RESIDUALS C CALL MDLTS2 (PAR, RESTS, XM(1,1), NPAR, N, NFACT, ISTAK(MSPECT), + PMU, RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR), + RSTAK(PARMA), MBO, N-NRESTS+1, N, IFLAG) C RETURN END *PRTCNT SUBROUTINE PRTCNT(NPRT, NDIGIT, IPTOUT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS UP THE PRINT CONTROL PARAMETERS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 29, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NDIGIT,NPRT C C ARRAY ARGUMENTS INTEGER + IPTOUT(NDIGIT) C C LOCAL SCALARS INTEGER + I,IFAC1,IFAC2 C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I, IFAC1, IFAC2 C INTEGER IPTOUT(NDIGIT) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C C 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 IF (NPRT.LE.-1) GO TO 20 C IFAC1 = 10 ** (NDIGIT) DO 10 I = 1, NDIGIT IFAC2 = IFAC1/10 IPTOUT(I) = MOD(NPRT, IFAC1) / IFAC2 IFAC1 = IFAC2 10 CONTINUE RETURN C 20 DO 30 I = 1, NDIGIT IPTOUT(I) = 1 30 CONTINUE IPTOUT (NDIGIT) = 2 C RETURN C END *STOPX LOGICAL FUNCTION STOPX(IDUMMY) C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IDUMMY C C *****PURPOSE... C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A C DYNAMIC STOPX. C C *****ALGORITHM NOTES... C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. 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 STOPX = .FALSE. RETURN END *AMEER SUBROUTINE AMEER(NMSUB, N, NPAR, NPARE, LDSTAK, LDSMIN, + STP, LSTP, SCALE, LSCALE, IVCV, SAVE, MSPEC, NFAC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR NONLINEAR LEAST SQUARES C ESTIMATION ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVCV,LDSMIN,LDSTAK,LSCALE,LSTP,N,NFAC,NPAR,NPARE LOGICAL + SAVE C C ARRAY ARGUMENTS DOUBLE PRECISION + SCALE(*),STP(*) INTEGER + MSPEC(4,*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NP,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(20) CHARACTER + LIVCV(8)*1,LLDS(8)*1,LMSPEC(8)*1,LN(8)*1,LNFAC(8)*1, + LNPAR(8)*1,LNPARE(8)*1,LONE(8)*1,LSCL(8)*1,LSTEP(8)*1, + LZERO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EIAGE,EISEQ,EISGE,ERVGT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(20) C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE C PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE) C OR NOT (FALSE). C INTEGER I C AN INDEX VARIABLE. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IVCV C THE FIRST DIMENSION OF MATRIX VCV. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C CHARACTER*1 LIVCV(8), LLDS(8), LMSPEC(8), LN(8), LNFAC(8), C * LNPAR(8), LNPARE(8), LONE(8), LSCL(8), LSTEP(8), LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSTP C THE DIMENSION OF VECTOR STP. C INTEGER MSPEC(4,*) C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NP C THE NUMBER OF PARAMETERS SPECIFIED BY MSPEC. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NV C * C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION STP(LSTP) C THE STEP SIZE ARRAY. 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 SET UP NAME ARRAYS C DATA LIVCV(1), LIVCV(2), LIVCV(3), LIVCV(4), LIVCV(5), + LIVCV(6), LIVCV(7), LIVCV(8) /'I','V','C','V',' ',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LMSPEC(1), LMSPEC(2), LMSPEC(3), LMSPEC(4), LMSPEC(5), + LMSPEC(6), LMSPEC(7), LMSPEC(8) + /'M','S','P','C',' ',' ',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNFAC(1), LNFAC(2), LNFAC(3), LNFAC(4), LNFAC(5), + LNFAC(6), LNFAC(7), LNFAC(8) /'N','F','A','C',' ',' ',' ',' '/ DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5), + LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ', + ' '/ DATA LNPARE(1), LNPARE(2), LNPARE(3), LNPARE(4), LNPARE(5), + LNPARE(6), LNPARE(7), LNPARE(8) /'N','P','A','R','E',' ',' ', + ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), + LONE(6), LONE(7), LONE(8) /'1',' ',' ',' ',' ',' ',' ',' '/ DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5), + LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ', + ' '/ DATA LSTEP(1), LSTEP(2), LSTEP(3), LSTEP(4), LSTEP(5), + LSTEP(6), LSTEP(7), LSTEP(8) /'S','T','P',' ',' ',' ',' ',' '/ DATA LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5), + LZERO(6), LZERO(7), LZERO(8) /'Z','E','R','O',' ',' ',' ',' '/ C C ERROR CHECKING C DO 10 I=1,20 ERROR(I) = .FALSE. 10 CONTINUE C IERR = 0 HEAD = .TRUE. C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERROR(1), LONE) C CALL EISGE(NMSUB, LNFAC, NFAC, 1, 2, HEAD, ERROR(2), LONE) C IF (.NOT. ERROR(2)) + CALL EIAGE(NMSUB, LMSPEC, MSPEC, 4, NFAC, 4, 0, 0, HEAD, 1, NV, + ERROR(3), LMSPEC) C IF ((.NOT. ERROR(2)) .AND. (.NOT. ERROR(3))) THEN NP = 1 DO 20 I = 1, NFAC NP = NP + MSPEC(1,I) + MSPEC(3,I) 20 CONTINUE CALL EISEQ(NMSUB, LNPAR, NPAR, NP, 1, HEAD, ERROR(4), LNPAR) C IF (.NOT.ERROR(4)) THEN CALL EISGE(NMSUB, LNPARE, NPARE, 1, 2, HEAD, ERROR(5), LONE) CALL ERVGT(NMSUB, LSTEP, STP, LSTP, 0.0D0, 0, HEAD, 6, NV, + ERROR(8), LZERO) CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0D0, 0, HEAD, 6, NV, + ERROR(12), LZERO) IF (SAVE .AND. (.NOT.ERROR(5))) + CALL EISGE(NMSUB, LIVCV, IVCV, NPARE, 3, HEAD, ERROR(15), + LNPARE) END IF END IF C IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(2)) .AND. (.NOT.ERROR(3)) + .AND. (.NOT.ERROR(4)) .AND. (.NOT.ERROR(5))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6), + LLDS) C DO 30 I=1,20 IF (ERROR(I)) GO TO 40 30 CONTINUE RETURN C 40 CONTINUE IERR = 1 RETURN C END *CMPFD SUBROUTINE CMPFD(N,STP,PVSTP,PV,FD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES A FINITE DIFFERENCE DERIVATIVE, C ASSUMING THAT IF THE DIFFERENCE BETWEEN PVSTP(I) AND PV(I) IS C SMALL ENOUGH THE DERIVATIVE IS ZERO. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JUNE 30, 1987 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + STP INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + FD(*),PV(*),PVSTP(*) C C LOCAL SCALARS DOUBLE PRECISION + FPLRS INTEGER + I C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C DOUBLE PRECISION FD(N) C THE FINITE-DIFFERENCE DERIVATIVE. C DOUBLE PRECISION FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE. C DOUBLE PRECISION PVSTP(N) C THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE PLUS STP. C DOUBLE PRECISION STP C THE STEP. C 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 FPLRS = D1MACH(4) C DO 10 I=1,N FD(I) = PVSTP(I) - PV(I) IF (ABS(FD(I)).GE.5*FPLRS*MIN(ABS(PVSTP(I)),ABS(PV(I)))) THEN FD(I) = FD(I) / STP ELSE FD(I) = 0.0D0 END IF 10 CONTINUE RETURN END *ERSLFS SUBROUTINE ERSLFS(NMSUB, FC, K, HEAD, ERROR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS ERROR CHECKING FOR THE INPUT C VALUES USED TO SPECIFY SYMMETRIC LINEAR FILTERING OF A C TIME SERIES C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + FC INTEGER + K LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS DOUBLE PRECISION + TEMP C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION FC C THE USER SUPPLIED CUTOFF FREQUENCY. C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER K C THE NUMBER OF TERMS IN THE FILTER. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THE CALLING SUBROUTINE. C DOUBLE PRECISION TEMP C A TEMPORARY VARIABLE USED FOR TYPE CONVERSION. 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 ERROR = .FALSE. TEMP = K C IF (FC - 1.0D0/TEMP .GE. 0.0D0) GO TO 10 C CALL EHDR(NMSUB, HEAD) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE (ICOUT, 1010) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1011) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1012) FC, K CALL DPWRST('XXX','BUG ') ERROR = .TRUE. RETURN C 10 CONTINUE C IF (FC + 1.0D0/K .LT. 0.5D0) RETURN C CALL EHDR(NMSUB, HEAD) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1020) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1021) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1022) FC, K CALL DPWRST('XXX','BUG ') ERROR = .TRUE. RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1010 FORMAT ( + ' THE CUTOFF FREQUENCY, FC, MINUS ONE', + ' OVER THE NUMBER OF FILTER TERMS, K, THAT') 1011 FORMAT ( + ' IS, FC - 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO.', + ' THE INPUT VALUES OF FC AND K') 1012 FORMAT ( + ' ARE', F8.5, ' AND', I5, ', RESPECTIVELY.') 1020 FORMAT ( + ' THE CUTOFF FREQUENCY, FC, PLUS ONE', + ' OVER THE NUMBER OF FILTER TERMS, K, THAT IS') 1021 FORMAT ( + ' FC + 1/K, MUST BE LESS THAN 0.5.', + ' THE INPUT VALUES OF FC AND K') 1022 FORMAT ( + ' ARE', F7.5, ' AND', I5, ', RESPECTIVELY.') C END *LDSCMP SUBROUTINE LDSCMP (NARR, NLOG, NINT, NREAL, NDBL, NCMP, + FLAG, NFP, LDSMIN) C C LATEST REVISION - 03/15/90 (JRD) C C COMPUTES LDSMIN, THE MINIMUM NUMBER OF DOUBLE PRECISION LOCATIONS C NEEDED BY THE FRAMEWORK TO STORE NARR ARRAYS, COMPRISING NLOG C LOGICAL LOCATIONS, NINT INTEGER LOCATIONS, NREAL REAL LOCATIONS, C NDBL DOUBLE PRECISION LOCATIONS, AND NCMP COMPLEX LOCATIONS, C TOGETHER WITH THE NOVER OVERHEAD INTEGER LOCATIONS THAT THE C FRAMEWORK ALWAYS USES AND THE 3 OVERHEAD LOCATIONS THAT IT USES C PER ARRAY STORED. (ALL THE LOCATIONS ARE ASSIGNED OUT OF THE C LABELED COMMON CSTAK, USING A STACK DISCIPLINE.) C C IT IS ASSUMED, BASED UPON THE FORTRAN STANDARD (ANSI X3.9 1966), C THAT DOUBLE PRECISION AND COMPLEX DATA ELEMENTS ARE TWICE AS LONG C AS INTEGER AND LOGICAL ELEMENTS. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSMIN,NARR,NCMP,NDBL,NFP,NINT,NLOG,NREAL CHARACTER + FLAG*1 C C LOCAL SCALARS INTEGER + NOVER C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 FLAG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE NFP C ELEMENTS ARE REAL OR DOUBLE PRECISION, WHERE FLAG=S INDICATES C THE NFP ELEMENTS ARE REAL (SINGLE PRECISION), AND FLAG=D C INDICATES THE ELEMENTS ARE DOUBLE PRECISION. C INTEGER LDSMIN C OUTPUT PARAMETER. THE MINIMUM NUMBER OF DOUBLE PRECISION C LOCATIONS IN CSTAK REQUIRED FOR THE QUANTITIES OF ARRAY C ELEMENTS AND ARRAYS SPECIFIED BY THE INPUT PARAMETERS. C INTEGER NARR C INPUT PARAMETER. THE NUMBER OF ARRAYS TO BE STORED IN CSTAK. C INTEGER NCMP C INPUT PARAMETER. THE NUMBER OF COMPLEX ELEMENTS IN THE C ARRAYS TO BE STORED IN CSTAK. C INTEGER NDBL C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION ELEMENTS IN C THE ARRAYS TO BE STORED, IN CSTAK. C INTEGER NFP C THE NUMBER OF ELEMENTS WHICH DEPEND ON THE PRECISION OF THE C VERSION OF STARPAC BEING USED. C INTEGER NINT C INPUT PARAMETER. THE NUMBER OF INTEGER ELEMENTS IN THE C ARRAYS TO BE STORED IN CSTAK. C INTEGER NLOG C INPUT PARAMETER. THE NUMBER OF LOGICAL ELEMENTS IN THE C ARRAYS TO BE STORED IN CSTAK. C INTEGER NOVER C THE NUMBER OF INTEGER LOCATIONS THAT THE FRAMEWORK ALWAYS C USES FOR OVERHEAD PURPOSES. C INTEGER NREAL C INPUT PARAMETER. THE NUMBER OF REAL ELEMENTS IN THE ARRAYS C TO BE STORED IN CSTAK. C 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 DEFINE CONSTANTS C DATA NOVER /10/ C C COMMENCE BODY OF ROUTINE C LDSMIN = (NLOG + NINT + NREAL + 3*NARR + NOVER + 1)/2 + + NDBL + NCMP IF (FLAG.EQ.'S') THEN LDSMIN = LDSMIN + (NFP+1)/2 ELSE LDSMIN = LDSMIN + NFP END IF RETURN END *MODSUM SUBROUTINE MODSUM(NFAC, MSPECT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE MODEL SUMMARY FOR THE ARIMA ROUTINES C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 4, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NFAC C C ARRAY ARGUMENTS INTEGER + MSPECT(NFAC,4) C C LOCAL SCALARS CCCCC INTEGER CCCCC+ I,J C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER I C AN INDEX VARIABLE. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER J C AN INDEX VARIABLE. C INTEGER MSPECT(NFAC,4) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT 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 C CCCCC CALL IPRINT(IPRT) C C PRINT MODEL SPECIFICATION C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1002) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1003) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') DO1005I=1,NFAC WRITE(ICOUT, 1004)I,(MSPECT(I,J),J=1,4) CALL DPWRST('XXX','BUG ') 1005 CONTINUE C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1002 FORMAT( + ' MODEL SPECIFICATION') 1003 FORMAT( + ' FACTOR (P D Q) S') 1004 FORMAT( + (7X, I6, 6X, 4I6)) END *QAPPLY SUBROUTINE QAPPLY(NN, N, P, J, R, IERR) C C LATEST REVISION - 03/15/90 (JRD) C C VARIABLE DECLARATIONS C C C SCALAR ARGUMENTS INTEGER + IERR,N,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + J(NN,P),R(N) C C LOCAL SCALARS DOUBLE PRECISION + T INTEGER + I,K,L,NL1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD EXTERNAL DOTPRD C C INTRINSIC FUNCTIONS INTRINSIC ABS C C *****PARAMETERS. C INTEGER NN, N, P, IERR C DOUBLE PRECISION J(NN,P), R(N) C C ================================================================= C C *****PURPOSE. C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS C STORED IN J BY QRFACT C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN C THE CALLING PROGRAM DIMENSION STATEMENT C C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R C C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA C C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C IDENT - U*U.TRANSPOSE C C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL C TRANSFORMATIONS WILL BE APPLIED C C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED C C ON OUTPUT. C C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE C C *****APPLICATION AND USAGE RESTRICTIONS. C NONE C C *****ALGORITHM NOTES. C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1). C C *****SUBROUTINES AND FUNCTIONS CALLED. C C DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS C C *****REFERENCES. C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7, C PP. 269-276. C C *****HISTORY. C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977) C C *****GENERAL. C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C ================================================================= C C *****LOCAL VARIABLES. C INTEGER I, K, L, NL1 C DOUBLE PRECISION T C/ C *****FUNCTIONS. C EXTERNAL DOTPRD C DOUBLE PRECISION DOTPRD 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 K = P IF (IERR .NE. 0) K = ABS(IERR) - 1 IF ( K .EQ. 0) GO TO 999 C DO 20 L = 1, K NL1 = N - L + 1 T = -DOTPRD(NL1, J(L,L), R(L)) C DO 10 I = L, N R(I) = R(I) + T*J(I,L) 10 CONTINUE 20 CONTINUE 999 RETURN C ==== LAST CARD OF QAPPLY ========================================= END *STPADJ SUBROUTINE STPADJ(XM, N, M, IXM, MDL, PAR, NPAR, + NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW, STPMID, + STPUP, ITEMP, FD, FDLAST, PV, PVNEW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE ADJUSTS THE SELECTED STEP SIZES TO OPTIMAL C VALUES. C C WRITTEN BY - ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON) C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ABSTOL,RELTOL,STP,STPLOW,STPMID,STPUP INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + FD(N),FDLAST(N),PAR(NPAR),PV(N),PVNEW(N),XM(IXM,M) INTEGER + IFAIL(N),ITEMP(N) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON DOUBLE PRECISION + Q C C LOCAL SCALARS DOUBLE PRECISION + FACTOR,STPNEW,TEMP INTEGER + NCOUNT LOGICAL + DONE,FIRST C C EXTERNAL SUBROUTINES EXTERNAL CMPFD,ICOPY,RELCOM,DCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,SIGN C C COMMON BLOCKS COMMON /NOTOPT/Q C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ABSTOL C THE ABSOLUTE AGREEMENT TOLERANCE. C LOGICAL DONE C THE VARIABLE USED TO INDICATE WHETHER THE ADJUSTMENT C PROCESS IS COMPLETE OR NOT. C DOUBLE PRECISION FACTOR C A FACTOR USED IN COMPUTING THE STEP SIZE. C DOUBLE PRECISION FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C DOUBLE PRECISION FDLAST(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED. C LOGICAL FIRST C THE VARIABLE USED TO INDICATE WHETHER THIS STEP SIZE C IS BEING USED FOR THE FIRST TIME OR WHETHER IT HAS BEEN C PREVIOUSLY ADJUSTED. C INTEGER IFAIL(N) C AN INDICATOR VECTOR USED TO DESIGNATE THOSE OBSERVATIONS C FOR WHICH THE STEP SIZE DOES NOT MEET THE CRITERIA. C INTEGER ITEMP(N) C A TEMPORARY VECTOR USED FOR STORING PAST VALUES OF ITEMP. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NCOUNT C THE NUMBER OF OBSERVATIONS AT WHICH THE NEW STEP SIZE DOES C SATISFY THE CRITERIA. C INTEGER NEXMPT C THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE C DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP C SIZE STILL BE CONSIDERED OK. C INTEGER NFAIL C A VECTOR CONTAINING FOR EACH OBSERVATION THE NUMBER OF C OBSERVATIONS FOR WHICH THE STEP SIZE DID NOT MEET THE CRITERIA. C DOUBLE PRECISION PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C DOUBLE PRECISION PVNEW(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD. C DOUBLE PRECISION Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C DOUBLE PRECISION RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C DOUBLE PRECISION STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C DOUBLE PRECISION STPNEW C THE VALUE OF THE NEW STEP SIZE BEING TESTED. C DOUBLE PRECISION STPUP C THE UPPER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C DOUBLE PRECISION XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C 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 CALL ICOPY(N, IFAIL, 1, ITEMP, 1) NCOUNT = NFAIL C IF ((STPLOW.LE.ABS(STP)) .AND. (ABS(STP).LE.STPUP)) RETURN C IF (ABS(STP).GT.STPMID) THEN C STPNEW = STPUP * SIGN(1.0D0, PAR(J)) FACTOR = 10.0D0 ELSE C STPNEW = STPLOW * SIGN(1.0D0, PAR(J)) FACTOR = 0.1D0 C END IF C Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) C DONE = .FALSE. FIRST = .TRUE. C C REPEAT STATEMENTS 60 TO 130 UNTIL (DONE) C 60 CONTINUE C CALL DCOPY(N, FD, 1, FDLAST, 1) C TEMP = PAR(J) PAR(J) = TEMP + STPNEW CALL MDL(PAR, NPAR, XM, N, M, IXM, PVNEW) PAR(J) = TEMP C CALL CMPFD(N, STPNEW, PVNEW, PV, FD) C CALL RELCOM(N, FD, FDLAST, RELTOL, ABSTOL, NCOUNT, ITEMP) C IF (NCOUNT.LE.NEXMPT) THEN DONE = .TRUE. CALL ICOPY(N, ITEMP, 1, IFAIL, 1) NFAIL = NCOUNT C IF (FIRST) THEN STP = STPNEW ELSE STP = STPNEW / FACTOR END IF C ELSE C FIRST = .FALSE. STPNEW = STPNEW * FACTOR Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) C IF ((FACTOR.GT.1.0D0 .AND. ABS(STPNEW).GT.ABS(STP)) + .OR. + (FACTOR.LT.1.0D0 .AND. ABS(STPNEW).LT.ABS(STP))) + DONE = .TRUE. END IF C IF (DONE) THEN RETURN ELSE GO TO 60 END IF C END *AMEFIN SUBROUTINE AMEFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, + PAR, NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RSSHLF, RSD, + PVT, SDPVT, SDREST, RD, VCVL, LVCVL, D, AMEHDR, IVCVPT, ISKULL, + NRESTS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPLETES THE ANALYSIS FOR THE NONLINEAR C LEAST SQUARES ESTIMATION ROUTINES ONCE THE ESTIMATES C HAVE BEEN FOUND. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + RSD,RSSHLF INTEGER + IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS LOGICAL + PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + D(N,*),PAR(*),PVT(*),RD(*),RES(*),SDPVT(*),SDREST(*),VCVL(*), + WT(*),XM(IXM,*),Y(*) INTEGER + IFIXD(*),IPTOUT(*),ISKULL(10) C C SUBROUTINE ARGUMENTS EXTERNAL AMEHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + COND,RSS,YSS INTEGER + I,IDF LOGICAL + EXACT,PRTFSM C C EXTERNAL SUBROUTINES EXTERNAL AMEOUT,NLCMP C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION COND C THE CONDITION NUMBER OF D. C DOUBLE PRECISION D(N,NPAR) C THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN). C LOGICAL EXACT C AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT C WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE). C EXTERNAL AMEHDR C THE ROUTINE USED TO PRINT THE HEADING C INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IPTOUT(NDIGIT) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C INTEGER IVCVPT C AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE C VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE C IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER LVCVL C THE DIMENSION OF VECTOR VCVL. C INTEGER LWT C THE DIMENSION OF VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C LOGICAL PRTFSM C THE VARIABLE USED TO INDICATE WHETHER ANY OF THE SUMMARY C INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION RD(N) C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RSSHLF C HALF THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDREST(N) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C DOUBLE PRECISION YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. C 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 MODIFY VCV TO REFLECT PROPER DEGREES OF FREEDOM C DO 10 I=1,LVCVL VCVL(I) = (NRESTS-NPAR)*VCVL(I)/(N-NPAR) 10 CONTINUE C C COMPUTE RETURNED AND/OR PRINTED VALUES. C CALL NLCMP (Y, WEIGHT, WT, LWT, N, NPAR, NPARE, RES, + D, RD, COND, VCVL, LVCVL, NNZW, IDF, RSSHLF, RSS, RSD, YSS, + EXACT, PVT, SDPVT, SDREST, ISKULL) C PRTFSM = ((IPTOUT(3).NE.0) .OR. (IPTOUT(4).NE.0) .OR. + (IPTOUT(5).NE.0) .OR. (IERR.NE.0)) C C PRINT SUMMARY INFORMATION IF DESIRED OR IF AN ERROR FLAG C HAS BEEN SET. C IF (PRTFSM) CALL AMEOUT(Y, N, + IFIXD, PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, + RSS, RSD, YSS, EXACT, PVT, SDPVT, SDREST, VCVL, LVCVL, IVCVPT, + ISKULL, AMEHDR, WIDE) RETURN C END *COVCLC SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X) C C LATEST REVISION - 03/15/90 (JRD) C C *** COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2) *** C C *** LET K = ABS(IV(COVREQ). FOR K .LE. 2, A FINITE-DIFFERENCE C *** HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF C *** IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF C *** IV(COVREQ) IS NEGATIVE). FOR SCALE = 2*F(X) / MAX(1, N-P), C *** WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES... C *** K = 0 OR 1... SCALE * H**-1 * (J**T * J) * H**-1. C *** K = 2... SCALE * H**-1. C *** K .GE. 3... SCALE * (J**T * J)**-1. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + COVIRC,N,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),J(NN,P),R(N),V(1),X(P) INTEGER + IV(1) C C LOCAL SCALARS DOUBLE PRECISION + DEL,HALF,NEGPT5,ONE,T,TWO,WK,ZERO INTEGER + COV,COVMAT,COVREQ,DELTA,DELTA0,DLTFDC,F,FX,G,G1,GP,GSAVE1, + H,HC,HMI,HPI,HPM,I,IERR,IP1,IPIV0,IPIVI,IPIVK,IPIVOT,IRC, + K,KAGQT,KALM,KIND,KL,L,LMAT,M,MM1,MM1O2,MODE,NFGCAL,PP1O2, + QTR,QTR1,RD,RD1,RSAVE,SAVEI,STP0,STPI,STPM,SWITCH,TOOBIG, + W,W0,W1,WL,XMSAVE LOGICAL + HAVEJ C C EXTERNAL SUBROUTINES EXTERNAL LINVRT,LITVMU,LIVMUL,LSQRTZ,LTSQAR,QRFACT,VCOPY,VSCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C *** PARAMETER DECLARATIONS *** C C INTEGER COVIRC, IV(1), N, NN, P C DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C C LOGICAL HAVEJ C INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK, C 1 IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1, C 2 RD1, STPI, STPM, STP0, WL, W0, W1 C DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO C C/ C *** EXTERNAL SUBROUTINES *** C C EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRTZ, LTSQAR, QRFACT, C 1 VCOPY, VSCOPY C C LINVRT... INVERT LOWER TRIANGULAR MATRIX. C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRTZ.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX. C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L. C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX. C VCOPY.... COPY ONE VECTOR TO ANOTHER. C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR. C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR, C 1 IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR, C 2 RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE 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 HALF/0.5D0/, NEGPT5/-0.5D0/, ONE/1.0D0/, TWO/2.0D0/, + ZERO/0.0D0/ C DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/, + DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/, + IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/, + LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/, + RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/, + TOOBIG/2/, W/59/, XMSAVE/49/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C COV = IV(LMAT) C COVIRC = 4 KIND = IV(COVREQ) M = IV(MODE) IF (M .GT. 0) GO TO 10 IV(KAGQT) = -1 IF (IV(KALM) .GT. 0) IV(KALM) = 0 IF (ABS(KIND) .GE. 3) GO TO 300 V(FX) = V(F) K = IV(RSAVE) CALL VCOPY(N, V(K), R) 10 IF (M .GT. P) GO TO 200 IF (KIND .LT. 0) GO TO 100 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND C *** GRADIENT VALUES. C GSAVE1 = IV(W) + P G1 = IV(G) IF (M .GT. 0) GO TO 15 C *** FIRST CALL ON COVCLC. SET GSAVE = G, TAKE FIRST STEP *** CALL VCOPY(P, V(GSAVE1), V(G1)) IV(SWITCH) = IV(NFGCAL) GO TO 80 C 15 DEL = V(DELTA) X(M) = V(XMSAVE) IF (IV(TOOBIG) .EQ. 0) GO TO 30 C C *** HANDLE OVERSIZE V(DELTA) *** C IF (DEL*X(M) .GT. ZERO) GO TO 20 C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT *** IV(COVMAT) = -2 GO TO 190 C C *** TRY SHRINKING V(DELTA) *** 20 DEL = NEGPT5 * DEL GO TO 90 C 30 COV = IV(LMAT) GP = G1 + P - 1 C C *** SET G = (G - GSAVE)/DEL *** C DO 40 I = G1, GP V(I) = (V(I) - V(GSAVE1)) / DEL GSAVE1 = GSAVE1 + 1 40 CONTINUE C C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX *** C K = COV + M*(M-1)/2 L = K + M - 2 IF ( M .EQ. 1) GO TO 60 C C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 *** C DO 50 I = K, L V(I) = HALF * (V(I) + V(G1)) G1 = G1 + 1 50 CONTINUE C C *** ADD H(I,M) = G(I) FOR I = M TO P *** C 60 L = L + 1 DO 70 I = M, P V(L) = V(G1) L = L + I G1 = G1 + 1 70 CONTINUE C 80 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE *** C DEL = V(DELTA0) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) 90 X(M) = X(M) + DEL V(DELTA) = DEL COVIRC = 2 GO TO 999 C C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY. C 100 STP0 = IV(W) + P - 1 MM1 = M - 1 MM1O2 = M*MM1/2 IF (M .GT. 0) GO TO 105 C *** FIRST CALL ON COVCLC. *** IV(SAVEI) = 0 GO TO 180 C 105 I = IV(SAVEI) IF (I .GT. 0) GO TO 160 IF (IV(TOOBIG) .EQ. 0) GO TO 120 C C *** HANDLE OVERSIZE STEP *** C STPM = STP0 + M DEL = V(STPM) IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110 C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT *** IV(COVMAT) = -2 GO TO 999 C C *** TRY SHRINKING THE STEP *** 110 DEL = NEGPT5 * DEL X(M) = X(XMSAVE) + DEL V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) *** C 120 PP1O2 = P * (P-1) / 2 COV = IV(LMAT) HPM = COV + PP1O2 + MM1 V(HPM) = V(F) C C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. *** C HMI = COV + MM1O2 IF (MM1 .EQ. 0) GO TO 140 HPI = COV + PP1O2 DO 130 I = 1, MM1 V(HMI) = V(FX) - (V(F) + V(HPI)) HMI = HMI + 1 HPI = HPI + 1 130 CONTINUE 140 V(HMI) = V(F) - TWO*V(FX) C C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. *** C I = 1 C 150 IV(SAVEI) = I STPI = STP0 + I V(DELTA) = X(I) X(I) = X(I) + V(STPI) IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI) COVIRC = 1 GO TO 999 C 160 X(I) = V(DELTA) IF (IV(TOOBIG) .EQ. 0) GO TO 170 C *** PUNT IN THE EVENT OF AN OVERSIZE STEP *** IV(COVMAT) = -2 GO TO 999 C C *** FINISH COMPUTING H(M,I) *** C 170 STPI = STP0 + I HMI = COV + MM1O2 + I - 1 STPM = STP0 + M V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM)) I = I + 1 IF (I .LE. M) GO TO 150 IV(SAVEI) = 0 X(M) = V(XMSAVE) C 180 M = M + 1 IV(MODE) = M IF (M .GT. P) GO TO 190 C C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H. C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR. C DEL = V(DLTFDC) * MAX(ONE/D(M), ABS(X(M))) IF (X(M) .LT. ZERO) DEL = -DEL V(XMSAVE) = X(M) X(M) = X(M) + DEL STPM = STP0 + M V(STPM) = DEL COVIRC = 1 GO TO 999 C C *** RESTORE R, V(F), ETC. *** C 190 K = IV(RSAVE) CALL VCOPY(N, R, V(K)) V(F) = V(FX) IF (KIND .LT. 0) GO TO 200 IV(NFGCAL) = IV(SWITCH) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) IF (IV(COVMAT) .LT. 0) GO TO 999 COVIRC = 3 GO TO 999 C 200 COV = IV(LMAT) C C *** THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV). *** C *** USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX. *** C C *** COMPUTE CHOLESKY FACTOR C OF H = C*(C**T) *** C *** AND STORE IT AT V(HC). *** C HC = COV IF (ABS(KIND) .EQ. 2) GO TO 210 HC = ABS(IV(H)) IV(H) = -HC 210 CALL LSQRTZ(1, P, V(HC), V(COV), IRC) IV(COVMAT) = -1 IF (IRC .NE. 0) GO TO 999 C W1 = IV(W) + P IF (ABS(KIND) .GT. 1) GO TO 350 C C *** COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1 *** C CALL VSCOPY(P*(P+1)/2, V(COV), ZERO) HAVEJ = IV(KALM) .EQ. (-1) C *** HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE C *** HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J. C M = P IF (HAVEJ) M = N W0 = W1 - 1 RD1 = IV(RD) DO 290 I = 1, M IF (HAVEJ) GO TO 240 C C *** SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT). *** C CALL VSCOPY(P, V(W1), ZERO) IPIVI = IPIV0 + I L = W0 + IV(IPIVI) V(L) = V(RD1) RD1 = RD1 + 1 IF (I .EQ. P) GO TO 260 IP1 = I + 1 DO 230 K = IP1, P IPIVK = IPIV0 + K L = W0 + IV(IPIVK) V(L) = J(I,K) 230 CONTINUE GO TO 260 C C *** SET W = (ROW I OF J). *** C 240 L = W0 DO 250 K = 1, P L = L + 1 V(L) = J(I,K) 250 CONTINUE C C *** SET W = H**-1 * W. *** C 260 CALL LIVMUL(P, V(W1), V(HC), V(W1)) CALL LITVMU(P, V(W1), V(HC), V(W1)) C C *** ADD W * W**T TO COVARIANCE MATRIX. *** C KL = COV DO 280 K = 1, P L = W0 + K WK = V(L) DO 270 L = 1, K WL = W0 + L V(KL) = V(KL) + WK * V(WL) KL = KL + 1 270 CONTINUE 280 CONTINUE 290 CONTINUE GO TO 380 C C *** COVARIANCE = SCALE * (J**T * J)**-1. *** C 300 RD1 = IV(RD) IF (IV(KALM) .NE. (-1)) GO TO 310 C C *** APPLY QRFACT TO J *** C QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) W1 = IV(W) + P CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0, + V(W1)) IV(KALM) = -2 310 IV(COVMAT) = -1 IF (IV(IERR) .NE. 0) GO TO 999 COV = IV(LMAT) HC = ABS(IV(H)) IV(H) = -HC C C *** SET HC = (R MATRIX FROM QRFACT). *** C L = HC DO 340 I = 1, P IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I)) L = L + I - 1 V(L) = V(RD1) L = L + 1 RD1 = RD1 + 1 340 CONTINUE C C *** THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX C *** (OR PERMUTATION THEREOF) IS STORED AT V(HC). C C *** SET C = C**-1. C 350 CALL LINVRT(P, V(HC), V(HC)) C C *** SET C = C**T * C. C CALL LTSQAR(P, V(HC), V(HC)) C IF (HC .EQ. COV) GO TO 380 C C *** C = PERMUTED, UNSCALED COVARIANCE. C *** SET COV = IPIVOT * C * IPIVOT**T. C DO 370 I = 1, P M = IPIV0 + I IPIVI = IV(M) KL = COV-1 + IPIVI*(IPIVI-1)/2 DO 360 K = 1, I M = IPIV0 + K IPIVK = IV(M) L = KL + IPIVK IF (IPIVK .GT. IPIVI) + L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2 V(L) = V(HC) HC = HC + 1 360 CONTINUE 370 CONTINUE C 380 IV(COVMAT) = COV C C *** APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P). C T = V(F) / (HALF * MAX(1,N-P)) K = COV - 1 + P*(P+1)/2 DO 390 I = COV, K 390 V(I) = T * V(I) C 999 RETURN C *** LAST CARD OF COVCLC FOLLOWS *** END *ERVGT SUBROUTINE ERVGT (NMSUB, NMVAR, VEC, N, VECLB, NVMX, + HEAD, MSGTYP, NV, ERROR, NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS TO ENSURE THAT NO VALUES, OR ONLY A MAXIMUM C OF NVMX, ARE NOT GREATER THAN A SPECIFIED LOWER BOUND VECLB, C WITH NAME NMMIN. THE ROUTINE ALTERNATIVELY CHECKS TO MAKE SURE C THAT NO VALUES ARE IN VIOLATION OF THIS LOWER BOUND IF THE FIRST C VALUE IN THE VECTOR IS NOT. THE CHECKING OPTION IS SPECIFIED C WITH MSGTYP. IF AN ERROR IS FOUND, THE ERROR IS PRINTED AND C AN ERROR FLAG AND THE NUMBER OF VIOLATINS ARE RETURNED. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + VECLB INTEGER + MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS DOUBLE PRECISION + VEC(*) CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,NVMN C C EXTERNAL SUBROUTINES EXTERNAL ERVGTP C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C THE VALUE RETURNED FROM THE ERROR CHECKING ROUTINES TO INDICATE C WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED (TRUE) C OR NOT (FALSE). C INTEGER I C AN INDEX ARGUMENT. C INTEGER MSGTYP C THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE. C IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN C OTHERWISE IT WILL USE VECLB. C IF (MSGTYP = 1 OR 4) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 2 OR 5) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C IF (MSGTYP = 3 OR 6) VIOLATIONS ARE COUNTED ONLY IF THE C THE FIRST ELEMENT IS NOT IN VIOLATION. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE ARGUMENTS NAME. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMN C THE SMALLEST NUMBER OF NON-VIOLATIONS ALLOWED. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C DOUBLE PRECISION VEC(N) C THE VECTOR BEING TESTED. C DOUBLE PRECISION VECLB C THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST. C 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 ERROR = .FALSE. C IF (N .LE. 0) RETURN C C TEST WHETHER TESTING IS NECESSRY C IF ((MOD(MSGTYP,3) .EQ. 0) .AND. (VEC(1) .LE. VECLB)) RETURN C C CHECK FOR VIOLATIONS C NV = 0 DO 5 I = 1, N IF ((VEC(I).LE.VECLB)) NV = NV + 1 5 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. NVMN = N - NVMX CALL ERVGTP (NMSUB, NMVAR, VECLB, NVMN, NVMX, HEAD, MSGTYP, NV, + NMMIN) C RETURN C END *LINVRT SUBROUTINE LINVRT(N, LIN, L) C C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED *** C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + L(*),LIN(*) C C LOCAL SCALARS DOUBLE PRECISION + ONE,T,ZERO INTEGER + I,II,IM1,J0,J1,JJ,K,K0,NP1 C C *** PARAMETERS *** C C INTEGER N C DOUBLE PRECISION L(*), LIN(*) C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2) C C *** LOCAL VARIABLES *** C C INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1 C DOUBLE PRECISION ONE, T, 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 ONE/1.0D0/, ZERO/0.0D0/ C C *** BODY *** C NP1 = N + 1 J0 = N*(NP1)/2 DO 30 II = 1, N I = NP1 - II LIN(J0) = ONE/L(J0) IF (I .LE. 1) GO TO 999 J1 = J0 IM1 = I - 1 DO 20 JJ = 1, IM1 T = ZERO J0 = J1 K0 = J1 - JJ DO 10 K = 1, JJ T = T - L(K0)*LIN(J0) J0 = J0 - 1 K0 = K0 + K - I 10 CONTINUE LIN(J0) = T/L(K0) 20 CONTINUE J0 = J0 - 1 30 CONTINUE 999 RETURN C *** LAST CARD OF LINVRT FOLLOWS *** END *MULTBP SUBROUTINE MULTBP(T, LT, C, LC, TEMP, LTEMP, MBO) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE MULTIPLIES TOGETHER TWO DIFFERENCE FACTORS FROM A C (BOX-JENKINS) TIME SERIES MODEL. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - AUGUST 1, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LC,LT,LTEMP,MBO C C ARRAY ARGUMENTS DOUBLE PRECISION + C(MBO),T(2*MBO),TEMP(MBO) C C LOCAL SCALARS INTEGER + I,J,JI,K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION C(MBO) C THE SECOND FACTOR ON INPUT AND THE EXPANDED FACTOR ON OUTPUT. C INTEGER I C AN INDEX VARIABLE. C INTEGER J C AN INDEX VARIABLE. C INTEGER JI C AN INDEX VARIABLE C INTEGER K C AN INDEX VARIABLE. C INTEGER LC C THE LARGEST ORDER OF THE SECOND FACTOR ON INPUT, AND C THE LARGEST ORDER OF THE EXPANDED FACTOR ON OUTPUT. C INTEGER LT C THE LARGEST ORDER OF THE FIRST FACTOR. C INTEGER LTEMP C THE LENGTH OF THE VECTOR TEMP. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C DOUBLE PRECISION T(2*MBO) C A TEMPORARY WORK VECTOR. C DOUBLE PRECISION TEMP(MBO) C A TEMPORARY WORK VECTOR C 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 IF (LC .EQ. 0) GO TO 15 DO 10 J = 1, LC TEMP(J) = C(J) 10 CONTINUE 15 K = LC + 1 DO 20 J=K,LTEMP TEMP(J) = 0.0D0 20 CONTINUE IF (LT .EQ. 0) GO TO 50 DO 40 J=1,LT TEMP(J) = TEMP(J) + T(J) IF (LC .EQ. 0) GO TO 40 DO 30 I=1,LC JI = J + I TEMP(JI) = TEMP(JI) - C(I)*T(J) 30 CONTINUE 40 CONTINUE C 50 DO 60 J=1,LTEMP C(J) = TEMP(J) 60 CONTINUE LC = LTEMP RETURN END *QRFACT SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM) C C LATEST REVISION - 03/15/90 (JRD) C C *** COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IERR,M,N,NM,NOPIVK C C ARRAY ARGUMENTS DOUBLE PRECISION + ALPHA(N),QR(NM,N),SUM(N) INTEGER + IPIVOT(N) C C LOCAL SCALARS DOUBLE PRECISION + ALPHAK,BETA,ONE,P01,P99,QRKK,QRKMAX,RKTOL,RKTOL1,SIGMA,SUMJ, + TEMP,UFETA,ZERO INTEGER + I,J,JBAR,K,K1,MINUM,MK1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD,RMDCON,V2NORM EXTERNAL DOTPRD,RMDCON,V2NORM C C EXTERNAL SUBROUTINES EXTERNAL VAXPY,VSCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN,SQRT C C *****PARAMETERS. C INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK C DOUBLE PRECISION QR(NM,N),ALPHA(N),SUM(N) C *****LOCAL VARIABLES. C INTEGER I,J,JBAR,K,K1,MINUM,MK1 C DOUBLE PRECISION ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL, C 1 RKTOL1,SUMJ C *****FUNCTIONS. C/+ C INTEGER MIN C DOUBLE PRECISION ABS,SQRT C/ C EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM C DOUBLE PRECISION DOTPRD, RMDCON, V2NORM C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *****CONSTANTS. C DOUBLE PRECISION ONE, P01, P99, 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/1.0D0/, P01/0.01D0/, P99/0.99D0/, ZERO/0.0D0/ C C C ================================================================== C C C *****PURPOSE. C C THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR, C WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE C UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS C USED IN THE TRANSFORMATIONS. C C *****PARAMETER DESCRIPTION. C ON INPUT. C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX. C C N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX. C C QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED. C C NOPIVK IS USED TO CONTROL PIVOTTING. COLUMNS 1 THROUGH C NOPIVK WILL REMAIN FIXED IN POSITION. C C SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE. C C ON OUTPUT. C C QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX C IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH C DEFINE THE HOUSEHOLDER TRANSFORMATIONS I - U*U-TRANSP, C ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U C ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0. C C ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX. C C IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT C MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH C ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL C MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE C DECOMPOSITION. C C IERR IS SET TO. C 0 FOR NORMAL RETURN, C K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH C TRANSFORMATION, OR C -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION. C IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1) C TRANSFORMATIONS ARE CORRECT. C C C *****APPLICATIONS AND USAGE RESTRICTIONS. C THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS -- C SEE SUBROUTINE QR1 OF ROSEPACK. IT IS CALLED FOR THIS PURPOSE C BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE. C C *****ALGORITHM NOTES. C THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF C UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS. RKTOL1 C IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO C EFFECT ON THE COMPUTED TWO-NORMS. C C ADAPTED FROM THE ALGOL ROUTINE SOLVE (1). C C *****REFERENCES. C (1) BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES C SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H. C AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION, C VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971). C PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965). C C *****HISTORY. C THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED C IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND C SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND C VAXPY IN PLACE OF SOME LOOPS. C C *****GENERAL. C C DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY C NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND C NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802 C TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC. C C C C ================================================================= C ================================================================= C C C ========== UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER C S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED. C C ========== RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION C OF FLOATING POINT ARITHMETIC (MACHEP). DATA RKTOL/0.0D0/, UFETA/0.0D0/ C *****BODY OF PROGRAM. IF (UFETA .GT. ZERO) GO TO 10 UFETA = RMDCON(1) RKTOL = RMDCON(4) 10 IERR = 0 RKTOL1 = P01 * RKTOL C DO 20 J=1,N SUM(J) = V2NORM(M, QR(1,J)) IPIVOT(J) = J 20 CONTINUE C MINUM = MIN(M,N) C DO 120 K=1,MINUM MK1 = M - K + 1 C ==========K-TH HOUSEHOLDER TRANSFORMATION========== SIGMA = ZERO JBAR = 0 C ==========FIND LARGEST COLUMN SUM========== IF (K .LE. NOPIVK) GO TO 50 DO 30 J=K,N IF (SIGMA .GE. SUM(J)) GO TO 30 SIGMA = SUM(J) JBAR = J 30 CONTINUE C IF (JBAR .EQ. 0) GO TO 220 IF (JBAR .EQ. K) GO TO 50 C ==========COLUMN INTERCHANGE========== I = IPIVOT(K) IPIVOT(K) = IPIVOT(JBAR) IPIVOT(JBAR) = I SUM(JBAR) = SUM(K) SUM(K) = SIGMA C DO 40 I=1,M SIGMA = QR(I,K) QR(I,K) = QR(I,JBAR) QR(I,JBAR) = SIGMA 40 CONTINUE C ==========END OF COLUMN INTERCHANGE========== 50 CONTINUE C ========== SECOND INNER PRODUCT ========== QRKMAX = ZERO C DO 60 I=K,M IF (ABS( QR(I,K) ) .GT. QRKMAX) QRKMAX = ABS( QR(I,K) ) 60 CONTINUE C IF (QRKMAX .LT. UFETA) GO TO 210 ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX SIGMA = ALPHAK**2 C C ========== END SECOND INNER PRODUCT ========== QRKK = QR(K,K) IF (QRKK .GE. ZERO) ALPHAK = -ALPHAK ALPHA(K) = ALPHAK * QRKMAX BETA = QRKMAX * SQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) ) QR(K,K) = QRKK - ALPHA(K) DO 65 I=K,M 65 QR(I,K) = QR(I,K) / BETA K1 = K + 1 IF (K1 .GT. N) GO TO 120 C DO 110 J = K1, N TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J)) C C *** SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M. C CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J)) C IF (K1 .GT. M) GO TO 110 SUMJ = SUM(J) IF (SUMJ .LT. UFETA) GO TO 110 TEMP = ABS(QR(K,J)/SUMJ) IF (TEMP .LT. RKTOL1) GO TO 110 IF (TEMP .GE. P99) GO TO 90 SUM(J) = SUMJ * SQRT(ONE - TEMP**2) GO TO 110 90 SUM(J) = V2NORM(M-K, QR(K1,J)) 110 CONTINUE C ==========END OF K-TH HOUSEHOLDER TRANSFORMATION========== 120 CONTINUE C GO TO 999 C ==========ERROR EXIT ON K-TH TRANSFORMATION========== 210 IERR = -K GO TO 230 C ==========NO NON-ZERO ACCEPTABLE PIVOT FOUND========== 220 IERR = K 230 DO 240 I = K, N ALPHA(I) = ZERO IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO) 240 CONTINUE C ==========RETURN TO CALLER========== 999 RETURN C ==========LAST CARD OF QRFACT========== END *STPAMO SUBROUTINE STPAMO(HEAD, N, EXM, NEXMPT, NETA, J, PAR, NPAR, STP, + NFAIL, IFAIL, SCALE, LSCALE, HDR, PAGE, WIDE, ISUBHD, NPRT, + PRTFXD, IFIXD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS A DUMMY ROUTINE FOR THE ARIMA ESTIMATION ROUTINES C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + EXM INTEGER + ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT LOGICAL + HEAD,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),SCALE(LSCALE),STP(NPAR) INTEGER + IFAIL(N),IFIXD(NPAR),NFAIL(NPAR) C C SUBROUTINE ARGUMENTS EXTERNAL HDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION EXM C THE PROPORTION OF OBSERVATIONS ACTUALLY USED FOR WHICH THE C COMPUTED NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE C EXEMPTED FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. C EXTERNAL HDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER IFAIL(N) C THE ARRAY OF INDICATOR VARIABLES DESIGNATING WHETHER C THE STEP SIZE SELECTED WAS SATISFACTORY FOR A GIVEN C OBSERVATION AND PARAMETER. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. IF C IFIXD(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED. IF C IFIXD(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C INTEGER ISUBHD C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER LSCALE C THE LENGTH OF VECTOR SCALE. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NEXMPT C THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE C DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP C SIZE STILL BE CONSIDERED OK. C INTEGER NFAIL(NPAR) C THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP C SIZE DOES NOT MEET THE CRITERIA. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE PROVIDED, WHERE IF THE VALUE OF C NPRT IS ZERO, NO PRINTED OUTPUT IS GIVEN. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT C IS TO BEGIN ON A NEW PAGE. C DOUBLE PRECISION PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C LOGICAL PRTFXD C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE C OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE C PARAMETER IS FIXED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION STP(NPAR) C THE SELECTED STEP SIZE. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C 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 RETURN C END *AMEHDR SUBROUTINE AMEHDR(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE NONLINEAR C LEAST SQUARES ESTIMATION ROUTINES FOR ARIMA MODELS THAT USE C NUMERICAL APPROXIMATIONS TO THE DERIVATIVES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - AUGUST 1, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS CCCCC INTEGER CCCCC+ IPRT C C EXTERNAL SUBROUTINES EXTERNAL VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C 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 CCCCC CALL IPRINT(IPRT) WRITE(ICOUT,1020) CALL DPWRST('XXX','BUG ') C IF (PAGE) THEN CCCCC WRITE (ICOUT, 1020) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE (ICOUT, 1020) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE (ICOUT, 1020) CCCCC CALL DPWRST('XXX','BUG ') ENDIF CALL VERSP(WIDE) CCCCC NAH. DON'T INCLUDE PAGE HEADING IN DATAPLOT OUTPUT. IF (PAGE) THEN CCCCC WRITE (ICOUT,1000) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE (ICOUT,1001) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (.NOT.PAGE) THEN WRITE (ICOUT,1010) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1012) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1010) CALL DPWRST('XXX','BUG ') ENDIF PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 CONTINUE WRITE (ICOUT, 1020) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1030) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1031) CALL DPWRST('XXX','BUG ') C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT ('NONLINEAR LEAST SQUARES ESTIMATION', + ' FOR THE PARAMETERS OF') 1001 FORMAT ( + ' AN ARIMA MODEL USING BACKFORECASTS') 1010 FORMAT (61('#')) 1011 FORMAT ( + '# NONLINEAR LEAST SQUARES ESTIMATION', + ' FOR THE PARAMETERS OF #') 1012 FORMAT ( + '# AN ARIMA MODEL USING BACKFORECASTS', + ' #') C1020 FORMAT ('1') 1020 FORMAT (1X) 1030 FORMAT (' SUMMARY OF INITIAL CONDITIONS') 1031 FORMAT (1X, 30('-')) END *CPYASF SUBROUTINE CPYASF (M, X, LX, Y, IY) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COPIES THE ELEMENTS OF SYMMETRIC MATRIX X, C STORED ROW WISE, TO MATRIX Y. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IY,LX,M C C ARRAY ARGUMENTS DOUBLE PRECISION + X(*),Y(IY,*) C C LOCAL SCALARS INTEGER + I,IJ,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VALUE. C INTEGER IY C THE FIRST DIMENSION OF THE MATRIX Y. C INTEGER J C AN INDEX VALUE. C INTEGER LX C THE LENGTH OF SYMMETRIC MATRIX X, STORED ROW WISE. C INTEGER M C THE NUMBER OF COLUMNS OF DATA TO BE COPIED FROM MATRIX X. C DOUBLE PRECISION X(LX) C THE MATRIX TO BE COPIED FROM. C DOUBLE PRECISION Y(IY,M) C THE MATRIX TO BE COPIED TO. C 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 DO 20 I = 1, M DO 10 J = 1, I IJ = I*(I-1)/2 + J Y(I,J) = X(IJ) Y(J,I) = Y(I,J) 10 CONTINUE 20 CONTINUE C RETURN C END *ERVGTP SUBROUTINE ERVGTP (NMSUB, NMVAR, VECLB, NVMN, NVMX, HEAD, MSGTYP, + NV, NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE ERROR MESSAGES FOR ERVGT AND ERVGTM. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + VECLB INTEGER + MSGTYP,NV,NVMN,NVMX LOGICAL + HEAD C C ARRAY ARGUMENTS CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL EHDR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED (TRUE) C OR NOT (FALSE). C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE. C IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN C OTHERWISE IT WILL USE VECLB. C IF (MSGTYP = 1 OR 4) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 2 OR 5) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C IF (MSGTYP = 3 OR 6) VIOLATIONS ARE COUNTED ONLY IF THE C THE FIRST ELEMENT IS NOT IN VIOLATION. C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE ARGUMENTS NAME. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C DOUBLE PRECISION VECLB C THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST. C 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 CCCCC CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C IF (MSGTYP.LE.3) THEN WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), VECLB, NV CALL DPWRST('XXX','BUG ') ELSE IF (MSGTYP.GE.7) THEN WRITE (ICOUT, 1001) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV CALL DPWRST('XXX','BUG ') ELSE WRITE (ICOUT, 1002) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV CALL DPWRST('XXX','BUG ') END IF END IF C GO TO (10, 20, 30, 40, 50, 60, 70), MSGTYP C 10 WRITE(ICOUT, 1010) (NMVAR(I),I=1,6), VECLB CALL DPWRST('XXX','BUG ') RETURN C 20 WRITE(ICOUT, 1020) (NMVAR(I),I=1,3), VECLB CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1021) NVMX CALL DPWRST('XXX','BUG ') RETURN C 30 WRITE(ICOUT, 1030) (NMVAR(I),I=1,6), VECLB CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1031) VECLB CALL DPWRST('XXX','BUG ') RETURN C 40 WRITE(ICOUT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') RETURN C 50 WRITE(ICOUT, 1050) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1051) NVMX CALL DPWRST('XXX','BUG ') RETURN C 60 WRITE(ICOUT, 1060) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1061) (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') RETURN C 70 WRITE(ICOUT, 1070) NVMN, (NMVAR(I),I=1,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1071) (NMMIN(I),I=1,8) CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT ( + ' THE NUMBER OF VALUES IN VECTOR ', 6A1, + ' LESS THAN OR EQUAL TO ', 1PE14.7, ' IS ', I6, '.') 1001 FORMAT ( + ' THE NUMBER OF VALUES IN VECTOR ', 6A1, + ' GREATER THAN ', 8A1, ' IS ', I2, '.') 1002 FORMAT ( + ' THE NUMBER OF VALUES IN VECTOR ', 6A1, + ' LESS THAN OR EQUAL TO ', 8A1, ' IS ', I6, '.') 1010 FORMAT( + ' THE VALUES IN THE VECTOR ', 6A1, + ' MUST ALL BE GREATER THAN ', 1PE14.7, '.') 1020 FORMAT( + ' THE NUMBER OF VALUES IN THE VECTOR ', 6A1, + ' LESS THAN OR EQUAL TO ', 1PE14.7) 1021 FORMAT( + ' MUST BE LESS THAN ', I5, '.') 1030 FORMAT( + ' SINCE THE FIRST VALUE OF THE VECTOR ', 6A1, + ' IS GREATER THAN ', 1PE14.7) 1031 FORMAT( + ' ALL OF THE VALUES MUST BE GREATER THAN ', 1PE14.7, '.') 1040 FORMAT( + ' THE VALUES IN THE VECTOR ', 6A1, + ' MUST ALL BE GREATER THAN ', 8A1, '.') 1050 FORMAT( + ' THE NUMBER OF VALUES IN THE VECTOR ', 6A1, + ' LESS THAN OR EQUAL TO ', 8A1) 1051 FORMAT( + ' MUST BE LESS THAN ', I5, '.') 1060 FORMAT( + ' SINCE THE FIRST VALUE OF THE VECTOR ', 6A1, + ' IS GREATER THAN ', 8A1) 1061 FORMAT( + ' ALL OF THE VALUES MUST BE GREATER THAN ', 8A1, '.') 1070 FORMAT( + ' THERE MUST BE AT LEAST ', I2, ' VALUES IN VECTOR ', 6A1) 1071 FORMAT( + ' GREATER THAN OR EQUAL TO ', 8A1, '.') C END *LITVMU SUBROUTINE LITVMU(N, X, L, Y) C C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + L(1),X(N),Y(N) C C LOCAL SCALARS DOUBLE PRECISION + XI,ZERO INTEGER + I,I0,II,IJ,IM1,J,NP1 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 ZERO/0.0D0/ C DO 10 I = 1, N 10 X(I) = Y(I) NP1 = N + 1 I0 = N*(N+1)/2 DO 30 II = 1, N I = NP1 - II XI = X(I)/L(I0) X(I) = XI IF (I .LE. 1) GO TO 999 I0 = I0 - I IF (XI .EQ. ZERO) GO TO 30 IM1 = I - 1 DO 20 J = 1, IM1 IJ = I0 + J X(J) = X(J) - XI*L(IJ) 20 CONTINUE 30 CONTINUE 999 RETURN C *** LAST CARD OF LITVMU FOLLOWS *** END *NCHOSE INTEGER FUNCTION NCHOSE(N,K) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE IS USED TO COMBINE THE DIFFERENCE FACTORS FROM A C (BOX-JENKINS) TIME SERIES MODEL. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + K,N C C LOCAL SCALARS INTEGER + I,KK,NN C C INTRINSIC FUNCTIONS INTRINSIC MIN C 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 IF (N .GT. K) GO TO 10 NCHOSE = 1 RETURN C 10 KK = MIN(K, N - K) NN = 1 DO 20 I = 1, KK NN = (NN*(N - I + 1))/I 20 CONTINUE NCHOSE = NN RETURN END *RELCOM SUBROUTINE RELCOM(N, V, W, RELTOL, ABSTOL, NFAIL, IFAIL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES THE NUMBER OF TIMES THE C RELATIVE DIFFERENCE BETWEEN V(I) AND W(I), I = 1, 2, ..., N, C IS GREATER THAN RELTOL . C C WRITTEN BY - ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON) C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ABSTOL,RELTOL INTEGER + N,NFAIL C C ARRAY ARGUMENTS DOUBLE PRECISION + V(N),W(N) INTEGER + IFAIL(N) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ABSTOL C THE ABSOLUTE TOLERANCE USED IN THE COMPARISON. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFAIL(N) C AN INDICATOR VARIABLE DESIGNATING WHETHER OR NOT THE COMPARISON C FAILED OR NOT, WHERE 0 INDICATES NOT FAILURE AND 1 INDICATES C FALURE. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAIL C THE TOTAL NUMBER OF FAILURES. C DOUBLE PRECISION RELTOL C THE RELATIVE TOLERANCE USED IN THE COMPARISON. C DOUBLE PRECISION V(N), W(N) C THE VALUES BEING COMPARED. C 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 NFAIL = 0 C DO 30 I = 1, N IF ((ABS(V(I)-W(I)).LE.RELTOL*MAX(ABS(V(I)),ABS(W(I)))) .OR. + (((V(I).EQ.0.0D0).OR.(W(I).EQ.0.0D0)).AND. + (ABS(V(I)-W(I)).LE.ABSTOL))) THEN IFAIL(I) = 0 ELSE IFAIL(I) = 1 NFAIL = NFAIL + 1 END IF 30 CONTINUE C RETURN C END *STPMN SUBROUTINE STPMN(J,XM,N,M,IXM,MDL,PAR,NPAR, + NEXMPT,ETA,RELTOL,SCALE,STP,NFAIL,IFAIL,CD, + ITEMP,FD,FDLAST,FDSAVE,PV,PVMCD,PVNEW,PVPCD,PVSTP,PVTEMP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR SELECTING THE STEP SIZE FOR C COMPUTING AGAINST NUMERICAL DERIVATIVES C C WRITTEN BY - ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON) C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ETA,RELTOL,SCALE,STP INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + CD(N),FD(N),FDLAST(N),FDSAVE(N),PAR(NPAR),PV(N),PVMCD(N), + PVNEW(N),PVPCD(N),PVSTP(N),PVTEMP(N),XM(IXM,M) INTEGER + IFAIL(N),ITEMP(N) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON DOUBLE PRECISION + Q C C LOCAL SCALARS DOUBLE PRECISION + ABSTOL,CURVE,ETA3,FPLRS,PARMX,PVMEAN,PVTYP,STPCD,STPLOW, + STPMID,STPUP,TAUABS,TEMP,THIRD INTEGER + I C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL CMPFD,GMEAN,RELCOM,STPADJ,STPSEL C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN,SQRT C C COMMON BLOCKS COMMON /NOTOPT/Q C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ABSTOL C THE ABSOLUTE AGREEMENT TOLERANCE. C DOUBLE PRECISION CD(N) C THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C DOUBLE PRECISION CURVE C A MEASURE OF THE CURVATURE OF THE MODEL. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE MODEL C DOUBLE PRECISION ETA3 C THE CUBE ROOT OF ETA. C DOUBLE PRECISION FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C DOUBLE PRECISION FDLAST(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED. C DOUBLE PRECISION FDSAVE(N) C A VECTOR USED TO SAVE THE BEST OF THE C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATIONS TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C DOUBLE PRECISION FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C INTEGER I C AN INDEX VARIABLE. C INTEGER IFAIL(N) C THE VECTOR OF INDICATOR VARIABLES DESIGNATING WHETHER C THE STEP SIZE SELECTED WAS SATISFACTORY FOR A GIVEN C OBSERVATION AND PARAMETER. C INTEGER ITEMP(N) C A TEMPORARY STORAGE VECTOR. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NEXMPT C THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE C DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP C SIZE STILL BE CONSIDERED OK. C INTEGER NFAIL C THE VECTOR CONTAINING THE COUNTS FOR EACH PARAMETER C OF THE NUMBER OF OBSERVATIONS THE SELECTED STEP SIZE WAS C NOT SATISFACTORY. C DOUBLE PRECISION PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C DOUBLE PRECISION PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C DOUBLE PRECISION PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C DOUBLE PRECISION PVMCD(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)-STPCD. C DOUBLE PRECISION PVMEAN C THE MEAN OF A FUNCTION OF THE PREDICTED VALUES. C DOUBLE PRECISION PVNEW(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPNEW. C DOUBLE PRECISION PVPCD(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD. C DOUBLE PRECISION PVSTP(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STP. C DOUBLE PRECISION PVTEMP(N) C A TEMPORARY STORAGE VECTOR FOR PREDICTED VALUES. C DOUBLE PRECISION PVTYP C THE TYPICAL SIZE OF THE PREDICTED VALUES OF THE MODEL. C DOUBLE PRECISION Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C DOUBLE PRECISION SCALE C THE TYPICAL SIZE OF THE JTH PARAMETER. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C DOUBLE PRECISION STPCD C THE STEP SIZE USED FOR THE CENTRAL DIFFERENCE QUOTIENT. C DOUBLE PRECISION STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C DOUBLE PRECISION STPUP C THE UPPER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C DOUBLE PRECISION TAUABS C THE ABSOLUTE AGREEMENT TOLERANCE. C DOUBLE PRECISION TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C DOUBLE PRECISION THIRD C THE VALUE ONE THIRD. C DOUBLE PRECISION XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C 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 FPLRS = D1MACH(4) C C SET VARIOUS PARAMETERS NECESSARY FOR COMPUTING THE C OPTIMUM STEP SIZE C THIRD = 1.0D0 / 3.0D0 C ETA3 = ETA ** THIRD C PARMX = MAX(ABS(PAR(J)), ABS(SCALE)) IF (PARMX .EQ. 0.0D0) PARMX = 1.0D0 C STPCD = ((3.0D0 ** THIRD) * ETA3 * PARMX * SIGN(1.0D0, PAR(J))) C Q = STPCD + PAR(J) STPCD = Q - PAR(J) C TEMP = PAR(J) C PAR(J) = TEMP + STPCD CALL MDL(PAR, NPAR, XM, N, M, IXM, PVPCD) C PAR(J) = TEMP - STPCD CALL MDL(PAR, NPAR, XM, N, M, IXM, PVMCD) C PAR(J) = TEMP C C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL WITH RESPECT TO C PAR(J) C DO 10 I = 1, N PVTEMP(I) = ABS((PVPCD(I)+PVMCD(I)) - 2*PV(I)) IF (PVTEMP(I).EQ.0.0D0) THEN IF (PV(I).EQ.0.0D0) THEN PVTEMP(I) = FPLRS ELSE PVTEMP(I) = FPLRS*ABS(PV(I)) END IF END IF 10 CONTINUE C C COMPUTE THE GEOMETRIC MEAN C CALL GMEAN(PVTEMP, N, PVMEAN) C CURVE = ABS(PVMEAN / STPCD / STPCD) C C COMPUTE A TYPICAL VALUE OF THE MODEL C DO 20 I = 1, N PVTEMP(I) = ABS(PVPCD(I) + PV(I) + PVMCD(I)) IF (PVTEMP(I).EQ.0.0D0) THEN IF (PV(I).EQ.0.0D0) THEN PVTEMP(I) = FPLRS ELSE PVTEMP(I) = FPLRS*ABS(PV(I)) END IF END IF 20 CONTINUE C CALL GMEAN(PVTEMP, N, PVMEAN) C PVTYP = ABS(PVMEAN / 3.0D0) C C SET VALUES REPRESENTATIVE OF THE RANGE THE STEP SIZE C CAN BE EXPECTED TO TAKE C STPUP = (ETA3) * PARMX STPLOW = (ETA3) * STPUP STPMID = SQRT(STPLOW) * SQRT(STPUP) C C SELECT AN OPTIMUM STARTING STEP SIZE C IF (CURVE.EQ.0.0D0) THEN STP = PARMX * SIGN(1.0D0, PAR(J)) ELSE STP = (2.0D0 * SQRT(ETA) * SQRT(PVTYP) / SQRT(CURVE)) * + SIGN(1.0D0,PAR(J)) END IF C IF (ABS(STP).GT.PARMX) STP = PARMX * SIGN(1.0D0,PAR(J)) C Q = STP + PAR(J) STP = Q - PAR(J) C IF (STP.EQ.0.0D0) THEN STP = FPLRS * PAR(J) IF (STP.EQ.0.0D0) STP = FPLRS C 30 CONTINUE Q = STP + PAR(J) STP = Q - PAR(J) C IF (STP.EQ.0.0D0) THEN STP = 2.0D0 * STP GO TO 30 END IF END IF C C COMPUTE THE ABSOLUTE TOLERANCES C ABSTOL = 10.0D0 * ETA * PVTYP C TAUABS = 2.0D0 * SQRT(ETA) * SQRT(PVTYP) IF (CURVE .NE. 0.0D0) TAUABS = TAUABS * SQRT(CURVE) C TEMP = PAR(J) PAR(J) = TEMP + STP C CALL MDL(PAR, NPAR, XM, N, M, IXM, PVSTP) C PAR(J) = TEMP C C COMPUTE THE FORWARD AND CENTRAL DIFFERENCE QUOTIENT ESTIMATE C OF THE DERIVATIVE C CALL CMPFD(N, STP, PVSTP, PV, FD) C CALL CMPFD(N, 2.0D0*STPCD, PVPCD, PVMCD, CD) C C COMPUTE THE NUMBER OF OBSERVATIONS FOR WHICH THE FD DOES NOT C AGREE WITH THE CD WITHIN THE TOLERANCE SPECIFIED. C CALL RELCOM(N, FD, CD, RELTOL, ABSTOL, NFAIL, IFAIL) C C IF THE FORWARD DIFFERENCE APPROXIMATION DOES NOT AGREE WITHIN C TOLERANCE FOR MORE THAN NEXMPT OBSERVATION, SELECT NEW C VALUE OF THE STEP SIZE, ELSE ADJUST THE STEP SIZE AND RETURN. C IF (NFAIL.GT.NEXMPT) THEN C C SELECT NEW VALUE OF THE STEP SIZE C CALL STPSEL(XM, N, M, IXM, MDL, PAR, NPAR, + NEXMPT, STP, NFAIL, IFAIL, J, ETA3, RELTOL, ABSTOL, + TAUABS, STPLOW, + STPMID, STPUP, ITEMP, FD, FDLAST, FDSAVE, PV, PVNEW) ELSE C C ADJUST THE CURRENT STEP SIZE VALUE C CALL STPADJ(XM, N, M, IXM, MDL, PAR, NPAR, + NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW, + STPMID, STPUP, ITEMP, FD, FDLAST, PV, PVNEW) C END IF C C CONVERT SELECTED ABSOLUTE STEP SIZE TO RELATIVE STEP SIZE C STP = ABS(STP) / PARMX C RETURN C END *AMEISM SUBROUTINE AMEISM (AMEHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, + WEIGHT, IFIXD, PAR, SCALE, LSCALE, IWORK, LIWORK, RWORK, + LRWORK, RES, APRXDV, STPT, LSTPT, NPARE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS AN INITIAL SUMMARY OF THE STARTING C ESTIMATES AND THE CONTROL PARAMETERS FOR THE NONLINEAR C LEAST SQUARES SUBROUTINES FOR ARIMA MODELING. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LIWORK,LRWORK,LSCALE,LSTPT,M,N,NNZW,NPAR,NPARE LOGICAL + APRXDV,HLFRPT,PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),RES(*),RWORK(*),SCALE(*),STPT(*) INTEGER + IFIXD(*),IWORK(*) C C SUBROUTINE ARGUMENTS EXTERNAL AMEHDR C C SCALARS IN COMMON INTEGER + IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS, + PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + RSD,RSS INTEGER CCCCC+ IAMHD,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL + IAMHD,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DNRM2 EXTERNAL DNRM2 C C EXTERNAL SUBROUTINES CCCCC EXTERNAL AMLST,IPRINT,MODSUM EXTERNAL AMLST,MODSUM C C INTRINSIC FUNCTIONS INTRINSIC DBLE,SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL AMEHDR C THE ROUTINE USED TO PRINT THE HEADING C LOGICAL APRXDV C THE VARIABLE USED TO INDICATE WHETHER NUMERICAL C APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE C CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE C INITIAL SUMMARY (TRUE) OR NOT (FALSE). C INTEGER IAMHD C THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST C TO BE GENERATED C IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE C ESTIMATION ROUTINES. C IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE C FORECASTING ROUTINES. C IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE C ESTIMATION ROUTINES. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IWORK(LIWORK) C WORK SPACE USED BY THE NL2 SUBROUTINES. C INTEGER LIWORK C THE DIMENSION OF VECTOR IWORK. C INTEGER LMAX0 C THE LOCATION IN RWORK OF THE VALUE INDICATING THE C MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C INTEGER LRWORK C THE DIMENSION OF VECTOR RWORK. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER LSTPT C THE DIMENSION OF VECTOR STPT. C INTEGER M C A DUMMY VARIABLE. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER MXFCAL C THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE C MAXIMUM NUMBER OF FUNCTION CALLS ALLOWED, EXCLUDING C CALLS NECESSARY TO COMPUTE THE DERIVATIVES AND VARIANCE C COVARIANCE MATRIX. C INTEGER MXITER C THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE C MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C INTEGER RFCTOL C THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE C TOLERANCE. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RWORK(LRWORK) C WORK SPACE USED BY THE NL2 SUBROUTINES. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION STPT(LSTPT) C THE STEP SIZE ARRAY. C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C INTEGER XCTOL C THE LOCATION IN RWORK OF THE PARAMETER CONVERGENCE TOLERANCE. C C IWORK SUBSCRIPT VALUES 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 MXFCAL/17/, MXITER/18/ C C RWORK SUBSCRIPT VALUES C DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/ C CCCCC CALL IPRINT(IPRT) C ISUBHD = 1 CALL AMEHDR(PAGE, WIDE, ISUBHD) C CALL MODSUM(NFACT, ISTAK(MSPECT)) IAMHD = 1 CALL AMLST (IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, PAR, NPAR, + SCALE, LSCALE, STPT, LSTPT, IFIXD, RSS, RSD, NPARDF, NPARE, 0) C IF (WEIGHT) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1170) NNZW CALL DPWRST('XXX','BUG ') ENDIF CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1070) IWORK(MXITER) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1090) IWORK(MXFCAL) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1080) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1100) RWORK(RFCTOL) CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1110) RWORK(XCTOL) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT, 1120) RWORK(LMAX0) CALL DPWRST('XXX','BUG ') RSD = DNRM2(NRESTS, RES, 1) RSS = RSD * RSD IF (N-NPARDF-NPARE.GE.1) + RSD = RSD / SQRT(DBLE(N-NPARDF-NPARE)) CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1200) RSS CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1202) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1210) RSD CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1220) N, NPARDF, NPARE, NNZW-NPARE CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1070 FORMAT (' MAXIMUM NUMBER OF ITERATIONS ALLOWED', 22X, 5H(MIT), + 1X, I5) 1080 FORMAT(' CONVERGENCE CRITERION FOR TEST BASED ON THE') 1090 FORMAT(' MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS', + ' ALLOWED', 16X, I5) 1100 FORMAT (3X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL, + 15H SUM OF SQUARES, 1X, 8H(STOPSS), 1X, G11.4) 1110 FORMAT(3X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS, + 7X, 7H(STOPP), 1X, G11.4) 1120 FORMAT(' MAXIMUM CHANGE ALLOWED IN THE PARAMETERS', + ' AT FIRST ITERATION (DELTA) ', G11.4) 1170 FORMAT (' NUMBER OF NON ZERO WEIGHTED OBSERVATIONS', 17X, + 6H(NNZW), 1X, I5) 1200 FORMAT (' RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER', + 7H VALUES, 18X, G11.4) 1202 FORMAT (' (BACKFORECASTS INCLUDED)') 1210 FORMAT (' RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER', + 7H VALUES, 4X, 5H(RSD), 5X, G11.4) 1220 FORMAT (' BASED ON DEGREES OF FREEDOM ', + I4, 3H - , I3, 3H - , I3, 3H = , I4) END *CPYVII SUBROUTINE CPYVII(N,X,INCX,Y,INCY) C C LATEST REVISION - 03/15/90 (JRD) C C COPY INTEGER X TO INTEGER Y. C FOR I = 0 TO N-1, COPY X(LX+I*INCX) TO Y(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C C MODELED AFTER BLAS COPY ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + INCX,INCY,N C C ARRAY ARGUMENTS INTEGER + X(N),Y(N) C C LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VALUE. C INTEGER INCX C THE INCREMENT FOR THE MATRIX X. C INTEGER INCY C THE INCREMENT FOR THE MATRIX Y. C INTEGER N C THE NUMBER OF ROWS OF DATA TO BE COPIED FROM MATRIX X. C INTEGER X(N) C THE MATRIX TO BE COPIED FROM. C INTEGER Y(N) C THE MATRIX TO BE COPIED TO. C 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 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N Y(IY) = X(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M Y(I) = X(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 Y(I) = X(I) Y(I + 1) = X(I + 1) Y(I + 2) = X(I + 2) Y(I + 3) = X(I + 3) Y(I + 4) = X(I + 4) Y(I + 5) = X(I + 5) Y(I + 6) = X(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX Y(I) = X(I) 70 CONTINUE RETURN END *ETAMDL SUBROUTINE ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NETA, + PARTMP, PV, NROWIN) C C LATEST REVISION - 03/15/90 (JRD) C C ROUTINE TO COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN C RESULTS OF MODEL ROUTINE AT ROW . C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ETA INTEGER + IXM,M,N,NETA,NPAR,NROWIN C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),PARTMP(NPAR),PV(N),XM(IXM,M) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS DOUBLE PRECISION + A,B,FAC,FPLRS,J,RSSSM,RSSSMJ,SQRTMP INTEGER + I,K,NROW C C LOCAL ARRAYS DOUBLE PRECISION + RSS(5) C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL SETROW C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10,MAX,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION A, B C PARAMETERS OF THE FIT. C DOUBLE PRECISION ETA C THE NOISE IN THE MODEL RESULTS. C DOUBLE PRECISION FAC C A FACTOR USED IN THE COMPUTATIONS. C DOUBLE PRECISION FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IXM C ACTUAL FIRST DIMENSION OF XM C DOUBLE PRECISION J C THE VALUE FLOAT(I-3). C INTEGER K C AN INDEX VARIABLE. C INTEGER M C NUMBER OF VARIABLES C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C INTEGER NPAR C NUMBER OF PARAMETERS C INTEGER NROW C THE ROW NUMBER ACTUALLY USED. C INTEGER NROWIN C THE INPUT NUMBER OF THE ROW BEING CHECKED. C DOUBLE PRECISION PAR(NPAR) C MODEL PARAMETERS C DOUBLE PRECISION PARTMP(NPAR) C MODIFIED MODEL PARAMETERS C DOUBLE PRECISION PV(N) C PREDICTED VALUES C DOUBLE PRECISION RSS(5) C THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J. C DOUBLE PRECISION RSSSM C THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF C PARAMETER VALUES. C DOUBLE PRECISION RSSSMJ C THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH C SET OF PARAMETER VALUES. C DOUBLE PRECISION SQRTMP C THE SQUARE ROOT OF MACHINE PRECISION (FPLRS). C DOUBLE PRECISION XM(IXM,M) C INDEPENDENT VARIABLES C 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 FPLRS = D1MACH(4) C C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C CALL SETROW(NROWIN, XM, N, M, IXM, NROW) C SQRTMP = SQRT(FPLRS) RSSSM = 0.0D0 RSSSMJ = 0.0D0 DO 20 I=1,5 J = I-3 DO 10 K=1,NPAR PARTMP(K) = PAR(K)*(1.0D0+J*SQRTMP) 10 CONTINUE CALL MDL(PARTMP, NPAR, XM, N, M, IXM, PV) C RSS(I) = PV(NROW) C RSSSM = RSSSM + RSS(I) RSSSMJ = RSSSMJ + J*RSS(I) 20 CONTINUE A = 0.2D00*RSSSM B = 0.1D00*RSSSMJ FAC = 1.0D0 IF (RSS(3).NE.0.0D0) FAC = FAC/RSS(3) DO 30 I=1,5 J = I-3 RSS(I) = ABS((RSS(I)-(A+J*B))*FAC) 30 CONTINUE ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),FPLRS) NETA = -LOG10(ETA) ETA = 10.0D0**(-NETA) RETURN END *LIVMUL SUBROUTINE LIVMUL(N, X, L, Y) C C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME C *** STORAGE. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + L(1),X(N),Y(N) C C LOCAL SCALARS DOUBLE PRECISION + T,ZERO INTEGER + I,J,K C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD EXTERNAL DOTPRD 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 ZERO/0.0D0/ C DO 10 K = 1, N IF (Y(K) .NE. ZERO) GO TO 20 X(K) = ZERO 10 CONTINUE GO TO 999 20 J = K*(K+1)/2 X(K) = Y(K) / L(J) IF (K .GE. N) GO TO 999 K = K + 1 DO 30 I = K, N T = DOTPRD(I-1, L(J+1), X) J = J + I X(I) = (Y(I) - T)/L(J) 30 CONTINUE 999 RETURN C *** LAST CARD OF LIVMUL FOLLOWS *** END *NL2ITR SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X) C C LATEST REVISION - 03/15/90 (JRD) C C C *** CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS *** C *** (NL2SOL VERSION 2.2) *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),J(NN,P),R(N),V(*),X(P) INTEGER + IV(*) C C LOCAL SCALARS DOUBLE PRECISION + E,HALF,NEGONE,ONE,RDOF1,STTSST,T,T1,ZERO INTEGER + CNVCOD,COSMIN,COVMAT,COVPRT,COVREQ,D0INIT,DGNORM,DIG,DIG1, + DINIT,DSTNRM,DTYPE,DUMMY,F,F0,FDIF,FUZZ,G,G01,G1,GTSTEP,H, + H0,H1,I,IERR,IM1,INCFAC,INITS,IPIV0,IPIV1,IPIVI,IPIVK, + IPIVOT,IPK,IRC,JTINIT,JTOL1,K,KAGQT,KALM,KM1,L,LKY,LKY1, + LMAT,LMAT1,LMAX0,LSTGST,M,MODE,MODEL,MXFCAL,MXITER,NFCALL, + NFCOV,NFGCAL,NGCALL,NGCOV,NITER,NVSAVE,PHMXFC,PP1O2, + PREDUC,QTR,QTR1,RAD0,RADFAC,RADINC,RADIUS,RD,RD0,RD1,RDK, + RESTOR,RLIMIT,RSAVE,RSAVE1,S,S1,SIZE,SMH,SSTEP,STEP,STEP1, + STGLIM,STLSTG,STPMOD,STPPAR,SUSED,SWITCH,TEMP1,TEMP2, + TOOBIG,TUNER4,TUNER5,VSAVE1,W,W1,WSCALE,X0,X01,XIRC C C EXTERNAL FUNCTIONS DOUBLE PRECISION CCCCC+ DOTPRD,D1MACH,V2NORM + DOTPRD,V2NORM LOGICAL + STOPX CCCCC EXTERNAL DOTPRD,D1MACH,V2NORM,STOPX EXTERNAL DOTPRD,V2NORM,STOPX C C EXTERNAL SUBROUTINES EXTERNAL ASSESS,COVCLC,DUPDAT,GQTSTP,ITSMRY,LMSTEP,PARCHK,QAPPLY, + QRFACT,RPTMUL,SLUPDT,SLVMUL,VAXPY,VCOPY,VSCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER IV(1), N, NN, P C DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P) C DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2) C C C-------------------------- PARAMETER USAGE -------------------------- C C D.... SCALE VECTOR. C IV... INTEGER VALUE ARRAY. C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN). C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R). C NN... LEAD DIMENSION OF J. C P.... NUMBER OF PARAMETERS (COMPONENTS IN X). C R.... RESIDUAL VECTOR. C V.... FLOATING-POINT VALUE ARRAY. C X.... PARAMETER VECTOR. C C *** DISCUSSION *** C C PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND- C ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D), C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND C NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS. C ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12, C NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X), C THE CORRESPONDING JACOBIAN MATRIX OF R AT X. C C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X, C AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER C PARAMETERS. AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED C AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG- C NORE R AND TRY A SMALLER STEP. THE PARAMETER NF THAT C NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A C COPY OF IV(NFCALL) = IV(6). C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX C OF R AT X, AND CALL NL2ITR AGAIN. THE CALLER MAY CHANGE C D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER C PARAMETERS. THE PARAMETER NF THAT NL2SOL PASSES TO C CALCJ IS IV(NFGCAL) = IV(7). IF J CANNOT BE EVALUATED C AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH C CASE NL2ITR WILL RETURN WITH IV(1) = 15. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C (SEE NL2SOL FOR REFERENCES.) C C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C C INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1, C 1 IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1, C 2 RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1, C 3 TEMP1, TEMP2, W1, X01 C DOUBLE PRECISION E, RDOF1, STTSST, T, T1 C C *** CONSTANTS *** C C DOUBLE PRECISION HALF, NEGONE, ONE, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP, C 1 PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX, C 2 VAXPY, VCOPY, VSCOPY, V2NORM C LOGICAL STOPX C DOUBLE PRECISION DOTPRD, D1MACH, V2NORM C C ASSESS... ASSESSES CANDIDATE STEP. C COVCLC... COMPUTES COVARIANCE MATRIX. C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS. C DUPDAT... UPDATES SCALE VECTOR D. C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL). C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL). C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES. C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR. C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS. C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE) C STORED BY QRFACT. C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI- C ANGLE OF A SYMMETRIC MATRIX. C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED. C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER. C VCOPY.... COPIES ONE VECTOR TO ANOTHER. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C V2NORM... RETURNS THE 2-NORM OF A VECTOR. C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG, C 1 DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ, C 2 F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC, C 3 JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL, C 4 MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, C 5 NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC, C 6 RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP, C 7 STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, C 8 TUNER5, VSAVE1, W, WSCALE, XIRC, X0 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 *** IV SUBSCRIPT VALUES *** C DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/, + COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/, + IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/, + IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/, + MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/, + NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/, + NGCALL/30/, NITER/31/, QTR/49/, + RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/, + STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/, + SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/ C C *** V SUBSCRIPT VALUES *** C DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/, + D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/, + F0/13/, GTSTEP/4/, INCFAC/23/, + JTINIT/39/, JTOL1/87/, LMAX0/35/, + NVSAVE/9/, PHMXFC/21/, PREDUC/7/, + RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/, + SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/, + VSAVE1/78/, WSCALE/48/ C C DATA HALF/0.5D0/, NEGONE/-1.0D0/, ONE/1.0D0/, ZERO/0.0D0/ C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I = IV(1) IF (I .EQ. 1) GO TO 20 IF (I .EQ. 2) GO TO 50 C C *** CHECK VALIDITY OF IV AND V INPUT VALUES *** C C *** NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V) *** CALL PARCHK(IV, N, NN, P, V) I = IV(1) - 2 IF (I .GT. 10) GO TO 999 GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I C C *** INITIALIZATION AND STORAGE ALLOCATION *** C 10 IV(NITER) = 0 IV(NFCALL) = 1 IV(NGCALL) = 1 IV(NFGCAL) = 1 IV(MODE) = -1 IV(STGLIM) = 2 IV(TOOBIG) = 0 IV(CNVCOD) = 0 IV(COVMAT) = 0 IV(NFCOV) = 0 IV(NGCOV) = 0 IV(KALM) = -1 IV(RADINC) = 0 IV(S) = JTOL1 + 2*P PP1O2 = P * (P + 1) / 2 IV(X0) = IV(S) + PP1O2 IV(STEP) = IV(X0) + P IV(STLSTG) = IV(STEP) + P IV(DIG) = IV(STLSTG) + P IV(G) = IV(DIG) + P IV(LKY) = IV(G) + P IV(RD) = IV(LKY) + P IV(RSAVE) = IV(RD) + P IV(QTR) = IV(RSAVE) + N IV(H) = IV(QTR) + N IV(W) = IV(H) + PP1O2 IV(LMAT) = IV(W) + 4*P + 7 C +++ LENGTH OF W = P*(P+9)/2 + 7. LMAT IS CONTAINED IN W. IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT)) IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT)) I = JTOL1 + P IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT)) V(RAD0) = ZERO V(STPPAR) = ZERO V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC)) C C *** SET INITIAL MODEL AND S MATRIX *** C IV(MODEL) = 1 IF (IV(INITS) .EQ. 2) IV(MODEL) = 2 S1 = IV(S) IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO) C C *** COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES) *** C 20 T = V2NORM(N, R) IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1 IF (IV(TOOBIG) .NE. 0) GO TO 30 V(F) = 0.0 IF (T.GT.SQRT(D1MACH(1))) V(F) = HALF * T**2 30 IF (IV(MODE)) 40, 350, 730 C 40 IF (IV(TOOBIG) .EQ. 0) GO TO 60 IV(1) = 13 GO TO 900 C C *** MAKE SURE JACOBIAN COULD BE COMPUTED *** C 50 IF (IV(NFGCAL) .NE. 0) GO TO 60 IV(1) = 15 GO TO 900 C C *** COMPUTE GRADIENT *** C 60 IV(KALM) = -1 G1 = IV(G) DO 70 I = 1, P V(G1) = DOTPRD(N, R, J(1,I)) G1 = G1 + 1 70 CONTINUE IF (IV(MODE) .GT. 0) GO TO 710 C C *** UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER *** C IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V) RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) C C *** COMPUTE D**-1 * GRADIENT *** C G1 = IV(G) DIG1 = IV(DIG) K = DIG1 DO 80 I = 1, P V(K) = V(G1) / D(I) K = K + 1 G1 = G1 + 1 80 CONTINUE V(DGNORM) = V2NORM(P, V(DIG1)) C IF (IV(CNVCOD) .NE. 0) GO TO 700 IF (IV(MODE) .EQ. 0) GO TO 570 IV(MODE) = 0 C C C----------------------------- MAIN LOOP ----------------------------- C C C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT *** C 150 CALL ITSMRY(D, IV, P, V, X) 160 K = IV(NITER) IF (K .LT. IV(MXITER)) GO TO 170 IV(1) = 10 GO TO 900 170 IV(NITER) = K + 1 C C *** UPDATE RADIUS *** C IF (K .EQ. 0) GO TO 185 STEP1 = IV(STEP) DO 180 I = 1, P V(STEP1) = D(I) * V(STEP1) STEP1 = STEP1 + 1 180 CONTINUE STEP1 = IV(STEP) V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1)) C C *** INITIALIZE FOR START OF NEXT ITERATION *** C 185 X01 = IV(X0) V(F0) = V(F) IV(KAGQT) = -1 IV(IRC) = 4 IV(H) = -ABS(IV(H)) IV(SUSED) = IV(MODEL) C C *** COPY X TO X0 *** C CALL VCOPY(P, V(X01), X) C C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT *** C 190 IF (.NOT. STOPX(DUMMY)) GO TO 200 IV(1) = 11 GO TO 205 C C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX. C 195 IF (V(F) .GE. V(F0)) GO TO 200 V(RADFAC) = ONE K = IV(NITER) GO TO 170 C 200 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210 IV(1) = 9 205 IF (V(F) .GE. V(F0)) GO TO 900 C C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X. C IV(CNVCOD) = IV(1) GO TO 560 C C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . . C 210 STEP1 = IV(STEP) W1 = IV(W) IF (IV(MODEL) .EQ. 2) GO TO 240 C C *** COMPUTE LEVENBERG-MARQUARDT STEP *** C QTR1 = IV(QTR) IF (IV(KALM) .GE. 0) GO TO 215 RD1 = IV(RD) IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1), + IV(IPIVOT), IV(IERR), 0, V(W1)) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) 215 H1 = IV(H) IF (H1 .GT. 0) GO TO 230 C C *** COPY R MATRIX TO H *** C H1 = -H1 IV(H) = H1 K = H1 RD1 = IV(RD) V(K) = V(RD1) IF (P .EQ. 1) GO TO 230 DO 220 I = 2, P CALL VCOPY(I-1, V(K+1), J(1,I)) K = K + I RD1 = RD1 + 1 V(K) = V(RD1) 220 CONTINUE C 230 G1 = IV(G) CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P, + V(QTR1), V(H1), V(STEP1), V, V(W1)) GO TO 310 C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL) *** C 240 IF (IV(H) .GT. 0) GO TO 300 C C *** SET H TO D**-1 * ( (J**T)*J + S) ) * D**-1. *** C H1 = -IV(H) IV(H) = H1 S1 = IV(S) IF (IV(KALM) .GE. 0) GO TO 270 C C *** J IS IN ITS ORIGINAL FORM *** C DO 260 I = 1, P T = ONE / D(I) DO 250 K = 1, I V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K) H1 = H1 + 1 S1 = S1 + 1 250 CONTINUE 260 CONTINUE GO TO 300 C C *** LMSTEP HAS APPLIED QRFACT TO J *** C 270 SMH = S1 - H1 H0 = H1 - 1 IPIV1 = IV(IPIVOT) T1 = ONE / D(IPIV1) RD0 = IV(RD) - 1 RDOF1 = V(RD0 + 1) DO 290 I = 1, P L = IPIV0 + I IPIVI = IV(L) H1 = H0 + IPIVI*(IPIVI-1)/2 L = H1 + IPIVI M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(I)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(I)) *** T = ONE / D(IPIVI) RDK = RD0 + I E = V(RDK)**2 IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I)) V(L) = (E + V(M)) * T**2 IF (I .EQ. 1) GO TO 290 L = H1 + IPIV1 IF (IPIVI .LT. IPIV1) L = L + + ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(1)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(1)) *** V(L) = T * (RDOF1 * J(1,I) + V(M)) * T1 IF (I .EQ. 2) GO TO 290 IM1 = I - 1 DO 280 K = 2, IM1 IPK = IPIV0 + K IPIVK = IV(IPK) L = H1 + IPIVK IF (IPIVI .LT. IPIVK) L = L + + ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2 M = L + SMH C *** V(L) = H(IPIVOT(I), IPIVOT(K)) *** C *** V(M) = S(IPIVOT(I), IPIVOT(K)) *** KM1 = K - 1 RDK = RD0 + K V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) + + V(RDK)*J(K,I) + V(M)) / D(IPIVK) 280 CONTINUE 290 CONTINUE C C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP *** C 300 H1 = IV(H) DIG1 = IV(DIG) LMAT1 = IV(LMAT) CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1), + V, V(W1)) C C C *** COMPUTE R(X0 + STEP) *** C 310 IF (IV(IRC) .EQ. 6) GO TO 350 X01 = IV(X0) STEP1 = IV(STEP) CALL VAXPY(P, X, ONE, V(STEP1), V(X01)) IV(NFCALL) = IV(NFCALL) + 1 IV(1) = 1 IV(TOOBIG) = 0 GO TO 999 C C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . . C 350 STEP1 = IV(STEP) LSTGST = IV(STLSTG) X01 = IV(X0) CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01)) C C *** IF NECESSARY, SWITCH MODELS AND/OR RESTORE R *** C IF (IV(SWITCH) .EQ. 0) GO TO 360 IV(H) = -ABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V, V(VSAVE1)) 360 IF (IV(RESTOR) .EQ. 0) GO TO 390 RSAVE1 = IV(RSAVE) CALL VCOPY(N, R, V(RSAVE1)) 390 L = IV(IRC) - 4 STPMOD = IV(MODEL) IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L C C *** DECIDE WHETHER TO CHANGE MODELS *** C E = V(PREDUC) - V(FDIF) SSTEP = IV(LKY) S1 = IV(S) CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1)) STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP)) IF (IV(MODEL) .EQ. 1) STTSST = -STTSST IF (ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 400 C C *** SWITCH MODELS *** C IV(MODEL) = 3 - IV(MODEL) IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1 IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0 IF (-2 .LT. L) GO TO 480 IV(H) = -ABS(IV(H)) IV(SUSED) = IV(SUSED) + 2 CALL VCOPY(NVSAVE, V(VSAVE1), V) GO TO 420 C 400 IF (-3 .LT. L) GO TO 480 C C *** RECOMPUTE STEP WITH DECREASED RADIUS *** C V(RADIUS) = V(RADFAC) * V(DSTNRM) GO TO 190 C C *** RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY *** C 410 V(RADIUS) = V(RADFAC) * V(DSTNRM) 420 IF (V(F) .GE. V(F0)) GO TO 190 RSAVE1 = IV(RSAVE) CALL VCOPY(N, V(RSAVE1), R) GO TO 190 C C *** COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST C 440 V(RADIUS) = V(LMAX0) GO TO 210 C C *** CONVERGENCE OR FALSE CONVERGENCE *** C 450 IV(CNVCOD) = L IF (V(F) .GE. V(F0)) GO TO 700 IF (IV(XIRC) .EQ. 14) GO TO 700 IV(XIRC) = 14 C C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . . C 480 IV(COVMAT) = 0 C C *** SET LKY = (J(X0)**T) * R(X) *** C LKY1 = IV(LKY) IF (IV(KALM) .GE. 0) GO TO 500 C C *** JACOBIAN HAS NOT BEEN MODIFIED *** C DO 490 I = 1, P V(LKY1) = DOTPRD(N, J(1,I), R) LKY1 = LKY1 + 1 490 CONTINUE GO TO 510 C C *** QRFACT HAS BEEN APPLIED TO J. STORE COPY OF R IN QTR AND *** C *** APPLY Q TO IT. *** C 500 QTR1 = IV(QTR) CALL VCOPY(N, V(QTR1), R) CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR)) C C *** MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE *** C *** STORED BY QRFACT IN J AND RD. *** C RD1 = IV(RD) TEMP1 = IV(STLSTG) CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1), + V(TEMP1)) C C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS *** C 510 IF (IV(IRC) .NE. 3) GO TO 560 STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) C C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS *** C IF (STPMOD .EQ. 2) GO TO 530 C C *** STEP COMPUTED USING GAUSS-NEWTON MODEL *** C *** -- QRFACT HAS BEEN APPLIED TO J *** C RD1 = IV(RD) CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1), + V(STEP1), V(TEMP1), V(TEMP2)) GO TO 560 C C *** STEP COMPUTED USING AUGMENTED MODEL *** C 530 H1 = IV(H) K = TEMP2 DO 540 I = 1, P V(K) = D(I) * V(STEP1) K = K + 1 STEP1 = STEP1 + 1 540 CONTINUE CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2)) DO 550 I = 1, P V(TEMP1) = D(I) * V(TEMP1) TEMP1 = TEMP1 + 1 550 CONTINUE C C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE *** C 560 IV(NGCALL) = IV(NGCALL) + 1 G1 = IV(G) G01 = IV(W) CALL VCOPY(P, V(G01), V(G1)) IV(1) = 2 GO TO 999 C C *** INITIALIZATIONS -- G0 = G - G0, ETC. *** C 570 G01 = IV(W) G1 = IV(G) CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1)) STEP1 = IV(STEP) TEMP1 = IV(STLSTG) TEMP2 = IV(X0) IF (IV(IRC) .NE. 3) GO TO 600 C C *** SET V(RADFAC) BY GRADIENT TESTS *** C C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) *** C K = TEMP1 L = G01 DO 580 I = 1, P V(K) = (V(K) - V(L)) / D(I) K = K + 1 L = L + 1 580 CONTINUE C C *** DO GRADIENT TESTS *** C IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 590 IF (DOTPRD(P, V(G1), V(STEP1)) + .GE. V(GTSTEP) * V(TUNER5)) GO TO 600 590 V(RADFAC) = V(INCFAC) C C *** FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R *** C C *** CURRENTLY LKY = (J(X0)**T) * R *** C 600 LKY1 = IV(LKY) CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1)) C C *** DETERMINE SIZING FACTOR V(SIZE) *** C C *** SET TEMP1 = S * STEP *** S1 = IV(S) CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1)) C T1 = ABS(DOTPRD(P, V(STEP1), V(TEMP1))) T = ABS(DOTPRD(P, V(STEP1), V(LKY1))) V(SIZE) = ONE IF (T .LT. T1) V(SIZE) = T / T1 C C *** UPDATE S *** C CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1), + V(TEMP2), V(G01), V(WSCALE), V(LKY1)) IV(1) = 2 GO TO 150 C C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . . C C *** BAD PARAMETERS TO ASSESS *** C 640 IV(1) = 14 GO TO 900 C C *** CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED *** C 700 IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760 IF (IV(COVMAT) .NE. 0) GO TO 760 IF (IV(CNVCOD) .GE. 7) GO TO 760 IV(MODE) = 0 710 CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X) GO TO (720, 720, 740, 750), I 720 IV(NFCOV) = IV(NFCOV) + 1 IV(NFCALL) = IV(NFCALL) + 1 IV(RESTOR) = I IV(1) = 1 GO TO 999 C 730 IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710 IV(NFGCAL) = IV(NFCALL) 740 IV(NGCOV) = IV(NGCOV) + 1 IV(NGCALL) = IV(NGCALL) + 1 IV(1) = 2 GO TO 999 C 750 IV(MODE) = 0 IF (IV(NITER) .EQ. 0) IV(MODE) = -1 C 760 IV(1) = IV(CNVCOD) IV(CNVCOD) = 0 C C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS *** C 900 CALL ITSMRY(D, IV, P, V, X) C 999 RETURN C C *** LAST CARD OF NL2ITR FOLLOWS *** END *RELDST DOUBLE PRECISION FUNCTION RELDST(P, D, X, X0) C C LATEST REVISION - 03/15/90 (JRD) C C C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 *** C *** NL2SOL VERSION 2.2 *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),X(P),X0(P) C C LOCAL SCALARS DOUBLE PRECISION + EMAX,T,XMAX,ZERO INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ABS 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 ZERO/0.0D0/ C EMAX = ZERO XMAX = ZERO DO 10 I = 1, P T = ABS(D(I) * (X(I) - X0(I))) IF (EMAX .LT. T) EMAX = T T = D(I) * (ABS(X(I)) + ABS(X0(I))) IF (XMAX .LT. T) XMAX = T 10 CONTINUE RELDST = ZERO IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX RETURN C *** LAST CARD OF RELDST FOLLOWS *** END *STPSEL SUBROUTINE STPSEL(XM, N, M, IXM, MDL, PAR, NPAR, + NEXMPT, STP, NFAIL, IFAIL, J, ETA3, RELTOL, ABSTOL, TAUABS, + STPLOW, STPMID, STPUP, ITEMP, FD, FDLAST, FDSAVE, PV, PVNEW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE SELECTS NEW STEP SIZES UNITL EITHER C THE NUMBER OF OBSERVATIONS AT WHICH THE SELECTION CRITERIA C IS NOT MET DOES NOT EXCEED NEXMPT OR UNTIL NO FURTHER C IMPROVEMENT CAN BE MADE. C C WRITTEN BY - ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON) C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + ABSTOL,ETA3,RELTOL,STP,STPLOW,STPMID,STPUP,TAUABS INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + FD(N),FDLAST(N),FDSAVE(N),PAR(NPAR),PV(N),PVNEW(N),XM(IXM,M) INTEGER + IFAIL(N),ITEMP(N) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON DOUBLE PRECISION + Q C C LOCAL SCALARS DOUBLE PRECISION + FACTOR,STP1,STP2,STPNEW,TEMP INTEGER + NCOUNT LOGICAL + FAIL,FIRST,FORWRD,HICURV,SUCCES C C EXTERNAL SUBROUTINES EXTERNAL ABSCOM,CMPFD,ICOPY,RELCOM,DCOPY,STPADJ C C INTRINSIC FUNCTIONS INTRINSIC ABS C C COMMON BLOCKS COMMON /NOTOPT/Q C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ABSTOL C THE ABSOLUTE AGREEMENT TOLERANCE. C DOUBLE PRECISION ETA3 C THE CUBE ROOT OF THE RELATIVE NOISE IN THE MODEL C DOUBLE PRECISION FACTOR C A FACTOR USED IN COMPUTING THE STEP SIZE. C LOGICAL FAIL C THE VARIABLE USED TO INDICATE WHETHER A STEP SIZE C CANNOT BE SELECTED WHICH WILL SUCCESSFULLY MEET THE CRITERIA. C DOUBLE PRECISION FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C DOUBLE PRECISION FDLAST(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED. C DOUBLE PRECISION FDSAVE(N) C A VECTOR USED TO SAVE THE BEST OF THE C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATIONS TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C LOGICAL FIRST C THE VARIABLE USED TO INDICATE WHETHER THIS STEP SIZE C IS BEING USED FOR THE FIRST TIME OR WHETHER IT HAS BEEN C PREVIOUSLY ADJUSTED. C LOGICAL FORWRD C THE VARIABLE USED TO INDICATE THE DIRECTION OF CHANGE IN C THE STEP SIZE. C LOGICAL HICURV C THE VARIABLE USED TO INDICATE WHETHER THE MODEL HAS C HIGH CURVATURE. C INTEGER IFAIL(N) C AN INDICATOR VECTOR USED TO DESIGNATE THOSE OBSERVATIONS C FOR WHICH THE STEP SIZE DOES NOT MEET THE CRITERIA. C INTEGER ITEMP(N) C A TEMPORARY VECTOR USED FOR STORING PAST VALUES OF ITEMP. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NCOUNT C THE NUMBER OF OBSERVATIONS AT WHICH THE NEW STEP SIZE DOES C SATISFY THE CRITERIA. C INTEGER NEXMPT C THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE C DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP C SIZE STILL BE CONSIDERED OK. C INTEGER NFAIL C A VECTOR CONTAINING FOR EACH OBSERVATION THE NUMBER OF C OBSERVATIONS FOR WHICH THE STEP SIZE DID NOT MEET THE CRITERIA. C DOUBLE PRECISION PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C DOUBLE PRECISION PVNEW(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD. C DOUBLE PRECISION Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C DOUBLE PRECISION STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C DOUBLE PRECISION STPNEW C THE VALUE OF THE NEW STEP SIZE BEING TESTED. C DOUBLE PRECISION STPUP C THE UPPER LIMIT ON THE STEP SIZE. C DOUBLE PRECISION STP1, STP2 C TEMPORARY STORAGE LOCATIONS FOR STEP SIZES. C LOGICAL SUCCES C THE VARIABLE USED TO INDICATE WHETHER THE STEP SIZE C SUCCESSFULLY MEETS THE CRITERIA USED TO SELECT THE STEP C SIZES. C DOUBLE PRECISION RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C DOUBLE PRECISION TAUABS C THE ABSOLUTE AGREEMENT TOLERANCE. C DOUBLE PRECISION TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C DOUBLE PRECISION XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C 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 CALL DCOPY(N, FD, 1, FDSAVE, 1) C FACTOR = 10.0D0 IF (ABS(STP) .GT. STPMID) FACTOR = 0.1D0 C STPNEW = STP * FACTOR STP1 = STPNEW STP2 = STPNEW C Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) C FIRST = .TRUE. FORWRD = .TRUE. SUCCES = .FALSE. FAIL = .FALSE. C NFAIL = N + 1 C C REPEAT FOLLOWING UNTIL (SUCCES) OR (FAIL) C 10 CONTINUE C CALL DCOPY(N, FD, 1, FDLAST, 1) C TEMP = PAR(J) PAR(J) = TEMP + STPNEW C CALL MDL(PAR, NPAR, XM, N, M, IXM, PVNEW) C PAR(J) = TEMP C CALL CMPFD(N, STPNEW, PVNEW, PV, FD) C CALL RELCOM(N, FD, FDLAST, RELTOL, ABSTOL, NCOUNT, ITEMP) C IF (NCOUNT.LE.NEXMPT) THEN SUCCES = .TRUE. NFAIL = NCOUNT CALL ICOPY(N, ITEMP, 1, IFAIL, 1) IF (ABS(ABS(STPNEW) - STPMID) .GT. + ABS(ABS(STPNEW/FACTOR) - STPMID)) THEN STP = STPNEW / FACTOR ELSE STP = STPNEW END IF ELSE IF (NCOUNT.LT.NFAIL) THEN NFAIL = NCOUNT STP1 = STPNEW STP2 = STPNEW / FACTOR CALL ICOPY(N, ITEMP, 1, IFAIL, 1) END IF IF (FIRST) THEN FIRST = .FALSE. CALL ABSCOM(N, FD, FDLAST, TAUABS, NCOUNT) IF (NCOUNT.LE.NEXMPT) THEN HICURV = .TRUE. ELSE HICURV = .FALSE. END IF END IF STPNEW = STPNEW * FACTOR Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) IF ((FACTOR.GT.1.0D0 .AND. ABS(STPNEW).GT.STPUP) .OR. + (FACTOR.LT.1.0D0 .AND. ABS(STPNEW).LT.STPLOW)) THEN IF (FORWRD) THEN FORWRD = .FALSE. FACTOR = 1.0D0 / FACTOR STPNEW = STP * FACTOR Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) CALL DCOPY(N, FDSAVE, 1, FD, 1) STPLOW = STPLOW * (ETA3) STPUP = STPUP / (ETA3) ELSE FAIL = .TRUE. END IF END IF END IF C IF (.NOT.(SUCCES.OR.FAIL)) GO TO 10 C IF (SUCCES .AND. FORWRD) THEN CALL STPADJ(XM, N, M, IXM, MDL, PAR, NPAR, + NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW, + STPMID, STPUP, ITEMP, FD, FDLAST, PV, PVNEW) RETURN ELSE IF (SUCCES) THEN RETURN ELSE C IF (HICURV) NFAIL = -NFAIL C IF (ABS(STP1).LT.ABS(STP2)) THEN STP = STP1 RETURN ELSE STP = STP2 RETURN END IF END IF END IF C END *AMEMN SUBROUTINE AMEMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, NRESTS, + APRXDV, IFIXD, PAR, PARE, NPAR, RES, PAGE, WIDE, + HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, DELTA, + IVAPRX, IPTOUT, NDIGIT, RSD, RESTS, SDPVI, SDRESI, VCVL, LVCVL, + D, IWORK, IIWORK, RWORK, IRWORK, NLHDR, NPARE, PVT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLING SUBROUTINE FOR PERFORMING NONLINEAR C LEAST SQUARES REGRESSION USING THE NL2 SOFTWARE PACKAGE C (IMPLEMENTING THE METHOD OF DENNIS, GAY AND WELSCH). C THIS SUBROUTINE WAS ADAPTED FROM SUBROUTINE NL2SOL. C C REFERENCES C C DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1979), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, (BEING REVISED). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + DELTA,RSD,STOPP,STOPSS INTEGER + IIWORK,IRWORK,IVAPRX,IXM,LSCALE,LSTP,LVCVL,LWT,M,MIT,N, + NDIGIT,NNZW,NPAR,NPARE,NRESTS,SDPVI,SDRESI,VCVL LOGICAL + APRXDV,HLFRPT,PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + D(NRESTS,*),PAR(*),PARE(*),PVT(*),RES(*),RESTS(*),RWORK(*), + SCALE(*),STP(*),WT(*),XM(IXM,*),Y(*) INTEGER + IFIXD(*),IPTOUT(*),IWORK(*) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + CNVCOD,COVMAT,I,ICNVCD,IVCVPT,QTR,RD,RDI,RSAVE,RSSHLF,S, + SCL LOGICAL + CMPDRV,DONE,HEAD,NEWITR,PRTSMY C C LOCAL ARRAYS INTEGER + ISKULL(10) C C EXTERNAL SUBROUTINES EXTERNAL AMDRV,AMEFIN,AMEISM,DRV,MDLTS3,NL2ITR,NLERR,NLINIT, + NLITRP,NLSUPK,REPCK,DCOPY C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL APRXDV C THE VARIABLE USED TO INDICATE WHETHER NUMERICAL C APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT C (FALSE). C LOGICAL CMPDRV C THE VARIABLE USED TO INDICATE WHETHER DERIVATIVES MUST BE C COMPUTED (TRUE) OR NOT (FALSE). C INTEGER CNVCOD C A VALUE USED TO CONTROL THE PRINTING OF ITERATION REPORTS. C INTEGER COVMAT C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK C OF THE BEGINNING OF THE VCV MATRIX. C DOUBLE PRECISION D(NRESTS,NPAR) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C DOUBLE PRECISION DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL. C LOGICAL DONE C THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL C COMPUTATION OF THE JACOBIAN OR NOT. C LOGICAL HEAD C THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE C PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE) C OR NOT (FALSE). C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE C CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE C INITIAL SUMMARY (TRUE) OR NOT (FALSE). C INTEGER I C AN INDEXING VARIABLE. C INTEGER ICNVCD C THE LOCATION IN IWORK OF C THE CONVERGENCE CONDITION. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IIWORK C THE DIMENSION OF THE INTEGER WORK VECTOR IWORK. C INTEGER IPTOUT(NDIGIT) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER IRWORK C THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C INTEGER IVAPRX C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE C IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED C IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED C INTEGER IVCVPT C AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE C VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE C IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C INTEGER IWORK(IIWORK) C THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LSCALE C THE ACTUAL LENGTH OF THE VECTOR SCALE. C INTEGER LSTP C THE ACTUAL LENGTH OF THE VECTOR STP. C INTEGER LVCVL C THE LENGTH OF THE VECTOR CONTAINING C THE LOWER HALF OF THE VCV MATRIX, STORED ROW WISE. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C EXTERNAL MDLTS3 C THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL C RESIDUALS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C LOGICAL NEWITR C A FLAG USED TO INDICATE WHETHER A NEW ITERATION HAS BEEN C COMPLETED (TRUE) OR NOT (FALSE). C EXTERNAL NLHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PARE(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS, BUT ONLY C THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED). C LOGICAL PRTSMY C THE VARIABLE USED TO INDICATE WHETHER THE SUMMARY C INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER QTR C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK C THE ARRAY Q TRANSPOSE R. C INTEGER RD C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK OF C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C INTEGER RDI C THE LOCATION IN RWORK OF THE DIAGONAL ELEMENTS OF THE R C MATRIX OF THE Q - R FACTORIZATION OF D. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C INTEGER RSAVE C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK C THE ARRAY RSAVE. C DOUBLE PRECISION RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C INTEGER RSSHLF C THE LOCATION IN RWORK OF C HALF THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RWORK(IRWORK) C THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES. C INTEGER S C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK C THE ARRAY OF SECOND ORDER TERMS OF THE HESSIAN. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C INTEGER SCL C THE INDEX IN RWORK OF THE 1ST VALUE OF THE USER SUPPLIED SCALE C VALUE. C INTEGER SDPVI C THE STARTING LOCATION IN RWORK OF C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C INTEGER SDRESI C THE STARTING LOCATION IN RWORK OF THE C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION STOPP C THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED C RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR C PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C DOUBLE PRECISION STOPSS C THE STOPPING CRITERION FORTHE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C DOUBLE PRECISION STP(LSTP) C THE DUMMY STEP SIZE ARRAY. C INTEGER VCVL C THE STARTING LOCATION IN RWORK OF THE LOWER HALF OF THE C VCV MATRIX, STORED ROW WISE. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C DOUBLE PRECISION Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C 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 IWORK SUBSCRIPT VALUES C DATA CNVCOD /34/, ICNVCD /1/, COVMAT /26/, QTR /49/, RD /51/, + RSAVE /52/, S/53/ DATA RSSHLF /10/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C C INITIALIZE CONTROL PARAMETERS C CALL NLINIT (NRESTS, IFIXD, PAR, NPAR, PARE, NPARE, MIT, STOPSS, + STOPP, SCALE, LSCALE, DELTA, IVAPRX, APRXDV, IVCVPT, IWORK, + IIWORK, RWORK, IRWORK, SCL) C CMPDRV = .TRUE. DONE = .FALSE. HEAD = .TRUE. NEWITR = .FALSE. PRTSMY = (IPTOUT(1).NE.0) C C COMPUTE RESIDUALS C 10 CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, RESTS) C C PRINT INITIAL SUMMARY C IF (.NOT.PRTSMY) GO TO 30 CALL AMEISM(NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, WEIGHT, + IFIXD, PAR, SCALE, LSCALE, IWORK, IIWORK, RWORK, IRWORK, RESTS, + APRXDV, STP, LSTP, NPARE) PRTSMY = .FALSE. C 30 CONTINUE C IF (.NOT.CMPDRV) GO TO 50 C CMPDRV = .FALSE. C 40 CONTINUE C C PRINT ITERATION REPORT IF DESIRED C IF ((IPTOUT(2).NE.0) .AND. NEWITR) CALL NLITRP(NLHDR, HEAD, PAGE, + WIDE, IPTOUT(2), NPAR, NNZW, IWORK, IIWORK, RWORK, IRWORK, + IFIXD, PARE, NPARE) C C *** COMPUTE JACOBIAN *** C IF (DONE) CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, RESTS) C CALL AMDRV(MDLTS3, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, IXM, + NRESTS, RESTS, D, WEIGHT, WT, LWT, STP, LSTP, RWORK(SCL), NPARE) C IF (DONE) GO TO 70 C C COMPUTE NEXT ITERATION C 50 CALL NL2ITR(RWORK(SCL), IWORK, D, NRESTS, NRESTS, NPARE, RESTS, + RWORK, PARE) C C UNPACK PARAMETERS C CALL NLSUPK(PARE, NPARE, PAR, IFIXD, NPAR) C NEWITR = (IWORK(CNVCOD).EQ.0) IF (IWORK(1)-2) 10, 40, 60 C 60 DONE = .TRUE. GO TO 40 70 CONTINUE C C SET ERROR FLAGS, IF NECESSARY C CALL NLERR(IWORK(ICNVCD), ISKULL) C C FINISH COMPUTATIONS AND PRINT ANY DESIRED RESULTS C CALL DCOPY(N, RESTS(NRESTS-N+1), 1, RES(1), 1) DO 75 I = 1, N PVT(I) = Y(I) - RES(I) 75 CONTINUE SDPVI = IWORK(RSAVE) SDRESI = IWORK(QTR) VCVL = IWORK(COVMAT) IF (VCVL.GE.1) GO TO 80 C VCVL = IWORK(S) IF (IERR.NE.0) GO TO 80 ISKULL(1) = 1 ISKULL(7) = 1 IERR = 7 C 80 CONTINUE C LVCVL = NPARE*(NPARE+1)/2 C RDI = IWORK(RD) C C REPCK IS CALLED TO AVOID MODIFICATION OF NLS CODE. FUTURE C REVISIONS OF NLS CODE SHOULD INCLUDE MODIFICATIONS NECESSARY C TO ELIMINATE NEED TO REPACK D FOR ARIMA CODE. C CALL REPCK(D, NRESTS, NPAR, N) CALL AMEFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, PAR, + NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RWORK(RSSHLF), + RSD, PVT, RWORK(SDPVI), RWORK(SDRESI), RWORK(RDI), + RWORK(VCVL), LVCVL, D, NLHDR, IVCVPT, ISKULL, NRESTS) C RETURN C END *DCOEF SUBROUTINE DCOEF (NDF, ND, IOD, NPARDF, PARDF, MBO, WORK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NDF, C IOD AND ND INTO PARDF. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DEVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MBO,NDF,NPARDF C C ARRAY ARGUMENTS DOUBLE PRECISION + PARDF(*),WORK(*) INTEGER + IOD(*),ND(*) C C LOCAL SCALARS INTEGER + K,KK,L,NTIMES,NWORK1,NWORK2 C C EXTERNAL FUNCTIONS INTEGER + NCHOSE EXTERNAL NCHOSE C C EXTERNAL SUBROUTINES EXTERNAL MULTBP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IOD(NDF) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER K C AN INDEX VARIABLE. C INTEGER KK C AN INDEX VARIABLE. C INTEGER L C AN INDEX VARIABLE. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER ND(NDF) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED. C INTEGER NDF C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NTIMES C THE NUMBER OF TIMES A GIVEN DIFFERENCE FACTOR IS TO BE APPLIED. C INTEGER NWORK1 C THE NUMBER OF TERMS IN THE FIRST COLUMN OF WORK. C INTEGER NWORK2 C THE NUMBER OF TERMS IN THE SECOND COLUMN OF WORK C DOUBLE PRECISION PARDF(MBO) C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS. C DOUBLE PRECISION WORK(MBO,2) C A WORK ARRAY NECESSARY TO EXPAND THE DIFFERENCE FILTER. C 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 NPARDF = 0 C DO 30 L = 1, NDF IF (ND(L).EQ.0) GO TO 30 NTIMES = ND(L) NWORK1 = IOD(L) * ND(L) DO 10 K = 1, NWORK1 WORK(K) = 0.0D0 10 CONTINUE DO 20 K = 1, NTIMES KK = K * IOD(L) WORK(KK) = ((-1)**(K+1)) * NCHOSE(NTIMES, K) 20 CONTINUE NWORK2 = NWORK1 + NPARDF CALL MULTBP (WORK(1), NWORK1, PARDF, NPARDF, WORK(MBO+1), + NWORK2, MBO) 30 CONTINUE RETURN END *FITEXT SUBROUTINE FITEXT(RSS, YSS, EXACT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE FIT IS EXACT TO MACHINE C PRECISION. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + RSS,YSS LOGICAL + EXACT C C LOCAL SCALARS DOUBLE PRECISION + FPLRS,RSSTST C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL EXACT C AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT C WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE). C DOUBLE PRECISION FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RSSTST C THE VALUE FOR TESTING WHETHER THE RESIDUAL SUM OF SQUARES C IS ZERO (TO WITHIN MACHINE PRECISION). C DOUBLE PRECISION YSS C THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y. 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 FPLRS = D1MACH(4) C C TEST FOR EXACT FIT C EXACT = .FALSE. RSSTST = RSS IF (YSS.GT.0.0D0) RSSTST = RSSTST / YSS RSSTST = SQRT(RSSTST) IF (RSSTST.LT.10.0D0*FPLRS) EXACT = .TRUE. C RETURN C END *LMSTEP SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W) C C LATEST REVISION - 03/15/90 (JRD) C C C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE ** C *** NL2SOL VERSION 2.2. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IERR,KA,P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),G(P),QTR(P),R(1),STEP(P),V(21),W(1) INTEGER + IPIVOT(P) C C LOCAL SCALARS DOUBLE PRECISION + A,ADI,ALPHAK,B,D1,D2,DFAC,DFACSQ,DST,DTOL,EIGHT,HALF,LK, + NEGONE,OLDPHI,ONE,P001,PHI,PHIMAX,PHIMIN,PSIFAC,RAD,SI,SJ, + SQRTAK,T,THREE,TTOL,TWOPSI,UK,WL,ZERO INTEGER + DGNORM,DST0,DSTNRM,DSTSAV,EPSLON,GTSTEP,I,I1,IP1,J1,K, + KALIM,L,LK0,NREDUC,PHIPIN,PHMNFC,PHMXFC,PP1O2,PREDUC,RAD0, + RADIUS,RES,RES0,RMAT,RMAT0,STPPAR,UK0 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD,V2NORM EXTERNAL DOTPRD,V2NORM C C EXTERNAL SUBROUTINES EXTERNAL LITVMU,LIVMUL,VCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,MIN,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER IERR, KA, P C INTEGER IPIVOT(P) C DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1) C DIMENSION W(P*(P+5)/2 + 4) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG- C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE- C TECHNIQUE. C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR. C G (IN) = THE GRADIENT VECTOR (J**T)*R. C IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS C FULL RANK. C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE C QR DECOMPOSITIONS WITH COLUMN PIVOTING. C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON C LMSTEP FOR THE CURRENT R AND QTR. ON OUTPUT KA CON- C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP. C P (IN) = NUMBER OF PARAMETERS. C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR. C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS. C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (I/O) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.) C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C FOR A GAUSS-NEWTON STEP. C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED C BY THE STEP RETURNED. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS). C C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P, C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1). C C *** ALGORITHM NOTES *** C C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60- C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER. C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS) C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE, C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE C REF. 2 FOR MORE DETAILS.) C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX. C VCOPY - COPIES ONE VECTOR TO ANOTHER. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1980), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, (SUBMITTED TO ACM C TRANS. MATH. SOFTWARE). C 2. GAY, D.M. (1979), COMPUTING OPTIMAL ELLIPTICALLY CONSTRAINED C STEPS, MRC TECH. SUMMARY REPORT NO. 2013, MATH RESEARCH C CENTER, UNIV. OF WISCONSIN-MADISON. C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J. C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C C INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN, C 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0 C DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2, C 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, C 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL C C *** CONSTANTS *** C DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE, C 1 TTOL, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM C DOUBLE PRECISION DOTPRD, V2NORM C C *** SUBSCRIPTS FOR V *** C C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, C 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR 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 DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, + GTSTEP/4/, NREDUC/6/, PHMNFC/20/, + PHMXFC/21/, PREDUC/7/, RADIUS/8/, + RAD0/9/, STPPAR/5/ C DATA DFAC/256.0D0/, EIGHT/8.0D0/, HALF/0.5D0/, NEGONE/-1.0D0/, + ONE/1.0D0/, P001/1.0D-3/, THREE/3.0D0/, TTOL/2.5D0/, + ZERO/0.0D0/ C C *** BODY *** C C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK, C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J) C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0), C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY. ALPHAK = 0.0D0 PSIFAC = 0.0D0 LK0 = P + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 RMAT0 = DSTSAV C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER C *** WORK ON THESE COPIES. RMAT = RMAT0 + 1 PP1O2 = P * (P + 1) / 2 RES0 = PP1O2 + RMAT0 RES = RES0 + 1 RAD = V(RADIUS) IF (RAD .GT. ZERO) + PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2) PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION. DTOL = ONE/DFAC DFACSQ = DFAC*DFAC C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO LK = ZERO UK = ZERO KALIM = KA + 12 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA) 10, 20, 370 C C *** FRESH START -- COMPUTE V(NREDUC) *** C 10 KA = 0 KALIM = 12 K = P IF (IERR .NE. 0) K = ABS(IERR) - 1 V(NREDUC) = HALF*DOTPRD(K, QTR, QTR) C C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP *** C 20 V(DST0) = NEGONE IF (IERR .NE. 0) GO TO 90 C C *** COMPUTE GAUSS-NEWTON STEP *** C C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE C *** TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL. CALL LITVMU(P, W, R, QTR) C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP. DO 60 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*W(I) 60 CONTINUE DST = V2NORM(P, STEP) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 410 C *** IF THIS IS A RESTART, GO TO 110 *** IF (KA .GT. 0) GO TO 110 C C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 *** C DO 70 I = 1, P J1 = IPIVOT(I) STEP(I) = D(J1)*(STEP(I)/DST) 70 CONTINUE CALL LIVMUL(P, STEP, R, STEP) T = ONE / V2NORM(P, STEP) W(PHIPIN) = (T/DST)*T LK = PHI*W(PHIPIN) C C *** COMPUTE U0 *** C 90 DO 100 I = 1, P 100 W(I) = G(I)/D(I) V(DGNORM) = V2NORM(P, W) UK = V(DGNORM)/RAD IF (UK .LE. ZERO) GO TO 390 C C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD C C C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES *** C 110 KA = KA + 1 CALL VCOPY(PP1O2, W(RMAT), R) CALL VCOPY(P, W(RES), QTR) C C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. *** C IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) + ALPHAK = UK * MAX(P001, SQRT(LK/UK)) SQRTAK = SQRT(ALPHAK) DO 120 I = 1, P 120 W(I) = ONE C C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. *** C DO 270 I = 1, P C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D. C *** (USE STEP TO STORE TEMPORARY ROW) *** L = I*(I+1)/2 + RMAT0 WL = W(L) D2 = ONE D1 = W(I) J1 = IPIVOT(I) ADI = SQRTAK*D(J1) IF (ADI .GE. ABS(WL)) GO TO 150 130 A = ADI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 150 W(I) = D1/T D2 = D2/T W(L) = T*WL A = -A DO 140 J1 = I, P L = L + J1 STEP(J1) = A*W(L) 140 CONTINUE GO TO 170 C 150 B = WL/ADI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 130 W(I) = D2/T D2 = D1/T W(L) = T*ADI DO 160 J1 = I, P L = L + J1 WL = W(L) STEP(J1) = -WL W(L) = A*WL 160 CONTINUE C 170 IF (I .EQ. P) GO TO 280 C C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW *** C IP1 = I + 1 DO 260 I1 = IP1, P L = I1*(I1+1)/2 + RMAT0 WL = W(L) SI = STEP(I1-1) D1 = W(I1) C C *** RESCALE ROW I1 IF NECESSARY *** C IF (D1 .GE. DTOL) GO TO 190 D1 = D1*DFACSQ WL = WL/DFAC K = L DO 180 J1 = I1, P K = K + J1 W(K) = W(K)/DFAC 180 CONTINUE C C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW C 190 IF (ABS(SI) .GT. ABS(WL)) GO TO 220 IF (SI .EQ. ZERO) GO TO 260 200 A = SI/WL B = D2*A/D1 T = A*B + ONE IF (T .GT. TTOL) GO TO 220 W(L) = T*WL W(I1) = D1/T D2 = D2/T DO 210 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = WL + B*SJ STEP(J1) = SJ - A*WL 210 CONTINUE GO TO 240 C 220 B = WL/SI A = D1*B/D2 T = A*B + ONE IF (T .GT. TTOL) GO TO 200 W(I1) = D2/T D2 = D1/T W(L) = T*SI DO 230 J1 = I1, P L = L + J1 WL = W(L) SJ = STEP(J1) W(L) = A*WL + SJ STEP(J1) = B*SJ - WL 230 CONTINUE C C *** RESCALE TEMP. ROW IF NECESSARY *** C 240 IF (D2 .GE. DTOL) GO TO 260 D2 = D2*DFACSQ DO 250 K = I1, P 250 STEP(K) = STEP(K)/DFAC 260 CONTINUE 270 CONTINUE C C *** COMPUTE STEP *** C 280 CALL LITVMU(P, W(RES), W(RMAT), W(RES)) C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) *** DO 290 I = 1, P J1 = IPIVOT(I) K = RES0 + I T = W(K) STEP(J1) = -T W(K) = T*D(J1) 290 CONTINUE DST = V2NORM(P, W(RES)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430 IF (OLDPHI .EQ. PHI) GO TO 430 OLDPHI = PHI C C *** CHECK FOR (AND HANDLE) SPECIAL CASE *** C IF (PHI .GT. ZERO) GO TO 310 IF (KA .GE. KALIM) GO TO 430 TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G) IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310 V(STPPAR) = -ALPHAK GO TO 440 C C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN *** C 300 IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK) GO TO 320 310 IF (PHI .LT. ZERO) UK = ALPHAK 320 DO 330 I = 1, P J1 = IPIVOT(I) K = RES0 + I STEP(I) = D(J1) * (W(K)/DST) 330 CONTINUE CALL LIVMUL(P, STEP, W(RMAT), STEP) DO 340 I = 1, P 340 STEP(I) = STEP(I) / SQRT(W(I)) T = ONE / V2NORM(P, STEP) ALPHAK = ALPHAK + T*PHI*T/RAD LK = MAX(LK, ALPHAK) GO TO 110 C C *** RESTART *** C 370 LK = W(LK0) UK = W(UK0) IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20 ALPHAK = ABS(V(STPPAR)) DST = W(DSTSAV) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 380 C C *** SMALLER RADIUS *** UK = T IF (ALPHAK .LE. ZERO) LK = ZERO IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** BIGGER RADIUS *** 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T LK = ZERO IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 300 C C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) *** C 390 V(STPPAR) = ZERO DST = ZERO LK = ZERO UK = ZERO V(GTSTEP) = ZERO V(PREDUC) = ZERO DO 400 I = 1, P 400 STEP(I) = ZERO GO TO 450 C C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W *** C 410 ALPHAK = ZERO DO 420 I = 1, P J1 = IPIVOT(I) STEP(J1) = -W(I) 420 CONTINUE C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(STPPAR) = ALPHAK 440 V(GTSTEP) = DOTPRD(P, STEP, G) V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP)) 450 V(DSTNRM) = DST W(DSTSAV) = DST W(LK0) = LK W(UK0) = UK V(RAD0) = RAD C RETURN C C *** LAST CARD OF LMSTEP FOLLOWS *** END *NLCMP SUBROUTINE NLCMP (Y, WEIGHT, WT, LWT, N, NPAR, NPARE, + RES, D, RD, COND, VCVL, LVCVL, NNZW, IDF, RSSHLF, RSS, RSD, + YSS, EXACT, PVT, SDPVT, SDREST, ISKULL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES VARIOUS STATISTICS AND VALUES RETURNED C AND/OR PRINTED BY THE NLS FAMILY OF ROUTINES WHEN WEIGHTS ARE C INVOLVED. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + COND,RSD,RSS,RSSHLF,YSS INTEGER + IDF,LVCVL,LWT,N,NNZW,NPAR,NPARE LOGICAL + EXACT,WEIGHT C C ARRAY ARGUMENTS DOUBLE PRECISION + D(N,NPAR),PVT(N),RD(N),RES(N),SDPVT(N),SDREST(N),VCVL(LVCVL), + WT(LWT),Y(N) INTEGER + ISKULL(10) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + FAC,FPLM,RVAR,SM,TJ,WTI,WTSUM,YWTSM,YWTYSM INTEGER + I,J,JK,K C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL FITEXT C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION COND C THE CONDITION NUMBER OF D. C DOUBLE PRECISION D(N,NPAR) C THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN). C LOGICAL EXACT C AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT C WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE). C DOUBLE PRECISION FAC C A FACTOR USED TO CORRECT FOR ZERO WEIGHTED OBSERVATIONS IN C THE VARIANCE COVARIANCE COMPUTATION. C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C INTEGER J C AN INDEX VARIABLE. C INTEGER JK C THE INDEX OF THE (J,K)TH ELEMENT OF THE VARIANCE-COVARIANCE C MATRIX. C INTEGER K C AN INDEX VARIABLE. C INTEGER LVCVL C THE DIMENSION OF VECTOR VCVL. C INTEGER LWT C THE DIMENSION OF VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION RD(N) C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RSSHLF C HALF THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RVAR C THE RESIDUAL VARIANCE. C DOUBLE PRECISION SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDREST(N) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION SM C A VARIABLE USED FOR SUMMATION. C DOUBLE PRECISION TJ C ... C DOUBLE PRECISION VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION WTI C THE ACTUAL WEIGHT USED FOR THE ITH OBSERVATION. C DOUBLE PRECISION WTSUM C THE SUM OF THE WEIGHTS. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C DOUBLE PRECISION YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. C DOUBLE PRECISION YWTSM C THE SUM OF THE VALUES Y(I)*WT(I), I=1,N. C DOUBLE PRECISION YWTYSM C THE SUM OF THE VALUES Y(I)*WT(I)*WT(I), I=1,N. C 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 FPLM = D1MACH(2) C C COMPUTE RESIDUALS C DO 10 I=1,N RES(I) = Y(I) - PVT(I) 10 CONTINUE C C COMPUTE VARIOUS STATISTICS C IDF = NNZW - NPARE RSS = 2.0D0*RSSHLF RVAR = 0.0D0 IF (IDF.GE.1) RVAR = RSS/IDF RSD = SQRT(RVAR) YWTSM = 0.0D0 YWTYSM = 0.0D0 WTSUM = 0.0D0 DO 20 I=1,N WTI = 1.0D0 IF (WEIGHT) WTI = WT(I) YWTSM = YWTSM + Y(I)*WTI YWTYSM = YWTYSM + Y(I)*WTI*Y(I) WTSUM = WTSUM + WTI 20 CONTINUE YSS = MAX(YWTYSM-(YWTSM*YWTSM)/WTSUM,0.0D0) C CALL FITEXT(RSS, YSS, EXACT) C COND = FPLM IF (RD(NPARE).NE.0.0D0) COND = ABS(RD(1)/RD(NPARE)) C IF (IERR.NE.0) RETURN C C CORRECT FOR DEGREES OF FREEDOM IF NECESSARY BECAUSE OF ZERO C WEIGHTED OBSERVATIONS. C IF (N.EQ.NNZW) GO TO 40 C FAC = N-NPARE IF (IDF.GE.1) FAC = FAC/IDF DO 30 I=1,LVCVL VCVL(I) = VCVL(I)*FAC 30 CONTINUE C 40 CONTINUE C C IF THE RESIDUAL SUM OF SQUARES IS IDENTICALLY ZERO, THEN C NO FURTHER COMPUTATIONS ARE NECESSARY C IF ((IDF.LE.0) .OR. EXACT) RETURN C C IF THE STANDARD DEVIATIONS OF THE PREDICTED VALUES AND C STANDARDIZED RESIDUALS ARE NOT SAVED OR PRINTED, THEN NO C FURTHER COMPUTATIONS ARE NECESSARY. C C COMPUTE THE STANDARD DEVIATIONS OF THE PREDICTED VALUES (SDPVT) C DO 90 I=1,N SM = 0.0D0 DO 60 J=1,NPARE TJ = 0.0D0 DO 50 K=1,NPARE IF (J.GE.K) THEN JK = J*(J-1)/2 + K ELSE JK = K*(K-1)/2 + J END IF TJ = TJ + VCVL(JK)*D(I,K) 50 CONTINUE SM = SM + D(I,J)*TJ 60 CONTINUE IF (SM.LT.0.0D0) SM = 0.0D0 SDPVT(I) = SQRT(SM) C SDREST(I) = FPLM WTI = 1.0D0 IF (WEIGHT) WTI = WT(I) IF (WTI.EQ.0.0D0) GO TO 90 C IF (RVAR/WTI-SM.LE.0.0D0) GO TO 70 GO TO 80 C C THEN C 70 SDREST(I) = FPLM ISKULL(1) = 1 ISKULL(4) = 1 IERR = 4 GO TO 90 C C ELSE C 80 SDREST(I) = RES(I)/SQRT(RVAR/WTI-SM) C C END IF C 90 CONTINUE C RETURN C END *REPCK SUBROUTINE REPCK(D, NRESTS, NPAR, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE MODIFIES D TO CONFORM TO N BY NPAR FORMAT REQUIRED C BY NLCMP. FUTURE REVISIONS TO NLCMP SHOULD BE MADE TO ELIMINATE C THE NEED FOR THIS ROUTINE. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NPAR,NRESTS C C ARRAY ARGUMENTS DOUBLE PRECISION + D(NRESTS*NPAR) C C LOCAL SCALARS INTEGER + I,I1,I2,J C 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 I1 = -N I2 = -N DO 10 J = 1, NPAR I1 = I1 + NRESTS I2 = I2 + N DO 5 I = 1, N D(I2+I) = D(I1+I) 5 CONTINUE 10 CONTINUE RETURN END *UFPARM SUBROUTINE UFPARM RETURN END *AMEOUT SUBROUTINE AMEOUT(Y, N, IFIXD, + PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, RSS, + RSD, YSS, EXACT, PVT, SDPVT, SDREST, VCVL, LVCVL, IVCVPT, + ISKULL, AMEHDR, WIDE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE FINAL SUMMARY OUTPUT FROM THE C ARIMA ESTIMATION SUBROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + COND,RSD,RSS,YSS INTEGER + IDF,IVCVPT,LVCVL,N,NDIGIT,NPAR,NPARE LOGICAL + EXACT,PAGE,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),PVT(*),RES(*),SDPVT(*),SDREST(*),VCVL(*),Y(*) INTEGER + IFIXD(*),IPTOUT(*),ISKULL(10) C C SUBROUTINE ARGUMENTS EXTERNAL AMEHDR C C SCALARS IN COMMON INTEGER + IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA, + NRESTS,PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + FPLM INTEGER + I,IAMHD,ISUBHD C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES CCCCC EXTERNAL AMEPT1,AMEPT2,AMLST,MODSUM,NLSKL,VCVOTF EXTERNAL AMEPT1,AMLST,MODSUM,NLSKL,VCVOTF C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION COND C THE CONDITION NUMBER OF D. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL EXACT C AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT C WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE). C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C EXTERNAL AMEHDR C THE ROUTINE USED TO PRINT THE HEADING C INTEGER I C AN INDEX VARIABLE. C INTEGER IAMHD C THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST C TO BE GENERATED C IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE C ESTIMATION ROUTINES. C IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE C FORECASTING ROUTINES. C IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE C ESTIMATION ROUTINES. C INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IPTOUT(NDIGIT) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IVCVPT C AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE C VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE C IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C INTEGER LVCVL C THE DIMENSION OF VECTOR VCVL. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE OPTIMIZED. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDREST(N) C THE STANDARDIZED RESIDUALS. C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C DOUBLE PRECISION VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C DOUBLE PRECISION YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. C 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 FPLM = D1MACH(2) C CCCCC CALL IPRINT(IPRT) C IF ((IERR.GE.1) .AND. (IERR.NE.4)) GO TO 60 C C TEST FOR EXACT FIT C IF ((IDF.LE.0) .OR. EXACT) GO TO 70 C C PRINT ERROR HEADING IF NECESSARY C IF (IERR.EQ.4) CALL NLSKL(ISKULL, PAGE, WIDE, AMEHDR) C C PRINT PRIMARY REPORT C IF ((IERR.EQ.0) .AND. (IPTOUT(3).EQ.0)) GO TO 10 ISUBHD = 0 CALL AMEHDR(PAGE, WIDE, ISUBHD) CALL AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT) C C PRINT STANDARDIZED RESIDUAL PLOTS C CCCCC USE DATAPLOT HIGH-QUALITY GRAPHICS INSTEAD OF THESE LINE CCCCC PRINTER GRAPHICS!!! 10 IF (IPTOUT(4).EQ.0) GO TO 20 ISUBHD = 0 CCCCC CALL AMEHDR(PAGE, WIDE, ISUBHD) C CCCCC CALL AMEPT2 (RES, SDREST, N, RSS) C C PRINT THE COVARIANCE AND CORRELATION MATRIX C 20 IF ((IERR.EQ.0) .AND. (IPTOUT(5).EQ.0)) RETURN ISUBHD = 0 CALL AMEHDR(PAGE, WIDE, ISUBHD) CCCCC CALL MODSUM(NFACT, ISTAK(MSPECT)) C IF ((IERR.EQ.0) .AND. (IPTOUT(5).LE.1)) GO TO 30 C CALL VCVOTF(NPARE, VCVL, LVCVL, .TRUE., NPAR, IFIXD, IVCVPT) C C PRINT ANALYSIS SUMMARY C 30 CONTINUE 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,1001) CALL DPWRST('XXX','BUG ') IAMHD = 3 CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL, + PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF) WRITE (ICOUT,1050) COND CALL DPWRST('XXX','BUG ') C IF (RSS.GT.YSS) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1060) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1061) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1062) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1063) CALL DPWRST('XXX','BUG ') ENDIF C RETURN C C PRINT OUT ERROR HEADING C 60 CALL NLSKL(ISKULL, PAGE, WIDE, AMEHDR) C IF (IERR.LE.2) RETURN C C PRINT SECONDARY REPORT C 70 CONTINUE ISUBHD = 0 CALL AMEHDR(PAGE, WIDE, ISUBHD) CALL MODSUM(NFACT, ISTAK(MSPECT)) IF (IERR.NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1080) CALL DPWRST('XXX','BUG ') ENDIF 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,1001) CALL DPWRST('XXX','BUG ') IAMHD = 2 CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL, + PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF) IF (IERR.NE.3) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1050) COND CALL DPWRST('XXX','BUG ') ENDIF C IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1070) CALL DPWRST('XXX','BUG ') ENDIF IF ((IERR.EQ.0) .AND. EXACT) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1090) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1091) CALL DPWRST('XXX','BUG ') ENDIF C IF (IERR.NE.0) GO TO 100 C DO 90 I=1,N SDREST(I) = 0.0D0 SDPVT(I) = 0.0D0 90 CONTINUE C RETURN C 100 CONTINUE C DO 110 I=1,N SDREST(I) = FPLM SDPVT(I) = FPLM 110 CONTINUE C C PRINT OUT ERROR EXIT STATISTICS C CALL AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT) C C WIPE OUT SDREST VECTOR C DO 120 I=1,N SDREST(I) = FPLM 120 CONTINUE C C WIPE OUT VCV MATRIX C DO 140 I=1,LVCVL VCVL(I) = FPLM 140 CONTINUE C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' ESTIMATES FROM LEAST SQUARES FIT (* FOR FIXED ', + 'PARAMETER)') 1001 FORMAT(1X, 56('#')) 1050 FORMAT (' APPROXIMATE CONDITION NUMBER', 10X, G15.7) 1060 FORMAT ( + ' THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES', + ' FIT IS GREATER THAN') 1061 FORMAT ( + ' THE SUM OF SQUARES ABOUT THE MEAN ', + 'Y OBSERVATION. THE MODEL IS LESS') 1062 FORMAT ( + ' REPRESENTATIVE OF THE DATA THAN A SIMPLE AVERAGE. DATA', + ' AND MODEL SHOULD ') 1063 FORMAT ( + ' BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.') 1070 FORMAT (' THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO.', + ' STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.') 1080 FORMAT ( + ' THE FOLLOWING SUMMARY SHOULD BE USED TO ANALYZE', + ' THE ABOVE MENTIONED PROBLEMS.') 1090 FORMAT ( + ' THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS', + ' EXACT TO WITHIN MACHINE PRECISION.') 1091 FORMAT ( + ' STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.') END *DFAULT SUBROUTINE DFAULT(IV, V) C C LATEST REVISION - 03/15/90 (JRD) C C C C VARIABLE DECLARATIONS C C ARRAY ARGUMENTS DOUBLE PRECISION + V(45) INTEGER + IV(25) C C LOCAL SCALARS DOUBLE PRECISION + MACHEP,MEPCRT,ONE,SQTEPS,THREE INTEGER + AFCTOL,COSMIN,COVPRT,COVREQ,D0INIT,DECFAC,DELTA0,DFAC, + DINIT,DLTFDC,DLTFDJ,DTYPE,EPSLON,FUZZ,INCFAC,INITS,JTINIT, + LMAX0,MXFCAL,MXITER,OUTLEV,PARPRT,PHMNFC,PHMXFC,PRUNIT, + RDFCMN,RDFCMX,RFCTOL,RLIMIT,SOLPRT,STATPR,TUNER1,TUNER2, + TUNER3,TUNER4,TUNER5,X0PRT,XCTOL,XFTOL C C EXTERNAL FUNCTIONS DOUBLE PRECISION + RMDCON INTEGER + IMDCON EXTERNAL RMDCON,IMDCON C C INTRINSIC FUNCTIONS INTRINSIC MAX C C *** SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V *** C C INTEGER IV(25) C DOUBLE PRECISION V(45) C/+ C DOUBLE PRECISION MAX C/ C EXTERNAL IMDCON, RMDCON C INTEGER IMDCON C DOUBLE PRECISION RMDCON C C DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC, C 1 DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ, C 2 INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV, C 3 PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX, C 4 RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3, C 5 TUNER4, TUNER5, XCTOL, XFTOL, X0PRT 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/1.0D0/, THREE/3.0D0/ C C *** IV SUBSCRIPT VALUES *** C DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/, + MXFCAL/17/, MXITER/18/, OUTLEV/19/, + PARPRT/20/, PRUNIT/21/, SOLPRT/22/, + STATPR/23/, X0PRT/24/ C C *** V SUBSCRIPT VALUES *** C DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/, + DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/, + DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/, + INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/, + PHMXFC/21/, RDFCMN/24/, RDFCMX/25/, + RFCTOL/32/, RLIMIT/42/, TUNER1/26/, + TUNER2/27/, TUNER3/28/, TUNER4/29/, + TUNER5/30/, XCTOL/33/, XFTOL/34/ C C----------------------------------------------------------------------- C IV(1) = 12 IV(COVPRT) = 1 IV(COVREQ) = 1 IV(DTYPE) = 1 IV(INITS) = 0 IV(MXFCAL) = 200 IV(MXITER) = 150 IV(OUTLEV) = 1 IV(PARPRT) = 1 IV(PRUNIT) = IMDCON(1) IV(SOLPRT) = 1 IV(STATPR) = 1 IV(X0PRT) = 1 C MACHEP = RMDCON(3) V(AFCTOL) = 1.0D-20 IF (MACHEP .GT. 1.0D-10) V(AFCTOL) = MACHEP**2 V(COSMIN) = MAX(1.0D-6, 1.0D2 * MACHEP) V(DECFAC) = 0.5D0 SQTEPS = RMDCON(4) V(DELTA0) = SQTEPS V(DFAC) = 0.6D0 V(DINIT) = 0.0D0 MEPCRT = MACHEP ** (ONE/THREE) V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(D0INIT) = 1.0D0 V(EPSLON) = 0.1D0 V(FUZZ) = 1.5D0 V(INCFAC) = 2.0D0 V(JTINIT) = 1.0D-6 V(LMAX0) = 100.0D0 V(PHMNFC) = -0.1D0 V(PHMXFC) = 0.1D0 V(RDFCMN) = 0.1D0 V(RDFCMX) = 4.0D0 V(RFCTOL) = MAX(1.0D-10, MEPCRT**2) V(RLIMIT) = RMDCON(5) V(TUNER1) = 0.1D0 V(TUNER2) = 1.0D-4 V(TUNER3) = 0.75D0 V(TUNER4) = 0.5D0 V(TUNER5) = 0.75D0 V(XCTOL) = SQTEPS V(XFTOL) = 1.0D2 * MACHEP C RETURN C *** LAST CARD OF DFAULT FOLLOWS *** END *FIXPRT SUBROUTINE FIXPRT(IFIX, FIXED) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE CHARACTER ARRAY FIXED. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFIX C C ARRAY ARGUMENTS CHARACTER + FIXED(3)*1 C C LOCAL SCALARS INTEGER + I C C LOCAL ARRAYS CHARACTER + NO(3)*1,YES(3)*1 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 FIXED(3) C THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT. C INTEGER I C AN INDEX VARIABLE. C INTEGER IFIX C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIX.EQ.0, THEN FIXED WILL BE SET TO NO. C IF IFIX.NE.0, THEN FIXED WILL BE SET TO YES. C CHARACTER*1 NO(3) C THE CHARACTERS BLANK, N, AND O C CHARACTER*1 YES(3) C THE CHARACTERS Y, E, AND S 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 NO(1)/' '/, NO(2)/'N'/, NO(3)/'O'/ DATA YES(1)/'Y'/, YES(2)/'E'/, YES(3)/'S'/ C IF (IFIX.NE.0) THEN C C SET FIXED TO YES C DO 10 I = 1, 3 FIXED(I) = YES(I) 10 CONTINUE C ELSE C C SET FIXED TO NO C DO 20 I = 1, 3 FIXED(I) = NO(I) 20 CONTINUE END IF C RETURN C END *LOPASS SUBROUTINE LOPASS (Y, N, FC, K, HLP, YF, NYF, IERR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE CARRIES OUT LOW-PASS FILTERING OF THE C SERIES. THE FILTER IS THE K-TERM C LEAST SQUARES APPROXIMATION TO THE CUTOFF FILTER C WITH CUTOF FREQUENCY FC. ITS TRANSFER FUNCTION C HAS A TRANSITION BAND OF WIDTH DELTA SURROUNDING FC, C WHERE DELTA = 4*PI/K. C C WRITTEN BY - PETER BLOOMFIELD C FOURIER ANALYSIS OF TIME SERIES- AN C INTRODUCTION C JOHN WILEY AND SONS, NEW YORK, 1976 C PAGE 149 C ADAPTED FOR STARPAC BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + FC INTEGER + K,N,NYF C C ARRAY ARGUMENTS DOUBLE PRECISION + HLP(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD C C LOCAL ARRAYS CHARACTER + LFC(8)*1,LK(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES CCCCC EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,IPRNT,LPFLT EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,LPFLT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION FC C THE USER SUPPLIED CUTOFF FREQUENCY. C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C DOUBLE PRECISION HLP(K) C THE ARRAY IN WHICH THE -IDEAL- HIGH PASS FILTER COEFFICIENTS C WILL BE RETURNED. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER K C THE NUMBER OF FILTER TERMS TO BE COMPUTED. C CHARACTER*1 LFC(8), LK(8), LN(8) C THE ARRAY CONTAINING THE NAMES OF THE VARIABLES FC, K AND N. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NYF C THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF. C DOUBLE PRECISION Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C DOUBLE PRECISION YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C 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 SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'L', 'O', 'P', 'A', 'S', 'S'/ DATA + LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8) + / 'F', 'C', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 3, 1, HEAD, ERR01, LN) C CALL ERSII(NMSUB, LFC, FC, 0.0D0, 0.5D0, 2, HEAD, ERR02, LFC, LFC) C CALL EISII(NMSUB, LK, K, 1, N, 2, HEAD, ERR03, LK, LK) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04) C IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 10 C CALL ERSLFS(NMSUB, FC, K, HEAD, ERR05) C IF (.NOT. ERR05) GO TO 20 C 10 CONTINUE IERR = 1 CCCCC CALL IPRNT (IPRT) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1003) CALL DPWRST('XXX','BUG ') IERR2=IERR C RETURN C 20 CONTINUE C CALL LPFLT (FC, K, HLP) C CALL FLTSL (Y, N, K, HLP, YF, NYF) C IERR2=IERR RETURN C C FORMAT STATEMENTS C 1000 FORMAT(' THE CORRECT FORM OF THE CALL STATEMENT IS') 1003 FORMAT(' CALL LOPASS (Y, N, FC, K, HLP, YF, NYF)') END *NLDRVN SUBROUTINE NLDRVN (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, + IXM, PVT, D, WEIGHT, WT, LWT, STPT, LSTPT, SCL, LSCL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE NUMERICAL APPROXIMATIONS TO THE C DERIVATIVE MATRIX (JACOBIAN). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,LSCL,LSTPT,LWT,M,N,NPAR LOGICAL + DONE,WEIGHT C C ARRAY ARGUMENTS DOUBLE PRECISION + D(N,NPAR),PAR(NPAR),PVT(N),SCL(LSCL),STPT(LSTPT),WT(LWT), + XM(IXM,M) INTEGER + IFIXD(NPAR) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + PJ,STPJ,WTSQRT INTEGER + I,J,JPK C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION D(N,NPAR) C THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN). C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL. C LOGICAL DONE C THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL C COMPUTATION OF THE JACOBIAN OR NOT. C INTEGER I C AN INDEX VARIABLE. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER J C AN INDEX VARIABLE. C INTEGER JPK C AN INDEX VARIABLE. C INTEGER LSCL C THE DIMENSION OF VECTOR SCL. C INTEGER LSTPT C THE DIMENSION OF VECTOR STPT. C INTEGER LWT C THE DIMENSION OF VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C DOUBLE PRECISION PJ C A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER. C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION SCL(LSCL) C THE SCALE VALUES. C DOUBLE PRECISION STPT(LSTPT) C THE STEP SIZE ARRAY. C DOUBLE PRECISION STPJ C THE JTH STEP SIZE. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C DOUBLE PRECISION WT(LWT) C THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION WTSQRT C THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS. C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. C 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 COMPUTE FINITE-DIFFERENCE JACOBIAN OF THE OPTIMIZED PARAMETERS C JPK = 0 C DO 20 J=1,NPAR IF (IFIXD(J).EQ.0) THEN JPK = JPK + 1 PJ = PAR(J) IF (SCL(JPK).EQ.0.0D0) THEN IF (PAR(J).NE.0.0D0) THEN STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*ABS(PAR(J)) ELSE STPJ = STPT(J) END IF ELSE STPJ = STPT(J)* + SIGN(1.0D0,PAR(J))*MAX(ABS(PAR(J)),1.0D0/ + ABS(SCL(JPK))) END IF C STPJ = STPJ + PAR(J) STPJ = STPJ - PAR(J) C PAR(J) = PJ + STPJ CALL MDL(PAR, NPAR, XM, N, M, IXM, D(1,J)) C DO 10 I=1,N WTSQRT = 1.0D0 IF (WEIGHT .AND. (.NOT.DONE)) WTSQRT = SQRT(WT(I)) D(I,JPK) = WTSQRT*(PVT(I)-D(I,J))/STPJ 10 CONTINUE C PAR(J) = PJ END IF 20 CONTINUE C RETURN C END *RMDCON DOUBLE PRECISION FUNCTION RMDCON(K) C C LATEST REVISION - 03/15/90 (JRD) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + K C C LOCAL SCALARS DOUBLE PRECISION + BIG,ETA,MACHEP,ONE001,PT999 C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C INTRINSIC FUNCTIONS INTRINSIC DSQRT C C C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL *** C C +++ COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES. +++ C +++ TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE +++ C +++ DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++ C +++ AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S) +++ C +++ THAT CORRESPOND TO THE NEW MACHINE. +++ C C INTEGER K C C *** THE CONSTANT RETURNED DEPENDS ON K... C C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS. C *** K = 2... SQUARE ROOT OF 1.001*ETA. C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1. C *** K = 4... SQUARE ROOT OF 0.999*MACHEP. C *** K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6). C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS. 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 ONE001/1.001D0/, PT999/0.999D0/ C BIG = D1MACH(2) ETA = D1MACH(1) MACHEP = D1MACH(4) C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 RMDCON = ETA GO TO 999 C 20 RMDCON = DSQRT(ONE001*ETA) GO TO 999 C 30 RMDCON = MACHEP GO TO 999 C 40 RMDCON = DSQRT(PT999*MACHEP) GO TO 999 C 50 RMDCON = DSQRT(PT999*BIG) GO TO 999 C 60 RMDCON = BIG C 999 RETURN C *** LAST CARD OF RMDCON FOLLOWS *** END *V2NORM DOUBLE PRECISION FUNCTION V2NORM(P, X) C C LATEST REVISION - 03/15/90 (JRD) C C *** RETURN THE 2-NORM OF THE P-VECTOR X, TAKING *** C *** CARE TO AVOID THE MOST LIKELY UNDERFLOWS. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + X(*) C C LOCAL SCALARS DOUBLE PRECISION + ONE,R,SCALE,SQTETA,T,XI,ZERO INTEGER + I,J C C EXTERNAL FUNCTIONS DOUBLE PRECISION + RMDCON EXTERNAL RMDCON C C INTRINSIC FUNCTIONS INTRINSIC ABS,SQRT 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/1.0D0/, SQTETA/0.0D0/, ZERO/0.0D0/ C IF (P .GT. 0) GO TO 10 V2NORM = ZERO GO TO 999 10 DO 20 I = 1, P IF (X(I) .NE. ZERO) GO TO 30 20 CONTINUE V2NORM = ZERO GO TO 999 C 30 SCALE = ABS(X(I)) IF (I .LT. P) GO TO 40 V2NORM = SCALE GO TO 999 40 T = ONE IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) C C *** SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE C *** SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE. C *** THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS. C J = I + 1 DO 60 I = J, P XI = ABS(X(I)) IF (XI .GT. SCALE) GO TO 50 R = XI / SCALE IF (R .GT. SQTETA) T = T + R*R GO TO 60 50 R = SCALE / XI IF (R .LE. SQTETA) R = ZERO T = ONE + T * R*R SCALE = XI 60 CONTINUE C V2NORM = SCALE * SQRT(T) 999 RETURN C *** LAST CARD OF V2NORM FOLLOWS *** END *AMEPT1 SUBROUTINE AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBOUTINE PRINTS THE DATA SUMMARY FOR THE NONLINEAR C LEAST SQUARES SUBROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NDIGIT C C ARRAY ARGUMENTS DOUBLE PRECISION + PVT(*),RES(*),SDPVT(*),SDREST(*),Y(*) INTEGER + IPTOUT(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS DOUBLE PRECISION + FPLM INTEGER + I,NMAX C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH CCCCC EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL OBSSM2 C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IPTOUT(NDIGIT) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. C INTEGER NMAX C THE MAXIMUM NUMBER OF ROWS TO BE PRINTED. C DOUBLE PRECISION PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C DOUBLE PRECISION RES(N) C THE RESIDUALS FROM THE FIT. C DOUBLE PRECISION SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C DOUBLE PRECISION SDREST(N) C THE STANDARDIZED RESIDUALS. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. 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 FPLM = D1MACH(2) C CCCCC CALL IPRINT(IPRT) C CCCCC WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2,1100) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2,1101) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2,1000) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2,1001) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2, 1110) CCCCC CALL DPWRST('XXX','BUG ') C NMAX = N IF ((MAX(IPTOUT(3),1).EQ.1) .AND. (N.GE.45)) + NMAX = MIN(N,40) C C PRINT OBSERVATION SUMMARY C CALL OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, 1, NMAX) C IF (NMAX.GE.N) GO TO 200 C DO 195 I = 1, 3 WRITE (IOUNI2, 1150) 195 CONTINUE C C PRINT LAST LINE OF OUTPUT C CALL OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, N, N) C 200 CONTINUE C IF ((IERR.EQ.4)) THEN WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2, 1080) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF ((IERR.GT.0) .AND. (IERR.NE.4)) THEN WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI2,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2, 1090) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI2, 1091) CCCCC CALL DPWRST('XXX','BUG ') ENDIF C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT ( + 4X, 15X, ' -----PREDICTED ----STD DEV OF', 16X, + ' ---STD') 1001 FORMAT ( + 1X, 3HROW, ' -------SERIES --------VALUE', + ' ---PRED VALUE -----RESIDUAL --RES') 1080 FORMAT ( + ' * NC - VALUE NOT COMPUTED BECAUSE', + ' THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.') 1090 FORMAT ( + ' * NC - VALUE NOT COMPUTED BECAUSE CONVERGENCE') 1091 FORMAT ( + 'PROBLEMS PREVENTED THE COVARIANCE MATRIX FROM BEING COMPUTED.') 1100 FORMAT (' RESULTS FROM LEAST SQUARES FIT') 1101 FORMAT ( 1X, 31('-')) 1110 FORMAT (' ') 1150 FORMAT (4X, '.', 4(14X, '.'), 7X, '.') END *DOTPRD DOUBLE PRECISION FUNCTION DOTPRD(P, X, Y) C C LATEST REVISION - 03/15/90 (JRD) C C *** RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + X(*),Y(*) C C LOCAL SCALARS DOUBLE PRECISION + ONE,SQTETA,T,ZERO INTEGER + I C C EXTERNAL FUNCTIONS DOUBLE PRECISION + RMDCON EXTERNAL RMDCON C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C INTEGER P C DOUBLE PRECISION X(*), Y(*) C C INTEGER I C DOUBLE PRECISION ONE, SQTETA, T, ZERO C/+ C DOUBLE PRECISION MAX, ABS C/ C EXTERNAL RMDCON C DOUBLE PRECISION RMDCON 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 *** RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH C *** IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT C *** CAN BE SQUARED WITHOUT UNDERFLOWING. C DATA ONE/1.0D0/, SQTETA/0.0D0/, ZERO/0.0D0/ C DOTPRD = ZERO IF (P .LE. 0) GO TO 999 IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2) DO 20 I = 1, P T = MAX(ABS(X(I)), ABS(Y(I))) IF (T .GT. ONE) GO TO 10 IF (T .LT. SQTETA) GO TO 20 T = (X(I)/SQTETA)*Y(I) IF (ABS(T) .LT. SQTETA) GO TO 20 10 DOTPRD = DOTPRD + X(I)*Y(I) 20 CONTINUE C 999 RETURN C *** LAST CARD OF DOTPRD FOLLOWS *** END *FLTSL SUBROUTINE FLTSL (Y, N, K, H, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE FILTERS THE INPUT SERIES Y USING THE K TERMS C OF H, COPYING THE FILTERED SERIES INTO YF. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DEVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + K,N,NYF C C ARRAY ARGUMENTS DOUBLE PRECISION + H(K),Y(N),YF(N) C C LOCAL SCALARS DOUBLE PRECISION + TEMP INTEGER + I,I1,IHM,IHP,IKMID,IM,IP,J,KHALF,KMID C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION H(K) C THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED. C INTEGER I, IHM, IHP, IKMID, IM, IP C INDEXING VARIABLES. C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C THE NUMBER OF FILTER TERMS. C INTEGER KHALF, KMID C THE HALF LENGTH OF THE FILTER AND THE MIDPOINT OF THE FILTER. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C INTEGER NYF C THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF. C DOUBLE PRECISION TEMP C A TEMPORY STORAGE LOCATION. C DOUBLE PRECISION Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C DOUBLE PRECISION YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. 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 DO 10 I = 1, N YF(I) = Y(I) 10 CONTINUE C NYF = N - (K - 1) C KHALF = (K - 1) / 2 C KMID = KHALF + 1 C DO 30 I = 1, NYF IKMID = I + KHALF TEMP = H(KMID) * YF(IKMID) DO 20 J = 1, KHALF IP = IKMID + J IHP = KMID + J IM = IKMID - J IHM = KMID - J TEMP = TEMP + H(IHP)*YF(IP) + H(IHM)*YF(IM) 20 CONTINUE YF(I) = TEMP 30 CONTINUE C I1 = NYF + 1 C DO 40 I = I1, N YF(I) = 0.0D0 40 CONTINUE RETURN END *LPFLT SUBROUTINE LPFLT (FC, K, HLP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE LOPASS FILTER COEFFICIENTS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + FC INTEGER + K C C ARRAY ARGUMENTS DOUBLE PRECISION + HLP(K) C C LOCAL SCALARS DOUBLE PRECISION + ARG,CON,PI,SUM INTEGER + I,IHM,IHP,KHALF,KMID C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC SIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION ARG, CON C VARIABLES USED IN THE COMPUTATION OF THE LOW PASS FILTER C COEFFICIENTS. C DOUBLE PRECISION FC C THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER. C DOUBLE PRECISION HLP(K) C THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS C ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IHM, IHP C INDEX VARIABLES FOR SYMMETRIC LOCATIONS AROUND THE MIDPOINT C OF THE FILTER. C INTEGER K C THE NUMBER OF TERMS IN THE FILTER. C INTEGER KHALF C THE VALUE OF THE MIDPOINT OF K MINUS 1. C INTEGER KMID C THE MIDPOINT OF THE FILTER. C DOUBLE PRECISION PI C THE VALUE OF PI. C DOUBLE PRECISION SUM C A VALUE USED FOR SUMMING. 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 CALL GETPI(PI) C KMID = (K + 1) / 2 C HLP(KMID) = 1.0D0 C IF (K .EQ. 1) RETURN C HLP(KMID) = 2.0D0 * FC CON = 2.0D0 * PI / K SUM = HLP(KMID) C KHALF = (K - 1) / 2 C DO 10 I = 1, KHALF ARG = I * CON IHP = KMID + I HLP(IHP) = SIN(I * FC * 2.0D0 * PI) * SIN(ARG) / + (I * PI * ARG) IHM = KMID - I HLP(IHM) = HLP(IHP) SUM = SUM + HLP(IHM) + HLP(IHP) 10 CONTINUE DO 20 I = 1, K HLP(I) = HLP(I) / SUM 20 CONTINUE RETURN END *NLERR SUBROUTINE NLERR (ICNVCD, ISKULL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE ERROR FLAG IERR BASED ON THE CONVERGENCE C CODE RETURNED BY NL2. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ICNVCD C C ARRAY ARGUMENTS INTEGER + ISKULL(10) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER ICNVCD C THE CONVERGENCE CODE FROM NL2. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C 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 INITIALIZE MESSAGE INDICATOR VARIABLE C DO 5 I = 1, 10 ISKULL(I) = 0 5 CONTINUE C C SET ERROR FLAG C GO TO (10, 10, 20, 20, 20, 20, 40, 50, 60, 60, 10, 30, 10, 10, + 10), ICNVCD C C BAD VALUE C 10 IERR = 1 RETURN C C ACCEPTABLE STOPPING CONDITION C 20 IERR = 0 RETURN C C INITIAL VARIANCE COMPUTATION OVERFLOWS C 30 IERR = 2 ISKULL(2) = 1 RETURN C C SINGULAR CONVERGENCE C 40 IERR = 3 ISKULL(3) = 1 RETURN C C FALSE CONVERGENCE C 50 IERR = 5 ISKULL(5) = 1 RETURN C C ITERATION OR FUNCTION EVALUATION LIMIT C 60 IERR = 6 ISKULL(6) = 1 RETURN C END *RPTMUL SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z) C C *** FUNC = 1... SET Y = RMAT * (PERM**T) * X. C *** FUNC = 2... SET Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X. C *** FUNC = 3... SET Y = PERM * (RMAT**T) X. C C C *** PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR. C *** RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE C *** IS STORED IN J AND WHOSE DIAGONAL IS STORED IN RD. C *** Z IS A SCRATCH VECTOR. C *** X AND Y MAY SHARE STORAGE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + FUNC,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + J(NN,P),RD(P),X(P),Y(P),Z(P) INTEGER + IPIVOT(P) C C LOCAL SCALARS DOUBLE PRECISION + ZK INTEGER + I,IM1,K,KM1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD EXTERNAL DOTPRD 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 C----------------------------------------------------------------------- C IF (FUNC .GT. 2) GO TO 50 C C *** FIRST SET Z = (PERM**T) * X *** C DO 10 I = 1, P K = IPIVOT(I) Z(I) = X(K) 10 CONTINUE C C *** NOW SET Y = RMAT * Z *** C Y(1) = Z(1) * RD(1) IF (P .LE. 1) GO TO 40 DO 30 K = 2, P KM1 = K - 1 ZK = Z(K) DO 20 I = 1, KM1 20 Y(I) = Y(I) + J(I,K)*ZK Y(K) = ZK*RD(K) 30 CONTINUE C 40 IF (FUNC .LE. 1) GO TO 999 GO TO 70 C 50 DO 60 I = 1, P 60 Y(I) = X(I) C C *** SET Z = (RMAT**T) * Y *** C 70 Z(1) = Y(1) * RD(1) IF (P .EQ. 1) GO TO 90 DO 80 I = 2, P IM1 = I - 1 Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y) 80 CONTINUE C C *** NOW SET Y = PERM * Z *** C 90 DO 100 I = 1, P K = IPIVOT(I) Y(K) = Z(I) 100 CONTINUE C 999 RETURN C *** LAST CARD OF RPTMUL FOLLOWS *** END *VAXPY SUBROUTINE VAXPY(P, W, A, X, Y) C C *** SET W = A*X + Y -- W, X, Y = P-VECTORS, A = SCALAR *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + A INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + W(*),X(*),Y(*) C C LOCAL SCALARS INTEGER + I 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 DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN END *AMESTP SUBROUTINE AMESTP(XM, N, M, IXM, MDL, PAR, NPAR, STP, + EXMPT, NETA, SCALE, LSCALE, NPRT, HDR, PAGE, WIDE, ISUBHD, + HLFRPT, PRTFXD, IFIXED, LIFIXD, STPOUT, PVPAD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CONTROLS THE STEP SIZE SELECTION PROCESS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + EXMPT INTEGER + ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,PVPAD LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(*),SCALE(*),STP(*),XM(IXM,*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL HDR,MDL,STPOUT C C SCALARS IN COMMON DOUBLE PRECISION + Q INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS DOUBLE PRECISION + ETA,EXM,FPLRS,SCL,TAU INTEGER + CD,FD,FDLAST,FDSAVE,IFAILJ,IFIXD,IFP,ITEMP,J,MXFAIL,NALL0, + NDD,NDGT1,NEXMPT,NFAIL,NFAILJ,PARTMP,PV,PVMCD,PVNEW,PVPCD, + PVSTP,PVTEMP LOGICAL + HEAD C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS CCCCC DOUBLE PRECISION CCCCC+ D1MACH INTEGER + STKGET,STKST CCCCC EXTERNAL D1MACH,STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN C C INTRINSIC FUNCTIONS INTRINSIC ABS,INT,LOG10,MAX,MIN C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 COMMON /NOTOPT/Q C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CD C THE STARTING LOCATION IN THE WORK AREA OF C THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE MODEL. C DOUBLE PRECISION EXM C THE PROPORTION OF OBSERVATIONS ACTUALLY USED FOR WHICH THE C COMPUTED NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE C EXEMPTED FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. C DOUBLE PRECISION EXMPT C THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED C NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXEMPTED C FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. C INTEGER FD C THE STARTING LOCATION IN THE WORK AREA OF C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C INTEGER FDLAST C THE STARTING LOCATION IN THE WORK AREA OF C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C FOR THE LAST STEP SIZE TRIED. C INTEGER FDSAVE C THE STARTING LOCATION IN THE WORK AREA OF C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C FOR THE BEST STEP SIZE TRIED SO FAR. C DOUBLE PRECISION FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C EXTERNAL HDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE C CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE C INITIAL SUMMARY (TRUE) OR NOT (FALSE). C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFAILJ C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY OF INDICATOR VARIABLES DESIGNATING WHETHER C THE SETP SIZE SELECTED WAS SATISFACOTRY FOR A GIVEN C OBSERVATION AND THE JTH PARAMETER. C INTEGER IFIXD C THE STARTING LOCATION IN /CSTAK/ OF VECTOR IFIXD CONTAINING C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IFIXED(LIFIXD) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IFP C AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE, C WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER ITEMP C THE STARTING LOCATION IN ISTAK FOR C A TEMPORARY STORAGE VECTOR. C INTEGER IXM C THE FIRST DIMENSION OF MATRIX XM. C INTEGER J C AN INDEX VARIABLE. C INTEGER LIFIXD C THE DIMENSION OF VECTOR IFIXED. C INTEGER LSCALE C THE DIMENSION OF VECTOR SCALE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C EXTERNAL MDL C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES. C INTEGER MXFAIL C THE MAXIMUM NUMBER OF FAILURES FOR ANY PARAMETER. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C NUMBER OF STACK ALLOCATIONS OUTSTANDING. C INTEGER NDD C THE NUMBER OF DECIMAL DIGITS CARRIED FOR A SINGLE C PRECISION DOUBLE PRECISION NUMBER. C INTEGER NDGT1 C THE NUMBER OF RELIABLE DIGITS IN THE MODEL USED, EITHER C SET TO THE USER SUPPLIED VALUE OF NETA, OR COMPUTED C BY ETAMDL. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C INTEGER NEXMPT C THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE C DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP C SIZE STILL BE CONSIDERED OK. C INTEGER NFAIL C THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP SIZE C FOR THE PARAMETER DOES NOT MEET THE CRITERIA. C INTEGER NFAILJ C THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP SIZE C FOR THE JTH PARAMETER DOES NOT MEET THE CRITERIA. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARTMP C THE STARTING LOCATION IN THE WORK AREA OF C THE MODIFIED MODEL PARAMETERS C LOGICAL PRTFXD C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE C OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE C PARAMETER IS FIXED (TRUE) OR NOT (FALSE). C INTEGER PV C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C INTEGER PVMCD C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C INTEGER PVNEW C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPNEW. C INTEGER PVPAD C ADDITIONAL WORKSPACE NEEDED IN PV FOR THE EVALUATION OF THE C MODEL. C INTEGER PVPCD C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD. C INTEGER PVSTP C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STP(J). C INTEGER PVTEMP C THE STARTING LOCATION IN THE WORK AREA OF C A TEMPORY STORAGE LOCATION FOR PREDICTED VALUES BEGINS. C DOUBLE PRECISION Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C DOUBLE PRECISION SCL C THE ACTUAL TYPICAL SIZE USED. C DOUBLE PRECISION STP(NPAR) C THE SELECTED STEP SIZES. C EXTERNAL STPOUT C THE ROUTINE FOR PRINTING THE OUTPUT. C DOUBLE PRECISION TAU C THE AGREEMENT TOLERANCE. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE. C 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 NALL0 = STKST(1) C FPLRS = D1MACH(4) IFP = 4 C C SET PRINT CONTROLS C HEAD = .TRUE. C C SUBDIVIDE WORK AREA C IFIXD = STKGET(NPAR, 2) ITEMP = STKGET(N, 2) IFAILJ = STKGET(N, 2) NFAIL = STKGET(NPAR, 2) C CD = STKGET(N, IFP) FD = STKGET(N, IFP) FDLAST = STKGET(N, IFP) FDSAVE = STKGET(N, IFP) PV = STKGET(N+PVPAD, IFP) PVMCD = STKGET(N+PVPAD, IFP) PVNEW = STKGET(N+PVPAD, IFP) PVPCD = STKGET(N+PVPAD, IFP) PVSTP = STKGET(N+PVPAD, IFP) PVTEMP = STKGET(N+PVPAD, IFP) C IF (IERR .EQ. 1) RETURN C PARTMP = CD C C SET UP IFIXD C IF (IFIXED(1).LT.0) CALL SETIV(ISTAK(IFIXD), NPAR, 0) IF (IFIXED(1).GE.0) CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1) C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C NDD = INT(-LOG10(FPLRS)) C IF ((NETA .GE. 2) .AND. (NETA .LE. NDD)) THEN ETA = 10.0D0 ** (-NETA) NDGT1 = NETA ELSE CALL ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NDGT1, + RSTAK(PARTMP), RSTAK(PVTEMP), 0) END IF C TAU = MIN(ETA**0.25D0, 0.01D0) C EXM = EXMPT IF ((EXM.LT.0.0D0) .OR. (EXM.GT.1.0D0)) EXM = 0.10D0 NEXMPT = INT(EXM * N) IF (EXM .NE. 0.0D0) NEXMPT = MAX(NEXMPT, 1) C C COMPUTE PREDICTED VALUES OF THE MODEL USING THE INPUT PARAMETER C ESTIMATES C CALL MDL(PAR, NPAR, XM, N, M, IXM, RSTAK(PV)) C MXFAIL = 0 NFAILJ = NFAIL C DO 120 J = 1, NPAR C IF (SCALE(1) .LE. 0.0D0) THEN IF (PAR(J) .EQ. 0.0D0) THEN SCL = 1.0D0 ELSE SCL = ABS(PAR(J)) END IF ELSE SCL = SCALE(J) END IF C CALL STPMN(J, XM, N, M, IXM, MDL, PAR, NPAR, NEXMPT, + ETA, TAU, SCL, STP(J), ISTAK(NFAILJ), ISTAK(IFAILJ), + RSTAK(CD), ISTAK(ITEMP), RSTAK(FD), RSTAK(FDLAST), + RSTAK(FDSAVE), RSTAK(PV), RSTAK(PVMCD), RSTAK(PVNEW), + RSTAK(PVPCD), RSTAK(PVSTP), RSTAK(PVTEMP)) C C COMPUTE THE MAXIMUM NUMBER OF FAILURES FOR ANY PARAMETER C MXFAIL = MAX(ISTAK(NFAILJ), MXFAIL) C C PRINT RESULTS IF THEY ARE DESIRED C IF ((NPRT.NE.0) .OR. (MXFAIL.GT.NEXMPT)) + CALL STPOUT(HEAD, N, EXM, NEXMPT, NDGT1, J, PAR, NPAR, + STP, ISTAK(NFAIL), ISTAK(IFAILJ), SCALE, LSCALE, HDR, + PAGE, WIDE, ISUBHD, NPRT, PRTFXD, ISTAK(IFIXD)) C NFAILJ = NFAILJ + 1 C 120 CONTINUE C HLFRPT = .FALSE. IF ((NPRT.NE.0) .OR. (MXFAIL.GT.NEXMPT)) HLFRPT = .TRUE. C IF (MXFAIL.GT.NEXMPT) IERR = 2 C CALL STKCLR(NALL0) C RETURN C END *DRV SUBROUTINE DRV(PAR, NPAR, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DUMMY DERIVATIVE FUNCTION FOR NLS FAMILY C C WRITTEN BY - LINDA L. MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,M,N,NPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + D(N,NPAR),PAR(NPAR),XM(IXM,M) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION D(N,NPAR) C THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER C INTEGER IXM C ACTUAL FIRST DIMENSION OF XM C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLESC C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NPAR C THE NUMBER OF PARAMETERS C DOUBLE PRECISION PAR(NPAR) C MODEL PARAMETERS C DOUBLE PRECISION XM(IXM,M) C MODEL INDEPENDENT VARIABLE C C 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 RETURN C END *GETPI SUBROUTINE GETPI(PI) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE VALUE OF PI. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + PI C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION PI C THE VALUE OF PI. C PI = 3.141592653589793238462643383279D0 RETURN END *LSQRTZ SUBROUTINE LSQRTZ(N1, N, L, A, IRC) C C ROUTINE RENAMED LSQRTZ FROM LSQRT FOR DATAPLOT TO C AVOID NAME CONFLICT WITH A PREVIOUSLY EXISTING ROUTINE. C C LATEST REVISION - 03/15/90 (JRD) C C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE). C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE -- C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IRC,N,N1 C C ARRAY ARGUMENTS DOUBLE PRECISION + A(1),L(1) C C LOCAL SCALARS DOUBLE PRECISION + T,TD,ZERO INTEGER + I,I0,IJ,IK,IM1,J,J0,JK,JM1,K C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C *** PARAMETERS *** C C INTEGER N1, N, IRC C DOUBLE PRECISION L(1), A(1) C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2) C C *** LOCAL VARIABLES *** C C INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K C DOUBLE PRECISION T, TD, 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 ZERO/0.0D0/ C C *** BODY *** C I0 = N1 * (N1 - 1) / 2 DO 50 I = N1, N TD = ZERO IF (I .EQ. 1) GO TO 40 J0 = 0 IM1 = I - 1 DO 30 J = 1, IM1 T = ZERO IF (J .EQ. 1) GO TO 20 JM1 = J - 1 DO 10 K = 1, JM1 IK = I0 + K JK = J0 + K T = T + L(IK)*L(JK) 10 CONTINUE 20 IJ = I0 + J J0 = J0 + J T = (A(IJ) - T) / L(J0) L(IJ) = T TD = TD + T*T 30 CONTINUE 40 I0 = I0 + I T = A(I0) - TD IF (T .LE. ZERO) GO TO 60 L(I0) = SQRT(T) 50 CONTINUE C IRC = 0 GO TO 999 C 60 L(I0) = T IRC = I C 999 RETURN C C *** LAST CARD OF LSQRTZ *** END *NLINIT SUBROUTINE NLINIT (N, IFIXD, PAR, NPAR, PARE, NPARE, MIT, + STOPSS, STOPP, SCALE, LSCALE, DELTA, IVAPRX, APRXDV, IVCVPT, + IWORK, IIWORK, RWORK, IRWORK, SCL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PERFORMS INITIALIZATION FOR THE NONLINEAR C LEAST SQUARES ROUTINES. C C REFERENCES C C DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1979), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, (BEING REVISED). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + DELTA,STOPP,STOPSS INTEGER + IIWORK,IRWORK,IVAPRX,IVCVPT,LSCALE,MIT,N,NPAR,NPARE,SCL LOGICAL + APRXDV C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),PARE(NPAR),RWORK(IRWORK),SCALE(LSCALE) INTEGER + IFIXD(NPAR),IWORK(IIWORK) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + AFCTOL,CNVCOD,COVPRT,COVREQ,DINIT,DTYPE,ISCL,J,LMAX0, + MXFCAL,MXITER,NITER,OUTLEV,PRUNIT,RFCTOL,SCLJ,SOLPRT, + STATPR,X0PRT,XCTOL C C EXTERNAL FUNCTIONS DOUBLE PRECISION + RMDCON EXTERNAL RMDCON C C EXTERNAL SUBROUTINES EXTERNAL DFAULT,NLSPK C C INTRINSIC FUNCTIONS INTRINSIC ABS,IABS,MAX C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER AFCTOL C THE LOCATION IN RWORK OF THE ABSOLUTE CONVERGENCE TOLERANCE. C LOGICAL APRXDV C THE VARIABLE USED TO INDICATE WHETHER NUMERICAL C APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT C (FALSE). C INTEGER CNVCOD C A VALUE USED TO CONTROL THE PRINTING OF ITERATION REPORTS. C INTEGER COVPRT C THE LOCATION IN IWORK OF THE VARIABLE USED TO INDICATE WHETHER C THE COVARIANCE MATRIX IS TO BE PRINTED BY THE NL2 CODE, WHERE C IWORK(COVPRT) = 0 INDICATES IT IS NOT. C INTEGER COVREQ C THE LOCATION IN IWORK OF THE VARIABLE USED TO INDICATE HOW C THE COVARIANCE MATRIX IS TO BE COMPUTED BY THE NL2 CODE, WHERE C IWORK(COVREQ) = 3 INDICATES THE COVARIANCE MATRIX IS TO BE COMP C AS THE RESIDUAL VARIANCE TIMES THE INVERSE OF THE JACOBIAN MATR C TRANSPOSED TIMES THE JACOBIAN MATRIX . C DOUBLE PRECISION DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C INTEGER DINIT C THE LOCATION IN IWORK OF THE VALUE USED TO INDICATE C WHETHER OR NOT USER SUPPLIED SCALE VALUES ARE TO BE C USED, WHERE THE (NL2) DEFAULT VALUE OF RWORK(DINIT) = 0.0D0 C INIDCATES NO, AND THE VALUE RWORK(DINIT) = -1.0D0 INDICATES C YES. C INTEGER DTYPE C THE LOCATION IN IWORK OF THE VALUE INDICATING WHETHER THE C SCALE VALUES HAVE BEEN SUPPLIED BY THE USER (IWORK(DTYPE) .LE. C OR THE DEFAULT VALUES ARE TO BE USED (IWORK(DTYPE) .GT. 0). C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IIWORK C THE DIMENSION OF THE INTEGER WORK VECTOR IWORK. C INTEGER IRWORK C THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK. C INTEGER ISCL C THE LOCATION IN IWORK INDICATING THE STARTING LOCATION IN C RWORK OF THE SCALE VECTOR. C INTEGER IVAPRX C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE C IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED C IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED C DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE C IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED C INTEGER IVCVPT C AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE C VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE C IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C INTEGER IWORK(IIWORK) C THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER LMAX0 C THE LOCATION IN RWORK OF THE VALUE INDICATING THE C MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MXFCAL C THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE C MAXIMUM NUMBER OF FUNCTION CALLS ALLOWED, EXCLUDING C CALLS NECESSARY TO COMPUTE THE DERIVATIVES AND VARIANCE C COVARIANCE MATRIX. C INTEGER MXITER C THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE C MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NITER C THE LOCATION IN IWORK OF THE NUMBER OF THE CURRENT ITERATION. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF UNKNOWN PARAMETERS TO BE OPTIMIZED. C INTEGER OUTLEV C THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL THE C PRINTING OF THE ITERATION REPORTS BY NL2. C DOUBLE PRECISION PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C DOUBLE PRECISION PARE(NPAR) C THE CURRENT ESTIMATES OF THE UNKNOWN PARAMETERS, BUT ONLY C THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED). C INTEGER PRUNIT C THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL C THE PRINT UNIT USED BY NL2. IWORK(PRUNIT) = 0 MEANS C DONT PRINT ANYTHING. C INTEGER RFCTOL C THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE C TOLERANCE. C DOUBLE PRECISION RWORK(IRWORK) C THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES. C DOUBLE PRECISION SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C INTEGER SCL C THE INDEX IN RWORK OF THE 1ST VALUE OF THE USER SUPPLIED SCALE C VALUE. C INTEGER SCLJ C THE INDEX IN RWORK OF THE JTH VALUE OF THE USER SUPPLIED SCALE C VALUE. C INTEGER SOLPRT C THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTING C BY NL2 OF THE FINAL SOLUTION. C INTEGER STATPR C THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTING C BY NL2 OF SUMMARY STATISTICS. C DOUBLE PRECISION STOPP C THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED C RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR C DOUBLE PRECISION STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C INTEGER XCTOL C THE LOCATION IN RSTAK/DSTAK OF THE P CONVERGENCE TOLERANCE. C INTEGER X0PRT C THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTIN C BY NL2 OF THE INITIAL PARAMETER AND SCALE VALUES. C 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 IWORK SUBSCRIPT VALUES C DATA CNVCOD /34/, COVPRT /14/, COVREQ /15/, DINIT /38/, DTYPE + /16/, ISCL /27/, MXFCAL /17/, MXITER /18/, + NITER /31/, OUTLEV /19/, PRUNIT /21/, SOLPRT /22/, STATPR + /23/, X0PRT /24/ C C RWORK SUBSCRIPT VALUES C DATA AFCTOL /31/, LMAX0 /35/, RFCTOL /32/, XCTOL /33/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C C PACK PARAMETERS INTO PARE C CALL NLSPK(PAR, IFIXD, NPAR, PARE, NPAR) C C SET NL2SOL DEFAULT VALUES C CALL DFAULT(IWORK, RWORK) C C SET NON NL2 DEFAULT VALUES C IWORK(MXITER) = MIT IF (MIT.LE.0) IWORK(MXITER) = 21 C IWORK(MXFCAL) = 2*IWORK(MXITER) C C SET STOPPING CRITERION C RWORK(AFCTOL) = RMDCON(1) IF ((STOPSS.GE.RMDCON(3)) .AND. (STOPSS.LE.0.1)) RWORK(RFCTOL) = + STOPSS C IF ((STOPP.GE.0.0D0) .AND. (STOPP.LE.1.0D0)) + RWORK(XCTOL) = STOPP C C SET SCALE VALUES C SCL = 94 + 2*N + NPARE*(3*NPARE+31)/2 IWORK(ISCL) = SCL IF (SCALE(1).GT.0.0D0) GO TO 40 C IWORK(DTYPE) = 1 C C INITIALIZE SCALE VALUES FOR FIRST ITERATION C SCLJ = SCL - 1 DO 30 J=1,NPAR IF (IFIXD(J).NE.0) GO TO 30 SCLJ = SCLJ + 1 IF (PAR(J).EQ.0.0D0) RWORK(SCLJ) = 1.0D0 IF (PAR(J).NE.0.0D0) RWORK(SCLJ) = 1.0D0/ABS(PAR(J)) 30 CONTINUE C GO TO 60 C 40 IWORK(DTYPE) = 0 RWORK(DINIT) = -1.0D0 SCLJ = SCL - 1 DO 50 J=1,NPAR IF (IFIXD(J).NE.0) GO TO 50 SCLJ = SCLJ + 1 RWORK(SCLJ) = 1.0D0/MAX(ABS(SCALE(J)),ABS(PAR(J))) 50 CONTINUE C 60 IF (DELTA.LE.0.0D0) RWORK(LMAX0) = 100.0D0 IF (DELTA.GT.0.0D0) RWORK(LMAX0) = DELTA C C SET NL2 COVARIANCE COMPUTATION CONTROL PARAMETER C IF ((IVAPRX.LE.1) .OR. (IVAPRX.EQ.4) .OR. (IVAPRX.GE.7)) + IWORK(COVREQ) = 3 IF ((IVAPRX.EQ.2) .OR. (IVAPRX.EQ.5)) IWORK(COVREQ) = 2 IF ((IVAPRX.EQ.3) .OR. (IVAPRX.EQ.6)) IWORK(COVREQ) = 1 IF ((IVAPRX.GE.4) .AND. (IVAPRX.LE.6)) + IWORK(COVREQ) = -IWORK(COVREQ) IF (APRXDV) IWORK(COVREQ) = -IABS(IWORK(COVREQ)) IF ((IVAPRX.LE.1) .OR. (IVAPRX.EQ.4) .OR. (IVAPRX.GE.7)) + IVCVPT = 1 IF ((IVAPRX.EQ.2) .OR. (IVAPRX.EQ.5)) IVCVPT = 2 IF ((IVAPRX.EQ.3) .OR. (IVAPRX.EQ.6)) IVCVPT = 3 C C INITIALIZE THE ITERATION COUNTER C IWORK(NITER) = 0 C C SET NL2 PRINT CONTROL PARAMETERS C IWORK(CNVCOD) = 0 IWORK(COVPRT) = 0 IWORK(OUTLEV) = 0 IWORK(PRUNIT) = 0 IWORK(SOLPRT) = 0 IWORK(STATPR) = 0 IWORK(X0PRT) = 0 C RETURN C END *SETIV SUBROUTINE SETIV(VECTOR, N, VALUE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE FIRST N ELEMENTS OF AN INTEGER VECTOR C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 7, 1981 C ADAPTED FROM SETRV, WRITTEN BY LINDA L. MITCHELL C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,VALUE C C ARRAY ARGUMENTS INTEGER + VECTOR(N) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C * C INTEGER N C NUMBER OF ELEMENTS TO SET C INTEGER VALUE C VALUE TO WHICH THE ELEMENTS ARE TO BE SET C INTEGER VECTOR(N) C VECTOR WHOSE FIRST N ELEMENTS ARE TO BE SET. C 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 DO 10 I=1,N VECTOR(I) = VALUE 10 CONTINUE C RETURN C END *VCOPY SUBROUTINE VCOPY(P, Y, X) C C *** SET Y = X, WHERE X AND Y ARE P-VECTORS *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + X(*),Y(*) C C LOCAL SCALARS INTEGER + I 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 DO 10 I = 1, P 10 Y(I) = X(I) RETURN END *AMFCNT SUBROUTINE AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, + NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR FORECASTING USING C ARIMA MODELS. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFCST,LDSTAK,N,NFAC,NFCST,NFCSTO,NPAR,NPRT LOGICAL + SAVE C C ARRAY ARGUMENTS DOUBLE PRECISION + FCST(*),FCSTSD(*),PAR(*),Y(*) INTEGER + IFCSTO(*),MSPEC(4,*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA, + NRESTS,PARAR,PARDF,PARMA,T,TEMP C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + F,FSD,IFP,IS,LDSMIN,NALL0,PV LOGICAL + PAGE,WIDE C C LOCAL ARRAYS DOUBLE PRECISION + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL AMFER,AMFMN,BACKOP,CPYVII,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA, + NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER F C THE STARTING LOCATION IN THE WORK VECTOR FOR C THE FORECASTS. C DOUBLE PRECISION FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C DOUBLE PRECISION FCSTSD(NFCST) C THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS. C INTEGER FSD C THE STARTING LOCATION IN THE WORK VECTOR FOR C THE STANDARD DEVIATIONS OF THE FORECASTS. C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER IFCST C THE FIRST DIMENSION OF THE ARRAY FCST. C INTEGER IFCSTO(NFCSTO) C THE INDICES OF THE ORIGINS FOR THE FORECASTS. C INTEGER IFP C AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE, C WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE. C INTEGER IS C A VALUE USED TO DETERMINE THE AMOUNT OF WORK SPACE NEEDED C BASED ON WHETHER STEP SIZES ARE INPUT OR ARE TO BE CALCULATED. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER MBO C THE MAXIMUM BACK ORDER OPERATOR. C INTEGER MBOL C THE MAXIMUM BACK ORDER ON THE LEFT C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER MSPECT C THE STARTING LOCATION IN THE WORK SPACE FOR C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C NUMBER OF STACK ALLOCATIONS OUTSTANDING. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFACT C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFCST C THE NUMBER OF FORECASTS. C INTEGER NFCSTO C THE NUMBER OF THE ORIGINS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARAR C THE NUMBER OF AUTOREGRESSIVE PARAMETERS C INTEGER NPARDF C THE ORDER OF THE EXPANDED DIFFERENCE FILTER. C INTEGER NPARMA C THE LENGTH OF THE VECTOR PARMA C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C INTEGER PARAR C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE AUTOREGRESSIVE PARAMETERS C INTEGER PARDF C THE STARTING LOCATION IN THE WORK SPACE FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS C INTEGER PARMA C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE MOVING AVERAGE PARAMETERS C INTEGER PV C THE STARTING LOCATION IN THE WORK ARRAY FOR C THE PREDICTED VALUES C INTEGER NRESTS C THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED. C DOUBLE PRECISION RSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C INTEGER T C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR. C INTEGER TEMP C THE STARTING LOCATION IN THE WORK ARRAY FOR C A TEMPORARY WORK VECTOR C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C 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 SET VARIOUS PROGRAM VALUES C WIDE = .TRUE. PAGE = .FALSE. C C COMPUTE BACK OPERATORS C CALL BACKOP(MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR) C C SET UP FOR ERROR CHECKING C IERR = 0 IS = 0 C CALL LDSCMP(8, 0, 4*NFAC, + 0, 0, 0, 'D', 5*MBO + 2*NFCST + N + MBO + 101, LDSMIN) C CALL AMFER(NMSUB, N, NPAR, LDSTAK, LDSMIN, SAVE, MSPEC, NFAC, + IFCST, NFCST) C IF (IERR.EQ.0) THEN C CALL STKSET(LDSTAK, 4) C C SUBDIVIDE WORKSPACE FOR STEP SIZES C NALL0 = STKST(1) C IFP = 4 C PARDF = STKGET(MBO, IFP) PARAR = STKGET(MBO, IFP) PARMA = STKGET(MBO, IFP) T = STKGET(2*MBO, IFP) C TEMP = T + MBO C NFACT = NFAC MSPECT = STKGET(4*NFAC, 2) F = STKGET(NFCST, IFP) FSD = STKGET(NFCST, IFP) C C SET UP FOR MODEL C NRESTS = MBO + 101 + N PV = STKGET(NRESTS, IFP) C CALL CPYVII(NFAC, MSPEC(1,1), 4, ISTAK(MSPECT), 1) CALL CPYVII(NFAC, MSPEC(2,1), 4, ISTAK(MSPECT+NFAC), 1) CALL CPYVII(NFAC, MSPEC(3,1), 4, ISTAK(MSPECT+2*NFAC), 1) CALL CPYVII(NFAC, MSPEC(4,1), 4, ISTAK(MSPECT+3*NFAC), 1) C C CALL MAIN ROUTINE FOR COMPUTING AND PRINTING FORECASTS C CALL AMFMN (PAR, RSTAK(PV), Y, NPAR, N, NFAC, ISTAK(MSPECT), + RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR), + RSTAK(PARMA), MBO, MBOL, N-NRESTS+1, N, NPRT, SAVE, + NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD, RSTAK(F), + RSTAK(FSD), NPARAR, NPARMA) END IF C CALL STKCLR(NALL0) C RETURN C END *DUPDAT SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V) C C LATEST REVISION - 03/15/90 (JRD) C C *** UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2) *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NN,P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),J(NN,P),V(1) INTEGER + IV(1) C C LOCAL SCALARS DOUBLE PRECISION + SII,T,VDFAC,ZERO INTEGER + D0,DFAC,DTYPE,I,JTOL0,JTOLI,NITER,S,S1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + V2NORM EXTERNAL V2NORM C C INTRINSIC FUNCTIONS INTRINSIC MAX,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER IV(1), N, NN, P C DOUBLE PRECISION D(P), J(NN,P), V(1) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C C INTEGER D0, I, JTOLI, S1 C DOUBLE PRECISION SII, T, VDFAC C C *** CONSTANTS *** C DOUBLE PRECISION ZERO C C/ C *** EXTERNAL FUNCTION *** C C EXTERNAL V2NORM C DOUBLE PRECISION V2NORM 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 *** SUBSCRIPTS FOR IV AND V *** C C INTEGER DFAC, DTYPE, JTOL0, NITER, S DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/ C DATA ZERO/0.0D0/ C C----------------------------------------------------------------------- C I = IV(DTYPE) IF (I .EQ. 1) GO TO 20 IF (IV(NITER) .GT. 0) GO TO 999 C 20 VDFAC = V(DFAC) D0 = JTOL0 + P S1 = IV(S) - 1 DO 30 I = 1, P S1 = S1 + I SII = V(S1) T = V2NORM(N, J(1,I)) IF (SII .GT. ZERO) T = SQRT(T*T + SII) JTOLI = JTOL0 + I D0 = D0 + 1 IF (T .LT. V(JTOLI)) T = MAX(V(D0), V(JTOLI)) D(I) = MAX(VDFAC*D(I), T) 30 CONTINUE C 999 RETURN C *** LAST CARD OF DUPDAT FOLLOWS *** END *GMEAN SUBROUTINE GMEAN(Y, N, YMEAN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE GEOMETRIC MEAN OF A SERIES, ASSUMING C ALL VALUES IN Y ARE NON-ZERO. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + YMEAN INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + Y(N) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC EXP,LOG C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES C DOUBLE PRECISION Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C DOUBLE PRECISION YMEAN C THE GEOMETRIC MEAN OF THE OBSERVED SERIES 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 YMEAN = 0.0D0 DO 10 I = 1, N YMEAN = YMEAN + LOG(Y(I)) 10 CONTINUE YMEAN = EXP(YMEAN/N) RETURN END *LSTVCF SUBROUTINE LSTVCF(N, VEC, LMASK, MASK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE FIRST N ELEMENTS OF THE VECTOR C VEC. THE I TH ELEMENT OF VEC IS IDENTIFIED WITH THE INDEX C OF THE I TH ZERO ELEMENT OF MASK. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C PATTERNED AFTER LSTVEC OF JUNE 7, 1982. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LMASK,N C C ARRAY ARGUMENTS DOUBLE PRECISION + VEC(N) INTEGER + MASK(LMASK) C C LOCAL SCALARS INTEGER + I,IMASK,IMAX,IMIN,INDEX,J,JMAX,NPERL C C LOCAL ARRAYS INTEGER + INDW(10) C C EXTERNAL FUNCTIONS INTEGER + INPERL EXTERNAL INPERL C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER IMASK C INDEX IN MASK. C INTEGER IMAX, IMIN C THE LARGEST AND SMALLEST INDICES IN VEC OF THE ELEMENTS TO BE C PRINTED. C INTEGER INDEX C THE INDEX OF THE VALUE TO BE PRINTED. C INTEGER INDW(10) C A WORK VECTOR FOR THE INDICES TO BE PRINTED FOR VEC. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER JMAX C INDEX IN INDW OF THE LARGEST INDEX TO BE PRINTED FOR VEC. C INTEGER LMASK C THE LENGTH OF MASK. LMASK .GE. N. C INTEGER MASK(LMASK) C MASK VECTOR FOR VEC. THE INDEX OF THE ITH ELEMENT OF MASK C EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF THE ITH ELEMENT C OF VEC. C INTEGER N C THE NUMBER OF VALUES TO BE PRINTED IN THE INPUT VECTOR. C INTEGER NPERL C THE NUMBER OF VALUES TO BE PRINTED PER LINE. C DOUBLE PRECISION VEC(N) C THE VECTOR OF VALUES TO BE PRINTED. C C COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 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 CCCCC CALL IPRINT(IPRT) C NPERL = INPERL(0) C NOTE - INPERL(0) IS ASSUMED TO BE AT MOST 10.0D0 IF GREATER, C INCREASE THE DIMENSION OF INDW. C C IMASK = 0 DO 30 I = 1, N, NPERL IMIN = I IMAX = MIN(I+NPERL-1, N) JMAX = MIN(N - IMIN + 1, NPERL) DO 20 J = 1, JMAX 10 IF (IMASK .GE. LMASK) GO TO 40 IMASK = IMASK + 1 IF (MASK(IMASK) .NE. 0) GO TO 10 INDW(J) = IMASK 20 CONTINUE WRITE(IOUNI3, 1010) (INDW(INDEX), INDEX = 1, JMAX) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3, 1020) (VEC(INDEX), INDEX = IMIN, IMAX) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') 30 CONTINUE C RETURN C 40 CONTINUE WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3, 1030) CCCCC CALL DPWRST('XXX','BUG ') RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1010 FORMAT(10X, 'INDEX', I5, 6I15) 1020 FORMAT(10X, 'VALUE', 7(1X, G14.7)) 1030 FORMAT (' ERROR IN STARPAC. LSTVEC TRIED TO ACCESS MORE', + ' ELEMENTS THAN EXIST IN MASK.') C END *NLITRP SUBROUTINE NLITRP(NLHDR, HEAD, PAGE, WIDE, IPTOUT, NPAR, NNZW, + IWORK, IIWORK, RWORK, IRWORK, IFIXD, PARE, NPARE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE ITERATION REPORTS FOR THE C NONLINEAR LEAST SQUARES REGRESSION SUBROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IIWORK,IPTOUT,IRWORK,NNZW,NPAR,NPARE LOGICAL + HEAD,PAGE,WIDE C C ARRAY ARGUMENTS DOUBLE PRECISION + PARE(NPAR),RWORK(IRWORK) INTEGER + IFIXD(NPAR),IWORK(IIWORK) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C LOCAL SCALARS DOUBLE PRECISION + RSD,RSS,RSSC,RSSPC INTEGER + DST0,F,F0,FDIF,ICASE,ISUBHD,MXITER,NFCALL,NITER, + NREDUC,PREDUC,RELDX,STPPAR CHARACTER + LETTRN*1,LETTRY*1 C C LOCAL ARRAYS CHARACTER + ISCHKD(2)*1 C C EXTERNAL SUBROUTINES EXTERNAL LSTVCF C C INTRINSIC FUNCTIONS INTRINSIC MOD,DBLE,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER DST0 C THE LOCATION IN RWORK OF THE VALUE OF THE 2 NORM OF D TIMES C THE NEWTON STEP. C INTEGER F C THE LOCATION IN RWORK OF THE VALUE OF HALF THE RESIDUAL C SUM OF SQUARES AT THE CURRENT PARAMETER VALUES. C INTEGER FDIF C THE LOCATION IN RWORK OF THE DIFFERENCE BETWEEN THE C RESIDUAL SUM OF SQUARES AT THE BEGINNING AND END OF THE C CURRENT ITERATION. C INTEGER F0 C THE LOCATION IN RWORK OF THE VALUE OF HALF THE RESIDUAL C VARIANCE AT THE BEGINNING OF THE CURRENT ITERATION. C LOGICAL HEAD C THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE C PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE) C OR NOT (FALSE). C INTEGER ICASE C AN INDICATER VARIABLE USED TO DESIGNATE THE MESSAGE TO BE C PRINTED. C INTEGER IFIXD(NPAR) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. C IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED. C INTEGER IIWORK C THE DIMENSION OF THE INTEGER WORK VECTOR IWORK. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IRWORK C THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK. C CHARACTER*1 ISCHKD(2) C THE INDICATOR USED TO DESIGNATE WHETHER THE C TEST VALUE WAS CHECKED FOR CONVERGENCE (Y) OR NOT (N). C INTEGER ISUBHD C AN INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IWORK(IIWORK) C THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES. C CHARACTER*1 LETTRN, LETTRY C THE LETTERS N AND Y, RESPECTIVELY. C INTEGER MXITER C THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE C MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER NFCALL C THE LOCATION IN IWORK OF THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE LOCATION IN IWORK OF THE NUMBER OF THE CURRENT ITERATION. C EXTERNAL NLHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF UNKNOWN PARAMETERS TO BE OPTIMIZED. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NREDUC C THE LOCATION IN RWORK OF THE VALUE USED TO CHECK IF THE C HESSIAN APPROXIMATION IS POSITIVE DEFINITE. IF C IF RWORK(NREDUC) .EQ. 0, THE HESSIAN IS SINGULAR, OTHERWISE C IT IS NOT. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C DOUBLE PRECISION PARE(NPAR) C THE CURRENT ESTIMATES OF THE UNKNOWN PARAMETERS, BUT ONLY C THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED). C INTEGER PREDUC C THE LOCATION IN RWORK OF THE PREDICTED FUNCTION REDUCTION C FOR THE CURRENT STEP. C INTEGER RELDX C THE LOCATION IN RWORK OF THE SCALED RELATIVE CHANGE IN C THE PARAMETER VALUES CAUSED BY THE CURRENT ITERATION. C DOUBLE PRECISION RSD C THE RESIDUAL STANDARD DEVIATION. C DOUBLE PRECISION RSS C THE RESIDUAL SUM OF SQUARES. C DOUBLE PRECISION RSSC C THE CHANGE IN THE RESIDUAL SUM OF SQUARES CAUSED BY THIS C ITERATION. C DOUBLE PRECISION RSSPC C THE PREDICTED CHANGE IN THE RESIDUAL SUM OF SQUARES AT THIS C ITERATION. C DOUBLE PRECISION RWORK(IRWORK) C THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES. C INTEGER STPPAR C THE LOCATION IN RWORK OF THE MARQUARDT LAMBDA PARAMETER. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C 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 LETTRN /'N'/, LETTRY /'Y'/ C C IWORK SUBSCRIPT VALUES C DATA MXITER /18/, NFCALL /6/, NITER /31/ C C RWORK SUBSCRIPT VALUES C DATA DST0 /3/, F /10/, FDIF /11/, F0 /13/, NREDUC /6/, PREDUC + /7/, RELDX /17/, STPPAR /5/ C CCCCC CALL IPRINT(IPRT) C C IF (IWORK(1).EQ.10) GO TO 90 IF ((IPTOUT.EQ.1) .AND. (IWORK(NITER).NE.1) .AND. + (IWORK(NITER).NE.IWORK(MXITER)) .AND. (IWORK(1).LE.2)) RETURN C ISUBHD = 0 IF (HEAD) CALL NLHDR(PAGE, WIDE, ISUBHD) HEAD = .FALSE. IF (MOD(IWORK(NITER),4).EQ.0) HEAD = .TRUE. C WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1000) IWORK(NITER) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1001) CCCCC CALL DPWRST('XXX','BUG ') 1000 FORMAT (' ITERATION NUMBER', I5) 1001 FORMAT (1X, 22('-')) C C COMPUTE STATISTICS TO BE PRINTED C RSS = 2.0D0*RWORK(F) RSD = SQRT(RSS) IF (NNZW-NPARE.GE.1) RSD = RSD/SQRT(DBLE(NNZW-NPARE)) C RSSC = 0.0D0 IF (RWORK(F0).GT.0.0D0) RSSC = RWORK(FDIF)/RWORK(F0) C RSSPC = 0.0D0 IF (RWORK(F0).GT.0.0D0) RSSPC = RWORK(NREDUC)/RWORK(F0) C C REFERENCE NL2 SUBROUTINE ASSESS, STATEMENT LABEL 300 TO 320 C ISCHKD(1) = LETTRN ISCHKD(2) = LETTRN IF (RWORK(FDIF).GT.2.0D0*RWORK(PREDUC)) GO TO 10 IF (RWORK(DST0).LT.0.0D0) GO TO 10 IF (RWORK(NREDUC).GE.0.0D0) ISCHKD(1) = LETTRY IF (RWORK(STPPAR).EQ.0.0D0) ISCHKD(2) = LETTRY 10 CONTINUE C WRITE (IOUNI3,1010) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1011) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1012) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1013) IWORK(NFCALL), RSD, RSS, RSSC, RSSPC, + ISCHKD(1), RWORK(RELDX), ISCHKD(2) CCCCC CALL DPWRST('XXX','BUG ') 1010 FORMAT ( + 5X, 'MODEL', 53X, 'FORECASTED') 1011 FORMAT ( + 5X, 'CALLS', 9X, 'RSD', + 13X, 'RSS', 8X, 'REL CHNG RSS', 4X, 'REL CHNG RSS', 4X, + 'REL CHNG PAR') 1012 FORMAT ( + 62X, 'VALUE', 3X, 'CHKD', 4X, 'VALUE', 3X, + 'CHKD') 1013 FORMAT ( + 3X, I7, 3(2X, G14.4), 2(G12.4, 3X, A1)) IF (NPARE.LT.NPAR) THEN WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1020) CCCCC CALL DPWRST('XXX','BUG ') ENDIF 1020 FORMAT (5X,' CURRENT PARAMETER VALUES', ' (ONLY UNFIXED PARA', + 'METERS ARE LISTED)') IF (NPARE.GE.NPAR) THEN WRITE(IOUNI3,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI3,1150) CCCCC CALL DPWRST('XXX','BUG ') ENDIF 1150 FORMAT (5X, ' CURRENT PARAMETER VALUES') CALL LSTVCF(NPARE, PARE, NPAR, IFIXD) C IF (IWORK(1).LE.2) RETURN C C PRINT FINAL ITERATION MESSAGE C ICASE = IWORK(1) - 2 GO TO (20, 30, 40, 50, 60, 70, 80, 90, 100, 140, 110, 120, 130), + ICASE C C ***** PARAMETER CONVERGENCE ***** C 20 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1030) CALL DPWRST('XXX','BUG ') RETURN C C ***** RESIDUAL SUM OF SQUARES CONVERGENCE ***** C 30 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1040) CALL DPWRST('XXX','BUG ') RETURN C C ***** PARAMETER AND RESIDUAL SUM OF SQUARES CONVERGENCE **** C 40 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1050) CALL DPWRST('XXX','BUG ') RETURN C C ***** RESIDUAL SUM OF SQUARES IS EXACTLY ZERO ***** C 50 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1060) CALL DPWRST('XXX','BUG ') RETURN C C ***** SINGULAR CONVERGENCE ***** C 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1070) CALL DPWRST('XXX','BUG ') RETURN C C ***** FALSE CONVERGENCE ***** C 70 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1080) CALL DPWRST('XXX','BUG ') RETURN C C ***** LIMIT ON NUM. OF CALLS TO THE MODEL SUBROUTINE REACHED ***** C 80 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1090) CALL DPWRST('XXX','BUG ') RETURN C C ***** ITERATION LIMIT REACHED ***** C 90 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1100) CALL DPWRST('XXX','BUG ') RETURN C C ***** STOPX ***** C 100 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1110) CALL DPWRST('XXX','BUG ') RETURN C C ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ***** C 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1120) CALL DPWRST('XXX','BUG ') RETURN C C ***** BAD PARAMETERS TO ASSESS ***** C 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1130) CALL DPWRST('XXX','BUG ') RETURN C C ***** J COULD NOT BE COMPUTED ***** C 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1140) CALL DPWRST('XXX','BUG ') RETURN C 140 RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1030 FORMAT (' ##### PARAMETER CONVERGENCE #####') 1040 FORMAT (' ##### RESIDUAL SUM OF SQUARES CONVERGENCE #####') 1050 FORMAT (' ##### PARAMETER AND RESIDUAL SUM OF SQUARES', + ' CONVERGENCE #####') 1060 FORMAT (' ##### THE RESIDUAL SUM OF SQUARES IS EXACTLY ZERO', + ' #####') 1070 FORMAT (' ##### SINGULAR CONVERGENCE #####') 1080 FORMAT (' ##### FALSE CONVERGENCE #####') 1090 FORMAT (' ##### LIMIT ON NUMBER OF CALLS TO THE MODEL', + ' SUBROUTINE REACHED #####') 1100 FORMAT (' ##### ITERATION LIMIT REACHED #####') 1110 FORMAT (' ##### STOPX #####') 1120 FORMAT (' ##### INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ####', + '#') 1130 FORMAT (' ##### BAD PARAMETERS TO ASSESS #####') 1140 FORMAT (' ##### DERIVATIVE MATRIX COULD NOT BE COMPUTED #####') END *SETROW SUBROUTINE SETROW (NROW, XM, N, M, IXM, NROWU) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SELECTS THE ROW USED BY THE DERIVATIVE CHECKING C PROCEDURE. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IXM,M,N,NROW,NROWU C C ARRAY ARGUMENTS DOUBLE PRECISION + XM(IXM,M) C C LOCAL SCALARS INTEGER + I,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER J C AN INDEX VARIABLE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NROW, NROWU C THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT C VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED, C AND THE NUMBER OF THE ROW ACTUALLY USED. C DOUBLE PRECISION XM(IXM,M) C THE INDEPENDENT VARIABLE MATRIX. C 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 NROWU = NROW C IF ((NROWU.GE.1) .AND. (NROWU.LE.N)) RETURN C C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. C DO 20 I = 1, N DO 10 J = 1, M IF (XM(I,J) .EQ. 0.0D0) GO TO 20 10 CONTINUE NROWU = I RETURN 20 CONTINUE C NROWU = 1 C RETURN END *VCVOTF SUBROUTINE VCVOTF(NPAR, VCV, LVCV, EST, LMASK, MASK, IVCVPT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE VARIANCE COVARIANCE MATRIX C STORED ROW WISE WHEN IT IS TO BE LABELLED ON THE BASIS OF A MASK. C IF EST IS TRUE, THE COVARIANCES ARE LISTED ABOVE THE C DIAGONAL, THE VARIANCES ON THE DIAGONAL, AND THE CORRELATION C COEFFICIENTS BELOW THE DIAGONAL. C IF EST IS FALSE, THE STANDARD DEVIATIONS ARE LISTED ON THE C DIAGONAL, AND THE CORRELATION COEFFICIENTS ARE BELOW THE C DIAGONAL. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C BASED ON VCVOUT VERSION OF DECEMBER 29, 1982 C WRITTEN BY JANET R. DONALDSON C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVCVPT,LMASK,LVCV,NPAR LOGICAL + EST C C ARRAY ARGUMENTS DOUBLE PRECISION + VCV(LVCV) INTEGER + MASK(LMASK) C C LOCAL SCALARS INTEGER + CODE,I,II,MODE C C EXTERNAL SUBROUTINES EXTERNAL MATPRF C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CODE C IF 1 -SINGLE PRINTED, X ONLY (Y IS DUMMY ARG) C 2 -DOUBLE PRINTED LINE, BOTH X AND Y C LOGICAL EST C AN INDICATOR USED TO DESIGNATE WHETHER THE VCV TO BE PRINTED C IS OF THE ESTIMATED PARAMETERS (TRUE) OR NOT (FALSE). C INTEGER I C AN INDEX VARIABLE. C INTEGER II C THE INDEX OF THE (I,I)TH ELEMENT OF THE VCV MATRIX C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCVPT C AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE C VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE C IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C INTEGER LMASK C THE LENGTH OF MASK. C INTEGER LVCV C THE LENGTH OF ARRAY VCV. C INTEGER MASK(LMASK) C MASK VECTOR FOR VCV. THE INDEX OF THE ITH ELEMENT OF C MASK EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF VCV C OF THE ITH ROW AND ITH COLUMN. C INTEGER MODE C IF 0, LOWER TRIANGULAR PART PRINTED C 1, LOWER TRIANGULAR PART IS PRINTED WITH C SQUARE ROOTS OF THE DIAGONAL C 2, LOWER TRIANGLE PRINTED AS CORRELATION MATRIX C WITH SQUARE ROOTS ON THE DIAGONAL C 3, FULL MATRIX PRINTED C 4, FULL MATRIX PRINTED WITH CORRELATION MATRIX C PRINTED BELOW THE DIAGONAL C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C DOUBLE PRECISION VCV(LVCV) C THE VARIANCE COVARIANCE MATRIX. C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 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 COMMENCE BODY OF ROUTINE C CCCCC CALL IPRINT(IPRT) C CODE = 1 C C DETERMINE WHETHER TO ISSUE NEGATIVE VARIANCE WARNING C MODE = 0 DO 30 I=1,NPAR II = I*(I-1)/2 + I IF (VCV(II).GT.0.0D0) GO TO 30 IF (EST) GO TO 10 WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1000) CCCCC CALL DPWRST('XXX','BUG ') GO TO 20 C 10 CONTINUE WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1050) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1051) CCCCC CALL DPWRST('XXX','BUG ') IF (IVCVPT.EQ.1) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1060) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IVCVPT.EQ.2) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1070) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IVCVPT.EQ.3) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1080) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1081) CCCCC CALL DPWRST('XXX','BUG ') ENDIF 20 CONTINUE WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1010) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1011) CCCCC CALL DPWRST('XXX','BUG ') GO TO 50 30 CONTINUE C IF (EST) GO TO 40 C C PRINT HEADING FOR CORRELATION ROUTINES C WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1040) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1030) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1031) CCCCC CALL DPWRST('XXX','BUG ') MODE = 2 GO TO 50 C 40 CONTINUE C C PRINT HEADING FOR ESTIMATION ROUTINES C WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1050) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1051) CCCCC CALL DPWRST('XXX','BUG ') IF (IVCVPT.EQ.1) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1060) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IVCVPT.EQ.2) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1070) CCCCC CALL DPWRST('XXX','BUG ') ENDIF IF (IVCVPT.EQ.3) THEN WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1080) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1081) CCCCC CALL DPWRST('XXX','BUG ') ENDIF WRITE(IOUNI4,999) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1020) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1021) CCCCC CALL DPWRST('XXX','BUG ') WRITE (IOUNI4,1022) CCCCC CALL DPWRST('XXX','BUG ') MODE = 4 C 50 CALL MATPRF(VCV, VCV, NPAR, MODE, CODE, LVCV, MASK, LMASK) C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' COVARIANCE MATRIX') 1010 FORMAT (' NONPOSITIVE VARIANCES ENCOUNTERED.') 1011 FORMAT( + ' CORRELATION COEFFICIENTS CANNOT BE COMPUTED.') 1020 FORMAT ( + 4X, '- COVARIANCES ARE ABOVE THE DIAGONAL') 1021 FORMAT ( + 4X, '- VARIANCES ARE ON THE DIAGONAL') 1022 FORMAT ( + 4X, '- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL') 1030 FORMAT ( + 4X, '- STANDARD DEVIATIONS ARE ON THE DIAGONAL') 1031 FORMAT ( + 4X, '- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL') 1040 FORMAT (' CORRELATION MATRIX') 1050 FORMAT ( + ' VARIANCE-COVARIANCE AND CORRELATION MATRICES', + ' OF THE ESTIMATED (UNFIXED) PARAMETERS') 1051 FORMAT ( + 1X, 82('-')) 1060 FORMAT ( + 4X, '- APPROXIMATION BASED ON ASSUMPTION THAT RESIDUALS ARE', + ' SMALL') 1070 FORMAT ( + 4X, '- APPROXIMATION BASED ON ASYMPTOTIC MAXIMUM LIKELIH', + 'OOD THEORY') 1080 FORMAT ( + 4X, + '- APPROXIMATION BASED ON ASSUMPTION THAT CONDITIONS', + ' NECESSARY') 1081 FORMAT ( + 5X, ' FOR ASYMPTOTIC MAXIMUM LIKELIHOOD THEORY', + ' MIGHT BE VIOLATED') END *AMFER SUBROUTINE AMFER(NMSUB, N, NPAR, LDSTAK, LDSMIN, + SAVE, MSPEC, NFAC, IFCST, NFCST) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR NONLINEAR LEAST SQUARES C ESTIMATION ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFCST,LDSMIN,LDSTAK,N,NFAC,NFCST,NPAR LOGICAL + SAVE C C ARRAY ARGUMENTS INTEGER + MSPEC(4,*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NP,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(20) CHARACTER + LIFCST(8)*1,LLDS(8)*1,LMSPEC(8)*1,LN(8)*1,LNFAC(8)*1, + LNFCST(8)*1,LNPAR(8)*1,LONE(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EIAGE,EISEQ,EISGE C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(20) C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE C PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE) C OR NOT (FALSE). C INTEGER IERR C THE VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .GE. 1, ERRORS WERE DETECTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C CHARACTER*1 LIFCST(8), LLDS(8), LMSPEC(8), LN(8), LNFAC(8), C * LNPAR(8), LNFCST(8), LONE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER MSPEC(4,NFAC) C THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFCST C THE NUMBER OF FORECASTS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NV C * C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT C (FALSE). C C SET UP NAME ARRAYS C DATA LIFCST(1), LIFCST(2), LIFCST(3), LIFCST(4), LIFCST(5), + LIFCST(6), LIFCST(7), LIFCST(8) + /'I','F','C','S','T',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LMSPEC(1), LMSPEC(2), LMSPEC(3), LMSPEC(4), LMSPEC(5), + LMSPEC(6), LMSPEC(7), LMSPEC(8) + /'M','S','P','C',' ',' ',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNFAC(1), LNFAC(2), LNFAC(3), LNFAC(4), LNFAC(5), + LNFAC(6), LNFAC(7), LNFAC(8) /'N','F','A','C',' ',' ',' ',' '/ DATA LNFCST(1), LNFCST(2), LNFCST(3), LNFCST(4), LNFCST(5), + LNFCST(6), LNFCST(7), LNFCST(8) + /'N','F','C','S','T',' ',' ',' '/ DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5), + LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ', + ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), + LONE(6), LONE(7), LONE(8) /'1',' ',' ',' ',' ',' ',' ',' '/ C C ERROR CHECKING C DO 10 I=1,20 ERROR(I) = .FALSE. 10 CONTINUE C IERR = 0 HEAD = .TRUE. C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERROR(1), LONE) C CALL EISGE(NMSUB, LNFAC, NFAC, 1, 2, HEAD, ERROR(2), LONE) C IF (.NOT. ERROR(2)) + CALL EIAGE(NMSUB, LMSPEC, MSPEC, 4, NFAC, 4, 0, 0, HEAD, 1, NV, + ERROR(3), LMSPEC) C IF ((.NOT. ERROR(2)) .AND. (.NOT. ERROR(3))) THEN NP = 1 DO 15 I = 1, NFAC NP = NP + MSPEC(1,I) + MSPEC(3,I) 15 CONTINUE CALL EISEQ(NMSUB, LNPAR, NPAR, NP, 1, HEAD, ERROR(4), LNPAR) END IF C IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(2)) .AND. (.NOT.ERROR(3)) + .AND. (.NOT.ERROR(4)) .AND. (.NOT.ERROR(5))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6), + LLDS) C IF (SAVE) + CALL EISGE(NMSUB, LIFCST, IFCST, NFCST, 3, HEAD, ERROR(15), + LNFCST) C DO 20 I=1,20 IF (ERROR(I)) GO TO 30 20 CONTINUE RETURN C 30 CONTINUE IERR = 1 RETURN C END *EHDR SUBROUTINE EHDR(NMSUB, HEAD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE HEADING FOR THE ERROR CHECKING ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 29, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS LOGICAL + HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT,VERSP EXTERNAL VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX ARGUMENT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C 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 IF (.NOT.HEAD) RETURN C CCCCC CALL IPRINT(IPRT) C CALL VERSP(.FALSE.) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,1010) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1010) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1000) (NMSUB(I), I=1,6) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1001) CALL DPWRST('XXX','BUG ') HEAD = .FALSE. C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT (' ERROR CHECKING FOR SUBROUTINE ',6A1) 1001 FORMAT (1X, 37('-')) 1010 FORMAT ('+', 18('*')) 1011 FORMAT (' * ERROR MESSAGES *') C END *GQTSTP SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W) C C LATEST REVISION - 03/15/90 (JRD) C C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE *** C *** (NL2SOL VERSION 2.2) *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + KA,P C C ARRAY ARGUMENTS DOUBLE PRECISION + D(P),DIG(P),DIHDI(1),L(1),STEP(P),V(21),W(1) C C LOCAL SCALARS DOUBLE PRECISION + AKI,AKK,ALPHAK,DELTA,DGXFAC,DST,EPSFAC,EPSO6,FOUR,HALF,KAPPA, + LK,NEGONE,OLDPHI,ONE,P001,PHI,PHIMAX,PHIMIN,PSIFAC,RAD,ROOT, + SI,SIX,SK,SW,T,T1,THREE,TWO,TWOPSI,UK,WI,ZERO INTEGER + DGGDMX,DGNORM,DIAG,DIAG0,DST0,DSTNRM,DSTSAV,EMAX,EMIN, + EPSLON,GTSTEP,I,IM1,INC,IRC,J,K,K1,KALIM,LK0,NREDUC, + PHIPIN,PHMNFC,PHMXFC,PREDUC,Q,Q0,RAD0,RADIUS,STPPAR,UK0,X, + X0 LOGICAL + RESTRT C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD,LSVMIN,RMDCON,V2NORM EXTERNAL DOTPRD,LSVMIN,RMDCON,V2NORM C C EXTERNAL SUBROUTINES EXTERNAL LITVMU,LIVMUL,LSQRTZ C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,MIN,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER KA, P C DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P), C 1 W(1) C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR, C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D. C (GQTSTP ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.) C IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT). C C *** PARAMETER DESCRIPTION *** C C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE C MATRIX D MENTIONED ABOVE UNDER PURPOSE. C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED. C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION), C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E., C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC. C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER- C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI) C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G. C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS. C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX. C STEP (I/O) = THE STEP COMPUTED. C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW. C W (I/O) = WORKSPACE OF LENGTH 4*P + 6. C C *** ENTRIES IN V *** C C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G. C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP. C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1. C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP. C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF. C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE). C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS). C V(PHMXFC) (IN) (SEE V(PHMNFC).) C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5. C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP. C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION. C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL. C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2 C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER, C THEN V(STPPAR) = -ALPHA. C C *** USAGE NOTES *** C C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS C WHY STEP AND W ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE WITH C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO- C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND C V(RAD0) OF V MUST BE INITIALIZED. TO COMPUTE STEP FROM A SADDLE C POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE C EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED. C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST- C SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY C UNCONSTRAINED MINIMIZATION PROBLEM. C C *** ALGORITHM NOTES *** C C THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5. C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6. CASES IN WHICH C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). C C *** FUNCTIONS AND SUBROUTINES CALLED *** C C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS. C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX. C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX. C LSQRTZ - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.). C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX. C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS. C V2NORM - RETURNS 2-NORM OF A VECTOR. C C *** REFERENCES *** C C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1980), AN ADAPTIVE C NONLINEAR LEAST-SQUARES ALGORITHM, (SUBMITTED TO ACM C TRANS. MATH. SOFTWARE). C 2. GAY, D.M. (1979), COMPUTING OPTIMAL ELLIPTICALLY CONSTRAINED C STEPS, MRC TECH. SUMMARY REPORT NO. 2013, MATH. RESEARCH C CENTER, UNIV. OF WISCONSIN-MADISON. C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966), C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34, C PP. 541-551. C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS C DIV., A.E.R.E. HARWELL, OXON., ENGLAND. C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN- C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER- C VERLAG, BERLIN AND NEW YORK. C 6. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15, C PP. 719-729. C C *** GENERAL *** C C CODED BY DAVID M. GAY. C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND C MCS-7906671. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C C LOGICAL RESTRT C INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC, C 1 J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0 C DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK, C 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, C 2 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI C C *** CONSTANTS *** C DOUBLE PRECISION DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE, C 1 P001, SIX, THREE, TWO, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRTZ, LSVMIN, RMDCON, V2NORM C DOUBLE PRECISION DOTPRD, LSVMIN, RMDCON, V2NORM C C *** SUBSCRIPTS FOR V *** C C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC, C 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0 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 DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/, + GTSTEP/4/, NREDUC/6/, PHMNFC/20/, + PHMXFC/21/, PREDUC/7/, RADIUS/8/, + RAD0/9/, STPPAR/5/ C DATA DGXFAC/0.0D0/, EPSFAC/50.0D0/, FOUR/4.0D0/, HALF/0.5D0/, + KAPPA/2.0D0/, NEGONE/-1.0D0/, ONE/1.0D0/, P001/1.0D-3/, + SIX/6.0D0/, THREE/3.0D0/, TWO/2.0D0/, ZERO/0.0D0/ C C *** BODY *** C C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX). DGGDMX = P + 1 C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX) C *** AND W(EMIN) RESPECTIVELY. EMAX = DGGDMX + 1 EMIN = EMAX + 1 C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST, C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF. C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN) C *** RESPECTIVELY. UK = 0.0D0 PHI = 0.0D0 DST = 0.0D0 ALPHAK = 0.0D0 LK0 = EMIN + 1 PHIPIN = LK0 + 1 UK0 = PHIPIN + 1 DSTSAV = UK0 + 1 C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P). DIAG0 = DSTSAV DIAG = DIAG0 + 1 C *** STORE -D*STEP IN W(Q),...,W(Q0+P). Q0 = DIAG0 + P Q = Q0 + 1 RAD = V(RADIUS) C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF C *** D*STEP. PHIMAX = V(PHMXFC) * RAD PHIMIN = V(PHMNFC) * RAD C *** EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE C *** OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2). PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) * + (KAPPA + ONE) + KAPPA + TWO) * RAD**2) C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT. OLDPHI = ZERO EPSO6 = V(EPSLON)/SIX IRC = 0 RESTRT = .FALSE. KALIM = KA + 50 C C *** START OR RESTART, DEPENDING ON KA *** C IF (KA .GE. 0) GO TO 310 C C *** FRESH START *** C K = 0 UK = NEGONE KA = 0 KALIM = 50 C C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) *** C J = 0 DO 20 I = 1, P J = J + I K1 = DIAG0 + I W(K1) = DIHDI(J) 20 CONTINUE C C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI *** C T1 = ZERO J = P * (P + 1) / 2 DO 30 I = 1, J T = ABS(DIHDI(I)) IF (T1 .LT. T) T1 = T 30 CONTINUE W(DGGDMX) = T1 C C *** TRY ALPHA = 0 *** C 40 CALL LSQRTZ(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 60 C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA. J = IRC*(IRC+1)/2 T = L(J) L(J) = ONE DO 50 I = 1, IRC 50 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = -T / T1 / T1 V(DST0) = -LK IF (RESTRT) GO TO 210 V(NREDUC) = ZERO GO TO 70 C C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. *** 60 LK = ZERO CALL LIVMUL(P, W(Q), L, DIG) V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q)) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) V(DST0) = DST PHI = DST - RAD IF (PHI .LE. PHIMAX) GO TO 280 IF (RESTRT) GO TO 210 C C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND C *** SMALLEST) EIGENVALUES. *** C 70 V(DGNORM) = V2NORM(P, DIG) IF (V(DGNORM) .EQ. ZERO) GO TO 450 K = 0 DO 100 I = 1, P WI = ZERO IF (I .EQ. 1) GO TO 90 IM1 = I - 1 DO 80 J = 1, IM1 K = K + 1 T = ABS(DIHDI(K)) WI = WI + T W(J) = W(J) + T 80 CONTINUE 90 W(I) = WI K = K + 1 100 CONTINUE C C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) *** C K = 1 T1 = W(DIAG) - W(1) IF (P .LE. 1) GO TO 120 DO 110 I = 2, P J = DIAG0 + I T = W(J) - W(I) IF (T .GE. T1) GO TO 110 T1 = T K = I 110 CONTINUE C 120 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 150 I = 1, P IF (I .EQ. K) GO TO 130 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (AKK - W(J) + SI - AKI) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 140 130 INC = I 140 K1 = K1 + INC 150 CONTINUE C W(EMIN) = AKK - T UK = V(DGNORM)/RAD - W(EMIN) C C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE *** C K = 1 T1 = W(DIAG) + W(1) IF (P .LE. 1) GO TO 170 DO 160 I = 2, P J = DIAG0 + I T = W(J) + W(I) IF (T .LE. T1) GO TO 160 T1 = T K = I 160 CONTINUE C 170 SK = W(K) J = DIAG0 + K AKK = W(J) K1 = K*(K-1)/2 + 1 INC = 1 T = ZERO DO 200 I = 1, P IF (I .EQ. K) GO TO 180 AKI = ABS(DIHDI(K1)) SI = W(I) J = DIAG0 + I T1 = HALF * (W(J) + SI - AKI - AKK) T1 = T1 + SQRT(T1*T1 + SK*AKI) IF (T .LT. T1) T = T1 IF (I .LT. K) GO TO 190 180 INC = I 190 K1 = K1 + INC 200 CONTINUE C W(EMAX) = AKK + T LK = MAX(LK, V(DGNORM)/RAD - W(EMAX)) C C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE C *** USE MORE*S SCHEME FOR INITIALIZING IT. ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD C IF (IRC .NE. 0) GO TO 210 C C *** COMPUTE L0 FOR POSITIVE DEFINITE H *** C CALL LIVMUL(P, W, L, W(Q)) T = V2NORM(P, W) W(PHIPIN) = DST / T / T LK = MAX(LK, PHI*W(PHIPIN)) C C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) *** C 210 KA = KA + 1 IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK) + ALPHAK = UK * MAX(P001, SQRT(LK/UK)) K = 0 DO 220 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) + ALPHAK 220 CONTINUE C C *** TRY COMPUTING CHOLESKY DECOMPOSITION *** C CALL LSQRTZ(1, P, L, DIHDI, IRC) IF (IRC .EQ. 0) GO TO 250 C C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK *** C J = (IRC*(IRC+1))/2 T = L(J) L(J) = ONE DO 230 I = 1, IRC 230 W(I) = ZERO W(IRC) = ONE CALL LITVMU(IRC, W, L, W) T1 = V2NORM(IRC, W) LK = ALPHAK - T/T1/T1 V(DST0) = -LK GO TO 210 C C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE. C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. *** C 250 CALL LIVMUL(P, W(Q), L, DIG) CALL LITVMU(P, W(Q), L, W(Q)) DST = V2NORM(P, W(Q)) PHI = DST - RAD IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290 IF (PHI .EQ. OLDPHI) GO TO 290 OLDPHI = PHI IF (PHI .GT. ZERO) GO TO 260 C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY) C *** SINGULAR. DELTA IS .GE. THE SMALLEST EIGENVALUE OF C *** (D**-1)*H*(D**-1) + ALPHAK*I. IF (V(DST0) .GT. ZERO) GO TO 260 DELTA = ALPHAK + V(DST0) TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q)) IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270 C C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK *** C 260 IF (KA .GE. KALIM) GO TO 290 CALL LIVMUL(P, W, L, W(Q)) T1 = V2NORM(P, W) C *** THE FOLLOWING MIN IS NECESSARY BECAUSE OF RESTARTS *** IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK) ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD) LK = MAX(LK, ALPHAK) GO TO 210 C C *** DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC. 270 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3) C C *** NOW DECIDE. *** IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350 C *** DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS. GO TO 290 C C *** ACCEPTABLE STEP ON FIRST TRY *** C 280 ALPHAK = ZERO C C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q *** C 290 DO 300 I = 1, P J = Q0 + I STEP(I) = -W(J)/D(I) 300 CONTINUE V(GTSTEP) = -DOTPRD(P, DIG, W(Q)) V(PREDUC) = HALF * (ABS(ALPHAK)*DST*DST - V(GTSTEP)) GO TO 430 C C C *** RESTART WITH NEW RADIUS *** C 310 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330 C C *** PREPARE TO RETURN NEWTON STEP *** C RESTRT = .TRUE. KA = KA + 1 K = 0 DO 320 I = 1, P K = K + I J = DIAG0 + I DIHDI(K) = W(J) 320 CONTINUE UK = NEGONE GO TO 40 C 330 IF (KA .EQ. 0) GO TO 60 C DST = W(DSTSAV) ALPHAK = ABS(V(STPPAR)) PHI = DST - RAD T = V(DGNORM)/RAD IF (RAD .GT. V(RAD0)) GO TO 340 C C *** SMALLER RADIUS *** UK = T - W(EMIN) LK = ZERO IF (ALPHAK .GT. ZERO) LK = W(LK0) LK = MAX(LK, T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** BIGGER RADIUS *** 340 UK = T - W(EMIN) IF (ALPHAK .GT. ZERO) UK = MIN(UK, W(UK0)) LK = MAX(ZERO, -V(DST0), T - W(EMAX)) IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN)) GO TO 260 C C *** HANDLE (NEARLY) SINGULAR H + ALPHA*D**2 *** C C *** NEGATE ALPHAK TO INDICATE SPECIAL CASE *** 350 ALPHAK = -ALPHAK C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X *** X0 = Q0 + P X = X0 + 1 C C *** USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN C *** APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE C *** OF (D**-1)*H*(D**-1). C DELTA = KAPPA*DELTA T = LSVMIN(P, L, W(X), W) C K = 0 C *** NORMALIZE W *** 360 DO 370 I = 1, P 370 W(I) = T*W(I) C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W. CALL LITVMU(P, W, L, W) T1 = ONE/V2NORM(P, W) T = T1*T IF (T .LE. DELTA) GO TO 390 IF (K .GT. 30) GO TO 290 K = K + 1 C *** START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X. DO 380 I = 1, P J = X0 + I W(J) = T1*W(I) 380 CONTINUE C *** COMPUTE W = (L**-1)*X. CALL LIVMUL(P, W, L, W(X)) T = ONE/V2NORM(P, W) GO TO 360 C 390 DO 400 I = 1, P 400 W(I) = T1*W(I) C C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W. C SW = DOTPRD(P, W(Q), W) T1 = (RAD + DST) * (RAD - DST) ROOT = SQRT(SW*SW + T1) IF (SW .LT. ZERO) ROOT = -ROOT SI = T1 / (SW + ROOT) C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3. V(PREDUC) = HALF*TWOPSI T1 = ZERO T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W))) IF (T .LT. EPSO6*TWOPSI) GO TO 410 V(PREDUC) = V(PREDUC) + T DST = RAD T1 = -SI 410 DO 420 I = 1, P J = Q0 + I W(J) = T1*W(I) - W(J) STEP(I) = W(J) / D(I) 420 CONTINUE V(GTSTEP) = DOTPRD(P, DIG, W(Q)) C C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART *** C 430 V(DSTNRM) = DST V(STPPAR) = ALPHAK W(LK0) = LK W(UK0) = UK V(RAD0) = RAD W(DSTSAV) = DST C C *** RESTORE DIAGONAL OF DIHDI *** C J = 0 DO 440 I = 1, P J = J + I K = DIAG0 + I DIHDI(J) = W(K) 440 CONTINUE GO TO 999 C C *** SPECIAL CASE -- G = 0 *** C 450 V(STPPAR) = ZERO V(PREDUC) = ZERO V(DSTNRM) = ZERO V(GTSTEP) = ZERO DO 460 I = 1, P 460 STEP(I) = ZERO C 999 RETURN C C *** LAST CARD OF GQTSTP FOLLOWS *** END *LSVMIN DOUBLE PRECISION FUNCTION LSVMIN(P, L, X, Y) C C LATEST REVISION - 03/15/90 (JRD) C C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + L(1),X(P),Y(P) C C LOCAL SCALARS DOUBLE PRECISION + B,HALF,ONE,PSJ,R9973,SMINUS,SPLUS,T,XMINUS,XPLUS,ZERO INTEGER + I,II,IX,J,J0,JI,JJ,JJJ,JM1,PPLUS1 C C EXTERNAL FUNCTIONS DOUBLE PRECISION + V2NORM EXTERNAL V2NORM C C INTRINSIC FUNCTIONS INTRINSIC ABS,MOD C C *** PARAMETER DECLARATIONS *** C C INTEGER P C DOUBLE PRECISION L(1), X(P), Y(P) C DIMENSION L(P*(P+1)/2) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** PURPOSE *** C C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L. C C *** PARAMETER DESCRIPTION *** C C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX. C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E. C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC. C X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY C CRUDE. IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES. C Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND- C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION C MAY BE CRUDE. IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER- C WRITES X (FOR NONZERO LSVMIN RETURNS). C C *** APPLICATION AND USAGE RESTRICTIONS *** C C THERE ARE NO USAGE RESTRICTIONS. C C *** ALGORITHM NOTES *** C C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT C LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE C (2) AND (3). C C *** SUBROUTINES AND FUNCTIONS CALLED *** C C V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR. C C *** REFERENCES *** C C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977), C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY. C C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW, C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV. C C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2 C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS. C C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18, C PP. 586-593. C C *** HISTORY *** C C DESIGNED AND CODED BY DAVID M GAY (WINTER 1977/SUMMER 1978). C C *** GENERAL *** C C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989. C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C *** LOCAL VARIABLES *** C C INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1 C DOUBLE PRECISION B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C C DOUBLE PRECISION HALF, ONE, R9973, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL V2NORM C DOUBLE PRECISION V2NORM 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 IX/2/ DATA HALF/0.5D0/, ONE/1.0D0/, R9973/9973.0D0/, ZERO/0.0D0/ C C *** BODY *** C C *** FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X *** C II = 0 DO 10 I = 1, P X(I) = ZERO II = II + I IF (L(II) .EQ. ZERO) GO TO 300 10 CONTINUE IF (MOD(IX, 9973) .EQ. 0) IX = 2 PPLUS1 = P + 1 C C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE. C C DO J = P TO 1 BY -1... DO 100 JJJ = 1, P J = PPLUS1 - JJJ C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I. IX = MOD(3432*IX, 9973) B = HALF*(ONE + IX/R9973) XPLUS = (B - X(J)) XMINUS = (-B - X(J)) SPLUS = ABS(XPLUS) SMINUS = ABS(XMINUS) JM1 = J - 1 J0 = J*JM1/2 JJ = J0 + J XPLUS = XPLUS/L(JJ) XMINUS = XMINUS/L(JJ) IF (JM1 .EQ. 0) GO TO 30 DO 20 I = 1, JM1 JI = J0 + I SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS) SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS) 20 CONTINUE 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS X(J) = XPLUS C *** UPDATE PARTIAL SUMS *** IF (JM1 .EQ. 0) GO TO 100 DO 40 I = 1, JM1 JI = J0 + I X(I) = X(I) + L(JI)*XPLUS 40 CONTINUE 100 CONTINUE C C *** NORMALIZE X *** C T = ONE/V2NORM(P, X) DO 110 I = 1, P 110 X(I) = T*X(I) C C *** SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y) *** C DO 200 J = 1, P PSJ = ZERO JM1 = J - 1 J0 = J*JM1/2 IF (JM1 .EQ. 0) GO TO 130 DO 120 I = 1, JM1 JI = J0 + I PSJ = PSJ + L(JI)*Y(I) 120 CONTINUE 130 JJ = J0 + J Y(J) = (X(J) - PSJ)/L(JJ) 200 CONTINUE C LSVMIN = ONE/V2NORM(P, Y) GO TO 999 C 300 LSVMIN = ZERO 999 RETURN C *** LAST CARD OF LSVMIN FOLLOWS *** END *NLSKL SUBROUTINE NLSKL(ISKULL, PAGE, WIDE, NLHDR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS A HEADING AND WARNING MESSAGES FOR C SERIOUS ERRORS DETECTED BY THE NONLINEAR LEAST SQUARES ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS LOGICAL + PAGE,WIDE C C ARRAY ARGUMENTS INTEGER + ISKULL(10) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C LOCAL SCALARS INTEGER + ISUBHD 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 EXTERNAL SUBROUTINES CCCCC EXTERNAL IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL NLHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISKULL(10) C AN ERROR MESSAGE INDICATOR VARIABLE. C INTEGER ISUBHD C AN INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT C IS TO BEGIN ON A NEW PAGE. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C CCCCC CALL IPRINT(IPRT) C ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) C IF (WIDE) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1010) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1012) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1013) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1014) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1020) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1021) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1022) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1023) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1024) CALL DPWRST('XXX','BUG ') C WRITE (ICOUT,1030) C WRITE (ICOUT,1040) C WRITE (ICOUT,1050) CCCCC WRITE (ICOUT,1000) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') END IF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1060) CALL DPWRST('XXX','BUG ') C C VCV COMPUTATION NOT COMPLETED C IF (ISKULL(7).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1120) CALL DPWRST('XXX','BUG ') ENDIF C C MAXIMUM NUMBER OF ITERATIONS REACHED BEFORE CONVERGENCE C IF (ISKULL(6).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1100) CALL DPWRST('XXX','BUG ') ENDIF C C FALSE CONVERGENCE C IF (ISKULL(5).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1090) CALL DPWRST('XXX','BUG ') ENDIF C C MEANINGLESS VCV MATRIX C IF (ISKULL(4).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1080) CALL DPWRST('XXX','BUG ') ENDIF C C PROBLEM IS COMPUTATIONALLY SINGULAR C IF (ISKULL(3).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1070) CALL DPWRST('XXX','BUG ') ENDIF C C INITIAL RESIDUAL SUM OF SQUARES COMPUTATION OVERFLOWED C IF (ISKULL(2).NE.0) THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1110) CALL DPWRST('XXX','BUG ') ENDIF C RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) c1000 FORMAT (///) 1010 FORMAT ( + ' W W AA RRRRRRR N N IIII', + ' N N GGG') 1011 FORMAT ( + ' W W A A R RR ', + ' NN N II NN N G G') 1012 FORMAT ( + ' W W ', + ' A A R R N N N II N N N G') 1013 FORMAT ( + ' WW WW AA AA R RR N N N II N N ', + 'N G') 1014 FORMAT ( + ' W W AAAAAA RRRRRRR N NN N II', + ' N NN N G GGGGG') 1020 FORMAT ( + ' W WW W A A R R N N N II ', + ' N N N G G') 1021 FORMAT ( + ' W WW W A A R R ', + ' N N N II N N N G G') 1022 FORMAT ( + ' W W ', + ' AA AA R R N NN II N NN G ', + 'GG') 1023 FORMAT ( + ' W W A A R R N N IIII ', + ' N N GGGG G') 1024 FORMAT (1X) C1010 FORMAT (/30X, 48H W W AA RRRRRRR N N IIII, C * 19H N N GGG/30X, 31H W W A A R RR , C * 38H NN N II NN N G G/30X, 12H W W , C * 51H A A R R N N N II N N N G/30X, C * 59H WW WW AA AA R RR N N N II N N , C * 4HN G/30X, 47H W W AAAAAA RRRRRRR N NN N II, C * 23H N NN N G GGGGG) C1020 FORMAT (30X, 49H W WW W A A R R N N N II , C * 21H N N N G G/30X, 29H W WW W A A R R , C * 41H N N N II N N N G G/30X, 9H W W , C * 59H AA AA R R N NN II N NN G , C * 2HGG/30X, 49H W W A A R R N N IIII , C * 21H N N GGGG G/) C1030 FORMAT (1(34X, 3HXXX, 58X, 3HXXX/), 31X, 6('X'), 58X, 6('X')/31X, C * 7('X'), 56X, 7('X')/31X, 9('X'), 52X, 9('X')/36X, 5('X'), 17X, C * '(', 14('-'), ')', 17X, 5('X')/38X, 5('X'), 14X, 2H((, 14X, C * 2H)), 14X, 5('X')/40X, 5('X'), 10X, 2H((, 18X, 2H)), 10X, C * 5('X')/41X, 5('X'), 8X, 2H((, 20X, 2H)), 8X, 5('X')/43X, C * 5('X'), 5X, 2H((, 22X, 2H)), 5X, 5('X')/44X, 5('X'), 3X, 2H((, C * 24X, 2H)), 3X, 5('X')) C1040 FORMAT (46X, 7HXXXXX (, 26X, 7H) XXXXX/48X, C * 5HXXX((, 7X, 2HOO, 8X, 2HOO, 7X, 5H))XXX/49X, 3HXX(, 7X, C * 4HO O, 6X, 4HO O, 7X, 3H)XX/50X, 2HX(, 7X, 4HO O, 6X, C * 4HO O, 7X, 2H)X/51X, '(', 8X, 2HOO, 8X, 2HOO, 8X, ')'/2(51X, C * '(', 28X, ')'/), 51X, '(', 11X, 6HOO OO, 11X, ')'/51X, 2H((, C * 10X, 6HOO OO, 10X, 2H))/52X, 2H((, 24X, 2H))/53X, '(', 24X, C * ')'/54X, '(', 22X, ')') C1050 FORMAT (55X, 4H(--(, 14X, 4H)--)/59X, '(', 12X, ')'/58X, C * 3HX((, 10X, 3H))X/56X, 5HXXXX(, 10X, 5H)XXXX/54X, 9HXXXXX (II, C * 15HIIIIIIII) XXXXX/53X, 5('X'), 2X, 12H(IIIIIIIIII), 2X, 5('X') C * /51X, 5('X'), 4X, '(', 10X, ')', 4X, 5('X')/49X, 5('X'), 6X, C * 2H((, 8X, 2H)), 6X, 5('X')/48X, 5('X'), 8X, 10H(--------), 8X, C * 5('X')/46X, 5('X'), 30X, 5('X')/44X, 5('X'), 34X, 5('X')/43X, C * 5('X'), 36X, 5('X')/41X, 5('X'), 40X, 5('X')/40X, 4HXXXX, 44X, C * 4HXXXX/38X, 5('X'), 46X, 5('X')/36X, 5('X'), 50X, 5('X')/31X, C * 9('X'), 52X, 9('X')/31X, 7('X'), 56X, 7('X')/31X, 6('X'), 58X, C * 6('X')/1(34X, 3HXXX, 58X, 3HXXX)) 1060 FORMAT (' ** ERROR SUMMARY **') 1070 FORMAT (' THIS MODEL AND DATA ARE COMPUTATIONALLY SINGULAR.', + ' CHECK YOUR INPUT FOR ERRORS.') 1080 FORMAT ( + ' AT LEAST ONE OF THE STANDARDIZED RESIDUALS COULD', + ' NOT BE COMPUTED BECAUSE THE STANDARD DEVIATION OF THE ') 1081 FORMAT ( + 'RESIDUAL WAS ZERO. THE VALIDITY OF THE COVARIANCE MATRIX', + ' IS QUESTIONABLE.') 1090 FORMAT ( + ' THE ITERATIONS DO NOT APPEAR TO BE CONVERGING', + ' TO A MINIMUM (FALSE CONVERGENCE), INDICATING THAT THE') 1091 FORMAT ( + ' CONVERGENCE CRITERIA STOPSS AND STOPP MAY BE TOO ', + 'SMALL FOR THE ACCURACY OF THE MODEL AND DERIVATIVES,') 1092 FORMAT ( + 'THAT THERE IS AN ERROR IN THE DERIVATIVE MATRIX, OR', + ' THAT THE MODEL IS DISCONTINUOUS NEAR THE CURRENT COEF', + 'FICIENT ESTIMATES.') 1100 FORMAT (' PROGRAM DID NOT CONVERGE IN THE NUMBER OF ITERATIONS', + ' OR NUMBER OF MODEL SUBROUTINE CALLS ALLOWED.') 1110 FORMAT (' THE RESIDUAL SUM OF SQUARES COULD NOT BE COMPUTED', + ' USING THE STARTING MODEL COEFFICIENT VALUES.') 1120 FORMAT (' THE VARIANCE-COVARIANCE MATRIX COULD NOT BE', + ' COMPUTED AT THE SOLUTION.') END *SLUPDT SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE, + Y) C C LATEST REVISION - 03/15/90 (JRD) C C C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y *** C *** (LOWER TRIANGLE OF A STORED ROWWISE *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + COSMIN,SIZE,WSCALE INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + A(1),STEP(P),U(P),W(P),WCHMTD(P),Y(P) C C LOCAL SCALARS DOUBLE PRECISION + DENMIN,HALF,ONE,SDOTWM,T,UI,WI,ZERO INTEGER + I,J,K C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD,V2NORM EXTERNAL DOTPRD,V2NORM C C EXTERNAL SUBROUTINES EXTERNAL SLVMUL C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN C C *** PARAMETER DECLARATIONS *** C C INTEGER P C DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P), C 1 WCHMTD(P), WSCALE, Y(P) C DIMENSION A(P*(P+1)/2) C C *** LOCAL VARIABLES *** C C INTEGER I, J, K C DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** C DOUBLE PRECISION HALF, ONE, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL DOTPRD, SLVMUL, V2NORM C DOUBLE PRECISION DOTPRD, V2NORM 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 HALF/0.5D0/, ONE/1.0D0/, ZERO/0.0D0/ C C----------------------------------------------------------------------- C SDOTWM = DOTPRD(P, STEP, WCHMTD) DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD) WSCALE = ONE IF (DENMIN .NE. ZERO) WSCALE = MIN(ONE, ABS(SDOTWM/DENMIN)) T = ZERO IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM DO 10 I = 1, P 10 W(I) = T * WCHMTD(I) CALL SLVMUL(P, U, A, STEP) T = HALF * (SIZE * DOTPRD(P, STEP, U) - DOTPRD(P, STEP, Y)) DO 20 I = 1, P 20 U(I) = T*W(I) + Y(I) - SIZE*U(I) C C *** SET A = A + U*(W**T) + W*(U**T) *** C K = 1 DO 40 I = 1, P UI = U(I) WI = W(I) DO 30 J = 1, I A(K) = SIZE*A(K) + UI*W(J) + WI*U(J) K = K + 1 30 CONTINUE 40 CONTINUE C RETURN C *** LAST CARD OF SLUPDT FOLLOWS *** END *VERSP SUBROUTINE VERSP (WIDE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE VERSION NUMBER. C C FOR DATAPLOT, MAKE THIS A NULL ROUTINE C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 4, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS LOGICAL + WIDE C C LOCAL SCALARS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED OUTPUT. C LOGICAL WIDE C THE MAXIMUM NUMBER OF COLUMNS THE PRINTED OUTPUT CAN USE. 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 CCCCC CALL IPRINT(IPRT) C CCCCC IF (WIDE) THEN CCCCC WRITE(IPRT, 1000) CCCCC ELSE CCCCC WRITE(IPRT, 1010) CCCCC END IF C RETURN C C FORMAT STATEMENTS C C1000 FORMAT (105X, 'STARPAC 2.08D (03/15/90)') C1010 FORMAT (54X, 'STARPAC 2.08D (03/15/90)') END *AMFHDR SUBROUTINE AMFHDR(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE NONLINEAR C LEAST SQUARES ESTIMATION ROUTINES FOR ARIMA MODELS THAT USE C NUMERICAL APPROXIMATIONS TO THE DERIVATIVES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - AUGUST 1, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS CCCCC INTEGER CCCCC+ IPRT C C EXTERNAL SUBROUTINES EXTERNAL VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C 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 CCCCC CALL IPRINT(IPRT) IF (PAGE) THEN WRITE (ICOUT, 1020) CALL DPWRST('XXX','BUG ') ENDIF CALL VERSP(WIDE) IF (PAGE) THEN WRITE (ICOUT,1000) CALL DPWRST('XXX','BUG ') ENDIF IF (.NOT.PAGE) THEN WRITE (ICOUT,1010) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE (ICOUT,1012) CALL DPWRST('XXX','BUG ') ENDIF PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 CONTINUE WRITE (ICOUT, 1020) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1020) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1030) CALL DPWRST('XXX','BUG ') C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT ('+ARIMA FORECASTING, CONTINUED') 1010 FORMAT ( + '+', 23('*')) 1011 FORMAT ( + ' * ARIMA FORECASTING *') 1012 FORMAT ( + 1X, 23('*')) 1020 FORMAT ('1') 1030 FORMAT (' MODEL SUMMARY') 1031 FORMAT (' -------------') END *EIAGE SUBROUTINE EIAGE (NMSUB, NMVAR, YM, N, M, IYM, YMMN, NVMX, + HEAD, MSGTYP, NV, ERROR, NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS TO ENSURE THAT NO VALUES, OR ONLY A MAXIMUM C OF NVMX, ARE NOT GREATER THAN A SPECIFIED LOWER BOUND YMMN, C WITH NAME NMMIN. THE CHECKING OPTION IS SPECIFIED C WITH MSGTYP. IF AN ERROR IS FOUND, THE ERROR IS PRINTED AND C AN ERROR FLAG AND THE NUMBER OF VIOLATINS ARE RETURNED. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JUNE 10, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IYM,M,MSGTYP,N,NV,NVMX,YMMN LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS INTEGER + YM(*) CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,J C C EXTERNAL SUBROUTINES EXTERNAL EIAGEP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C INTEGER I C AN INDEX VARIABLE. C INTEGER IYM C THE FIRST DIMENSION OF THE ARRAY YM. C INTEGER J C AN INDEXING VARIABLE. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN YM. C INTEGER MSGTYP C THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE. C IF (MSGTYP.GE.3) THE MESSAGE PRINTED WILL USE NMMIN C OTHERWISE IT WILL USE YMMN. C IF (MSGTYP = 1 OR 3) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 2 OR 4) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMMIN(8) C THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE PARAMETERS NAME. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C INTEGER YM(IYM,M) C THE ARRAY BEING TESTED. C INTEGER YMMN C THE MINIMUM ACCEPTABLE VALUE. C 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 ERROR = .FALSE. C IF ((N.LE.0) .OR. (M.LE.0)) RETURN C C CHECK FOR VIOLATIONS C NV = 0 DO 5 I = 1, N DO 1 J = 1, M IF (YM(I+(J-1)*IYM) .LT. YMMN) NV = NV + 1 1 CONTINUE 5 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. C CALL EIAGEP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV, + NMMIN) C RETURN C END *HIPASS SUBROUTINE HIPASS (Y, N, FC, K, HHP, YF, NYF, IERR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE CARRIES OUT HI-PASS FILTERING OF THE C SERIES. THE FILTER IS THE K-TERM C LEAST SQUARES APPROXIMATION TO THE CUTOFF FILTER C WITH CUTOF FREQUENCY FC. ITS TRANSFER FUNCTION C HAS A TRANSITION BAND OF WIDTH DELTA SURROUNDING FC, C WHERE DELTA = 4*PI/K. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + FC INTEGER + K,N,NYF C C ARRAY ARGUMENTS DOUBLE PRECISION + HHP(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD C C LOCAL ARRAYS CHARACTER + LFC(8)*1,LK(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,HPFLT,LPFLT C C COMMON BLOCKS COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C DOUBLE PRECISION FC C THE USER SUPPLIED CUTOFF FREQUENCY. C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED C (TRUE) OR NOT (FALSE). IF A HEADING IS PRINTED, THE VALUE C OF HEAD WILL BE CHANGED TO FALSE. C DOUBLE PRECISION HHP(K) C THE ARRAY IN WHICH THE -IDEAL- HIGH PASS FILTER COEFFICIENTS C WILL BE RETURNED. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER K C THE NUMBER OF FILTER TERMS TO BE COMPUTED. C CHARACTER*1 LFC(8), LK(8), LN(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES FC, K AND N. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NYF C THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF. C DOUBLE PRECISION Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C DOUBLE PRECISION YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS 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 + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'H', 'I', 'P', 'A', 'S', 'S'/ DATA + LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8) + / 'F', 'C', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 3, 1, HEAD, ERR01, LN) C CALL ERSII(NMSUB, LFC, FC, 0.0D0, + 0.5D0, 2, HEAD, ERR02, LFC, LFC) C CALL EISII(NMSUB, LK, K, 1, N, 2, HEAD, ERR03, LK, LK) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04) IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 10 C CALL ERSLFS(NMSUB, FC, K, HEAD, ERR05) C IF (ERR05) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1000) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE (ICOUT, 1001) CALL DPWRST('XXX','BUG ') IERR2=IERR RETURN C 20 CONTINUE C CALL LPFLT (FC, K, HHP) C CALL HPFLT (HHP, K, HHP) C CALL FLTSL (Y, N, K, HHP, YF, NYF) C IERR2=IERR RETURN C C FORMAT STATEMENTS C 999 FORMAT(1X) 1000 FORMAT ( + ' THE CORRECT FORM OF THE CALL STATEMENT IS') 1001 FORMAT ( + ' CALL HIPASS (Y, N, FC, K, HHP, YF, NYF)') END *LTSQAR SUBROUTINE LTSQAR(N, A, L) C C LATEST REVISION - 03/15/90 (JRD) C C C *** SET A TO LOWER TRIANGLE OF (L**T) * L *** C C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. *** C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS DOUBLE PRECISION + A(*),L(*) C C LOCAL SCALARS DOUBLE PRECISION + LII,LJ INTEGER + I,I1,II,IIM1,J,K,M C C INTEGER N C DOUBLE PRECISION A(1), L(1) C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2) C C INTEGER I, II, IIM1, I1, J, K, M C DOUBLE PRECISION LII, LJ 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 II = 0 DO 50 I = 1, N I1 = II + 1 II = II + I M = 1 IF (I .EQ. 1) GO TO 30 IIM1 = II - 1 DO 20 J = I1, IIM1 LJ = L(J) DO 10 K = I1, J A(M) = A(M) + LJ*L(K) M = M + 1 10 CONTINUE 20 CONTINUE 30 LII = L(II) DO 40 J = I1, II 40 A(J) = LII * L(J) 50 CONTINUE C RETURN C *** LAST CARD OF LTSQAR FOLLOWS *** END *NLSPK SUBROUTINE NLSPK(PAR, MASK, NPAR, PPAR, NPPAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PACKS A VECTOR PAR INTO A VECTOR PPAR, BY C OMITTING FROM THE PACKED VERSION THOSE ELEMENTS OF THE C UNPACKED VERSION CORRESPONDING TO ELEMENTS OF MASK WHICH C HAVE THE VALUE 1. OTHER ELEMENTS OF MASK SHOULD BE ZERO. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + NPAR,NPPAR C C ARRAY ARGUMENTS DOUBLE PRECISION + PAR(NPAR),PPAR(NPPAR) INTEGER + MASK(NPAR) C C LOCAL SCALARS INTEGER + I,IPPAR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION PAR(NPAR) C INPUT PARAMETER. THE UNPACKED VECTOR. C INTEGER I C LOOP PARAMETER. C INTEGER IPPAR C CURRENT ELEMENT OF PPAR. RANGES FROM 0 (ON INITIALIZATION) C TO NPPAR. C INTEGER MASK(NPAR) C INPUT PARAMETER. THE MASK GOVERNING THE PACKING OF PAR. C ELEMENTS OF MASK ARE 1 IF THE CORRESPONDING ELEMENT OF PAR C IS TO BE ELIMINATED IN PPAR, 0 IF IT IS TO BE INCLUDED. C INTEGER NPAR C INPUT PARAMETER. THE LENGTH OF PAR. C INTEGER NPPAR C INPUT PARAMETER. THE LENGTH OF PPAR. C DOUBLE PRECISION PPAR(NPPAR) C OUTPUT PARAMETER. THE PACKED VERSION OF PAR. SEE INITIAL C DESCRIPTION. C C COMMENCE BODY OF ROUTINE C 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 IPPAR = 0 DO 10 I=1,NPAR IF (MASK(I).NE.0) GO TO 10 IPPAR = IPPAR + 1 PPAR(IPPAR) = PAR(I) 10 CONTINUE RETURN END *SLVMUL SUBROUTINE SLVMUL(P, Y, S, X) C C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. *** C *** LOWER TRIANGLE OF S STORED ROWWISE. *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + S(1),X(P),Y(P) C C LOCAL SCALARS DOUBLE PRECISION + XI INTEGER + I,IM1,J,K C C EXTERNAL FUNCTIONS DOUBLE PRECISION + DOTPRD EXTERNAL DOTPRD C C *** PARAMETER DECLARATIONS *** C C INTEGER P C DOUBLE PRECISION S(1), X(P), Y(P) C DIMENSION S(P*(P+1)/2) C C *** LOCAL VARIABLES *** C C INTEGER I, IM1, J, K C DOUBLE PRECISION XI C C *** EXTERNAL FUNCTION *** C C EXTERNAL DOTPRD C DOUBLE PRECISION DOTPRD 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----------------------------------------------------------------------- C J = 1 DO 10 I = 1, P Y(I) = DOTPRD(I, S(J), X) J = J + I 10 CONTINUE C IF (P .LE. 1) GO TO 999 J = 1 DO 40 I = 2, P XI = X(I) IM1 = I - 1 J = J + 1 DO 30 K = 1, IM1 Y(K) = Y(K) + S(J)*XI J = J + 1 30 CONTINUE 40 CONTINUE C 999 RETURN C *** LAST CARD OF SLVMUL FOLLOWS *** END *VSCOPY SUBROUTINE VSCOPY(P, Y, S) C C *** SET P-VECTOR Y TO SCALAR S *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION + S INTEGER + P C C ARRAY ARGUMENTS DOUBLE PRECISION + Y(*) C C LOCAL SCALARS INTEGER + I 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 DO 10 I = 1, P 10 Y(I) = S RETURN END