*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 REAL + ABSTOL INTEGER + N,NFAIL C C ARRAY ARGUMENTS REAL + V(*),W(*) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL V(N), W(N) C THE VALUES BEING COMPARED. 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 *ACCDIG SUBROUTINE ACCDIG(AX, X, AD, N) C C LATEST REVISION - 03/15/90 (JRD) C C RETURNS NUMBER OF ACCURATE DIGITS, AD, IN AX AN APPROXIMATION TO X C C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/29/69. C C THIS ROUTINE WAS ADAPTED FROM THE OMNITAB ROUTINE ACCDIG C BY - - C C 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 + N C C ARRAY ARGUMENTS REAL + AD(*),AX(*),X(*) C C LOCAL SCALARS REAL + ADMAX,DIFF,FPLRS INTEGER + I C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AD(N) C THE NUMBER OF ACCURATE DIGITS. C REAL ADMAX C THE NUMBER OF DIGITS CARRIED IN A FLOATING POINT COMPUTATION. C REAL AX(N) C THE APPROXIMATION TO THE SOLUTION. C REAL DIFF C * C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C INTEGER I C AN INDEX. C INTEGER N C THE NUMBER OF ELEMENTS BEING COMPARED. C REAL X(N) C THE SOLUTION. C C FPLRS = R1MACH(4) C ADMAX = -LOG10(FPLRS) C DO 20 I=1,N DIFF = AX(I) - X(I) IF (DIFF.NE.0.0E0) GO TO 10 AD(I) = ADMAX GO TO 20 10 AD(I) = 0.0E0 IF (ABS(X(I)).GT.0.0E0) AD(I) = LOG10(ABS(X(I))) IF (ABS(DIFF).GT.0.0E0) AD(I) = -LOG10(ABS(DIFF)) + AD(I) AD(I) = MIN(ADMAX,AD(I)) AD(I) = MAX(-ADMAX,AD(I)) 20 CONTINUE RETURN END *ACFD SUBROUTINE ACFD (Y, N, LAGMAX, NFAC, ND, IOD, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C WITH DIFFERENCING. 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 + LAGMAX,LDSTAK,N,NFAC C C ARRAY ARGUMENTS REAL + Y(*) INTEGER + IOD(*),ND(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + ACOV,AIC,FTEST,I,IAR,IFP,IPRT,LACOV,LDSMIN,LYFFT,NALL0, + NFFT,NTIMES,NYD,NYF,PHI,PRHO,SDRHO,WORK,YF LOGICAL + DIFFER,ISFFT,NEWPG C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMN,ACFOUT,DIFSER,IPRINT,LDSCMP,SCOPY,STKCLR, + STKSET C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN DSTAK FOR C THE AUTOCOVARIANCE VECTOR. C INTEGER AIC C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE SERIES C BEING ANALYZED WAS DIFFERENCED OR NOT. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER FTEST C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 INTEGER IFP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING C POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION. C INTEGER IOD(NFAC) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C A DUMMY VARIABLE C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER ND(NFAC) C THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE C FACTORS ARE TO BE APPLIED. C INTEGER NDUM(1) C A DUMMY DIMENSIONED VARIABLE. C LOGICAL NEWPG C THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE OUTPUT C IS TO BEGIN ON A NEW PAGE. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NTIMES C THE NUMBER OF TIMES THE FIRST DIFFERENCE FACTOR HAS BEEN C APPLIED. C INTEGER NYD, NYF C THE NUMBER OF OBSERVATIONS AFTER THE DIFFERENCE FILTER IS C APPLIED. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C INTEGER PHI C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C INTEGER PRHO C THE STARTING LOCATION IN THE WORK AREA FOR PRHO. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHO C THE STARTING LOCATION IN THE WORK AREA FOR SDRHO. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR WORK. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C INTEGER YF C THE STARTING LOCATION IN DSTAK FOR C THE VECTOR CONTAINING THE DIFFERENCE FILTERED SERIES. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'D', ' ', ' '/ C C C SET UP FOR ERROR CHECKING C IERR = 0 LACOV = LAGMAX+1 DIFFER = .TRUE. ISFFT = .FALSE. LYFFT = 0 NFFT = 0 C CALL LDSCMP(7, 0, 0, 0, 0, 0, 'S', 7*LAGMAX+2+N, LDSMIN) C C CALL ERROR CHECKING ROUTINES C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C ACOV = STKGET(LAGMAX+1, IFP) PRHO = STKGET(LAGMAX, IFP) AIC = STKGET(LAGMAX+1, IFP) FTEST = STKGET(2*LAGMAX, IFP) PHI = STKGET(LAGMAX, IFP) WORK = STKGET(LAGMAX, IFP) YF = STKGET(N, IFP) SDRHO = WORK C IF (IERR.EQ.0) THEN C NEWPG = .FALSE. NTIMES = 0 C C CHECK WHETHER THERE IS MORE THAN ONE DIFFERENCE FACTOR. C IF (NFAC.LE.1) THEN CALL SCOPY(N, Y, 1, RSTAK(YF), 1) ELSE C C CREATE NEW DATA BY APPLYING DIFFERENCE FACTORS BEYOND THE C FIRST. C CALL DIFSER(Y, N, NFAC-1, ND(2), IOD(2), RSTAK(YF), NYF) END IF NYD = N C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMN (RSTAK(YF), NYD, MIN(LAGMAX, NYD-1), + RSTAK(ACOV+1), RSTAK(SDRHO), YMEAN, RSTAK(PRHO), + RSTAK(AIC), RSTAK(FTEST), RSTAK(PHI), IAR, OSPVAR, + RSTAK(ACOV), LAGMAX+1, LAGMAX+1, CHIA, CHIAP, RSTAK(WORK), + 1) C YSD = SQRT(RSTAK(ACOV) * N / (N-1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL ACFOUT (YMEAN, YSD, NYF, NYF, MIN(LAGMAX, NYD-1), + RSTAK(ACOV+1), RSTAK(SDRHO), RSTAK(PRHO), NDUM, RSTAK(AIC), + LAGMAX+1, RSTAK(FTEST), IAR, RSTAK(PHI), OSPVAR, CHIA, + CHIAP, LAGMAX, .FALSE., 0.0E0, DIFFER, NEWPG, NFAC, ND, + IOD, NTIMES) C NEWPG = .TRUE. C C COMPUTE CORRELATION ANALYSIS FOR FIRST DIFFERENCE FACTOR C APPLIED 1 TO ND(1) TIMES C IF ((NFAC.GE.1) .AND. (ND(1).GE.1)) THEN DO 50 I = 1, ND(1) C CALL DIFSER(RSTAK(YF), NYD, NFAC-1, ND(2), IOD(2), + RSTAK(YF), NYF) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMN (RSTAK(YF), NYD, MIN(LAGMAX, NYD-1), + RSTAK(ACOV+1), RSTAK(SDRHO), YMEAN, RSTAK(PRHO), + RSTAK(AIC), RSTAK(FTEST), RSTAK(PHI), IAR, OSPVAR, + RSTAK(ACOV), LAGMAX+1, LAGMAX+1, CHIA, CHIAP, + RSTAK(WORK), 1) C YSD = SQRT(RSTAK(ACOV) * N / (N-1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL ACFOUT (YMEAN, YSD, NYF, NYF, MIN(LAGMAX, NYD-1), + RSTAK(ACOV+1), RSTAK(SDRHO), RSTAK(PRHO), NDUM, + RSTAK(AIC), LAGMAX+1, RSTAK(FTEST), IAR, RSTAK(PHI), + OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0, DIFFER, + NEWPG, NFAC, ND, IOD, I) C 50 CONTINUE END IF END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL ACFD (Y, N, LAGMAX, NFAC, ND, IOD, LDSTAK)') END *ACFDTL SUBROUTINE ACFDTL (NDF, ND, IOD, NTIMES) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS TITLING FOR ACORRD. 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 + NDF,NTIMES C C ARRAY ARGUMENTS INTEGER + IOD(*),ND(*) C C LOCAL SCALARS INTEGER + I,IPRT,ISTOP CHARACTER + ICOM*1,IPER*1,IPUNCT*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C CHARACTER*1 ICOM C THE HOLLERITH VALUE -,- (COMMA) C INTEGER IOD(NDF) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C CHARACTER*1 IPER C THE HOLLERITH VALUE -.- (PERIOD) C INTEGER IPRT C THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED C OUTPUT. C CHARACTER*1 IPUNCT C THE HOLLERITH VALUE OF EITHER COMMA OR PERIOD. C INTEGER ISTOP C ONE LESS THAN THE NUMBER OF DIFFERENCE FACTORS. C INTEGER ND(NDF) C THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE C FACTORS ARE TO BE APPLIED. C INTEGER NDF C THE NUMBER OF DIFFERENCE FACTORS. C INTEGER NTIMES C THE NUMBER OF TIMES THE DIFFERENCING FACTOR HAS BEEN APPLIED. C DATA ICOM/','/, IPER/'.'/ C CALL IPRINT (IPRT) C IF (NDF .LE. 1) GO TO 10 C ISTOP = NDF - 1 IPUNCT = IPER IF (NTIMES .GE. 1) IPUNCT = ICOM WRITE(IPRT, 1000) IF (NDF .EQ. 2) WRITE(IPRT, 1001) ND(2), IOD(2), IPER IF (NDF .GE. 3) WRITE(IPRT, 1001) + (ND(I), IOD(I), ICOM, I = 1, ISTOP), ND(NDF), IOD(NDF), IPUNCT GO TO 20 C 10 WRITE(IPRT, 1002) C 20 IF (NTIMES .EQ. 0) RETURN C IF (NDF .GE. 2) WRITE(IPRT, 1003) NTIMES, IOD(1) IF (NDF .EQ. 1) WRITE(IPRT, 1004) NTIMES, IOD(1) RETURN C C FORMAT STATEMENTS C 1000 FORMAT(//47H SERIES ANALYZED IS INPUT SERIES DIFFERENCED BY/) 1001 FORMAT(3X, 3(I3, ' FACTOR(S) OF ORDER ', I3, A1, 1X)/) 1002 FORMAT(//' SERIES ANALYZED IS ORIGINAL INPUT SERIES'/) 1003 FORMAT(4X, 34H AND, IN ADDITION, DIFFERENCED BY , I3, + 18H FACTORS OF ORDER , I3, '.'//) 1004 FORMAT(4X, 16H DIFFERENCED BY , I3, 18H FACTORS OF ORDER , + I3, '.'//) END *ACFER SUBROUTINE ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE ACF FAMILY 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 + LACOV,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NFAC,NFFT LOGICAL + DIFFER,ISFFT C C ARRAY ARGUMENTS INTEGER + IOD(*),ND(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERR(15) CHARACTER + LLACOV(8)*1,LLAGMX(8)*1,LLDS(8)*1,LLGMX1(8)*1, + LLYFFT(8)*1,LN(8)*1,LNFFT(8)*1,LNM1(8)*1,LONE(8)*1, + LTHREE(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERDF C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C LOGICAL ERR(15) C VALUES 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 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 INTEGER IOD(NFAC) C THE ORDER OF EACH OF THE DIFFERENCE VACTORS C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. 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 LLACOV(8), LLAGMX(8), LLDS(8), LLGMX1(8), LLYFFT(8), C * LN(8), LNFFT(8), LNM1(8), LONE(8), LTHREE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER ND(NFAC) C THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE FACTORS C ARE TO BE APPLIED C INTEGER NFAC C THE NUMBER OF FACTORS. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C C C SET UP NAME ARRAYS C DATA + LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5), + LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ',' '/ DATA + LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5), + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5), + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+','1'/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), + LN(6), LN(7), LN(8) /'N',' ',' ',' ',' ',' ',' ',' '/ DATA + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), + LNM1(6), LNM1(7), LNM1(8) /'(','N','-','1',')',' ',' ',' '/ DATA + LNFFT(1), LNFFT(2), LNFFT(3), LNFFT(4), LNFFT(5), + LNFFT(6), LNFFT(7), LNFFT(8) /'N','F','F','T',' ',' ',' ',' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), + LONE(6), LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/ DATA + LTHREE(1), LTHREE(2), LTHREE(3), LTHREE(4), LTHREE(5), + LTHREE(6), LTHREE(7), LTHREE(8) /'T','H','R','E','E',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. DO 10 I = 1, 15 ERR(I) = .FALSE. 10 CONTINUE C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR(1), LTHREE) C IF (.NOT.ERR(1)) THEN C CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2), LONE, + LNM1) C IF (DIFFER) CALL ERDF(NMSUB, NFAC, ND, IOD, N, HEAD, ERR(3)) C IF (.NOT.ERR(2)) THEN C CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 2, HEAD, ERR(4), + LLGMX1) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(5), LLDS) C IF (ISFFT) + CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 2, HEAD, ERR(6), + LNFFT) END IF END IF C DO 20 I = 1, 15 IF (ERR(I)) IERR = 1 20 CONTINUE C RETURN C END *ACF SUBROUTINE ACF (Y, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C (SHORT CALL). 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 + N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + IAR,IPRT,LACOV,LAGMAX,LAIC,LDSMIN,LDSTAK,LYFFT,NFAC,NFFT, + NPRT LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100), + SDRHO(100),WORK(100) INTEGER + IOD(1),ND(1),NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMN,ACFOUT,IPRINT,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (ACOV(2),RHO(1)) EQUIVALENCE (WORK(1),SDRHO(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR. C REAL AIC(101) C THE ARRAY CONTAINING AKIAKES CRITERIA FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C REAL FTEST(2, 100) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY ARRAY. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING THE PRINTED OUTPUT. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR). C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C REAL PRHO(100) C THE ARRAY CONTAINING THE PARTIAL ACF ESTIMATES. C REAL RHO(100) C THE ARRAY CONTAINING THE ACF ESTIMATES. C REAL SDRHO(100) C THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF ESTIMATES. C REAL WORK(100) C A VECTOR USED IN THE COMPUTATIONS OF THE PARTIAL C AUTOCORRELATION COEFFICIENTS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN, YSD C THE MEAN AND STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 LAGMAX = 1 LACOV = 101 LAIC = 101 LDSMIN = 0 LDSTAK = 0 NPRT = 1 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .FALSE. LYFFT = N NFFT = N C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C IF (IERR.EQ.0) THEN C C SET NUMBER OF ACF TO BE COMPUTED C CALL SETLAG (N, LAGMAX) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMN (Y, N, LAGMAX, RHO, SDRHO, YMEAN, PRHO, AIC, FTEST, + PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, CHIAP, WORK, NPRT) C YSD = SQRT(ACOV(1) * N / (N-1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL ACFOUT (YMEAN, YSD, N, N, LAGMAX, RHO, SDRHO, PRHO, NDUM, + AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP, LAGMAX, + .FALSE., 0.0E0, .FALSE., .FALSE., 0, NDUM, NDUM, 0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 22H CALL ACF (Y, N)) END *ACFF SUBROUTINE ACFF (YFFT, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C USING AN FFT (SHORT CALL). 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + IAR,IFP,IPRT,LACOV,LAGMAX,LAIC,LDSMIN,NALL0,NFAC,NFFT, + SDRHO,WORK LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100), + RSTAK(12) INTEGER + IOD(1),ND(1),NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMNF,ACFOUT,FFTLEN,IPRINT,LDSCMP,SETLAG,STKCLR, + STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (ACOV(2),RHO(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE VECTOR. C REAL AIC(101) C THE ARRAY CONTAINING AKAIKES CRITERIA FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FTEST(2, 100) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0 ERRORS WERE DETECTED. C INTEGER IFP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING C POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION. C INTEGER IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY ARRAY. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR). C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C REAL PRHO(100) C THE ARRAY CONTAINING THE PARITAL ACF ESTIMATES. C REAL RHO(100) C THE ARRAY CONTAINING THE ACF ESTIMATES. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHO C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF ESTIMATES. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR WORK. C REAL YFFT(LYFFT) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'F', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 LACOV = 101 LAIC = 101 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .TRUE. C IF (N.GE.3) THEN C C SET NUMBER OF ACF TO BE COMPUTED C AND LENGTH OF EXTENDED SERIES C CALL SETLAG(N, LAGMAX) CALL FFTLEN(N+LAGMAX, 4, NFFT) END IF C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C C CALL ERROR CHECKING ROUTINES C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C WORK = STKGET(NFFT, IFP) SDRHO = WORK C IF (IERR.EQ.0) THEN C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMNF (YFFT, N, NFFT, LAGMAX, RHO, RSTAK(SDRHO), YMEAN, + PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, + CHIA, CHIAP, LYFFT, RSTAK(WORK), NFFT, 1) C YSD = SQRT (ACOV(1) * N / (N - 1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL ACFOUT(YMEAN, YSD, N, N, LAGMAX, RHO, RSTAK(SDRHO), PRHO, + NDUM, AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP, + LAGMAX, .FALSE., 0.0E0, .FALSE., .FALSE., 0, NDUM, NDUM, + 0) END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL ACFF (YFFT, N, LYFFT, LDSTAK)') END *ACFFS SUBROUTINE ACFFS (YFFT, N, LYFFT, LDSTAK, LAGMAX, LACOV, ACOV, + IAR, PHI, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C USING A FFT WITH THE COMPUTED ACVF ESTIMATES RETURNED TO THE USERS C ROUTINE (LONG CALL). 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 + IAR,LACOV,LAGMAX,LDSTAK,LYFFT,N,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),PHI(*),YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + AIC,FTEST,I,IFP,IPRT,LDSMIN,NALL0,NFAC,NFFT,PRHO,SDRHO, + WORK LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + IOD(1),ND(1),NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMNF,ACFOUT,FFTLEN,IPRINT,LDSCMP,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE VECTOR. C INTEGER AIC C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER FTEST C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES C INTEGER I C AN INDEXING VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 INTEGER IFP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING C POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION. C INTEGER IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY DIMENSIONED VARIABLE. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C INTEGER PRHO C THE STARTING LOCATION IN THE WORK AREA FOR PRHO. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHO C THE STARTING LOCATION IN THE WORK AREA FOR SDRHO. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR WORK. C REAL YFFT(LYFFT) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'F', 'S', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .TRUE. C C SET LENGTH OF EXTENDED SERIES C NFFT = 0 IF ((N.GE.3) .AND. (LAGMAX.GE.1)) CALL FFTLEN(N+LAGMAX, 4, NFFT) C CALL LDSCMP(4, 0, 0, 0, 0, 0, 'S', (4*LAGMAX+1) + NFFT, LDSMIN) C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C WORK = STKGET(NFFT, IFP) PRHO = STKGET(LAGMAX, IFP) AIC = STKGET(LAGMAX+1, IFP) FTEST = STKGET(2*LAGMAX, IFP) SDRHO = WORK C IF (IERR.EQ.0) THEN C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMNF (YFFT, N, NFFT, LAGMAX, ACOV(2), RSTAK(SDRHO), + YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST), PHI, + IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA, CHIAP, + LYFFT, RSTAK(WORK), NFFT, NPRT) C YSD = SQRT (ACOV(1) * N / (N - 1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C IF ((NPRT.NE.0) .OR. (ACOV(1).EQ.0.0E0)) + CALL ACFOUT (YMEAN, YSD, N, N, LAGMAX, ACOV(2), + RSTAK(SDRHO), + RSTAK(PRHO), NDUM, RSTAK(AIC), LAGMAX+1, RSTAK(FTEST), IAR, + PHI, OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0, .FALSE., + .FALSE., 0, NDUM, NDUM, 0) C IF (NPRT.NE.0) THEN DO 50 I = 1, LAGMAX ACOV(I+1) = ACOV(I+1) * ACOV(1) 50 CONTINUE END IF C END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL ACFFS (YFFT, N, LYFFT, LDSTAK,'/ + ' + LAGMAX, LACOV, ACOV, IAR, PHI, NPRT)') END *ACFLST SUBROUTINE ACFLST (RHO, SDRHO, NLPPA, LAGMAX, IFMISS, CHIA, + NDFCHI, CHIAP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE ACTUALLY LISTS THE AUTOCORRELATIONS OR C PARTIAL AUTOCORRELATIONS AND OTHER PERTINENT INFORMATION. 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 REAL + CHIA,CHIAP INTEGER + LAGMAX,NDFCHI LOGICAL + IFMISS C C ARRAY ARGUMENTS REAL + RHO(*),SDRHO(*) INTEGER + NLPPA(*) C C LOCAL SCALARS REAL + FPLM INTEGER + I,IMAX,IMIN,IPRT,LAG,NPERL C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CHIA, CHIAP C THE VARIABLES IN CHICH THE CHI SQUARE STATISTIC AND C PROBABILITY FOR THE AUTOCORRELATIONS ARE STORED. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C LOGICAL IFMISS C THE INDICATOR VARIABLE USED TO DETERMINE C WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT. C INTEGER IMAX, IMIN C THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION C TO BE PRINTED PER LINE C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT C INTEGER LAG C THE LAG VALUE OF THE AUTOCORRELATION OR PARTIAL C AUTOCORRELATION BEING PRINTED. C INTEGER LAGMAX C THE NUMBER OF AUTOCORRELATIONS OR PARTIAL AUTOCORRELATIONS C TO BE PRINTED. C INTEGER NDFCHI C THE DEGREES OF FREEDOM FOR THE CHI SQUARED STATISTIC. C INTEGER NLPPA(LAGMAX) C THE ARRAY IN WHICH THE NUMBER OF LAGGED PRODUCT PAIRS USED TO C COMPUTE EACH AUTOCORRELATION IS STORED C INTEGER NPERL C THE NUMBER OF VALUES TO BE PRINTED PER LINE. C REAL RHO(LAGMAX) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED. C REAL SDRHO(LAGMAX) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C C FPLM = R1MACH(2) C CALL IPRINT(IPRT) C NPERL = 12 DO 30 I = 1, LAGMAX, NPERL IMIN = I IMAX = MIN(I + NPERL - 1, LAGMAX) WRITE(IPRT, 1000) (LAG, LAG = IMIN, IMAX) WRITE(IPRT, 1001) (RHO(LAG), LAG = IMIN, IMAX) WRITE(IPRT, 1002) (SDRHO(LAG), LAG = IMIN, IMAX) IF (IFMISS) WRITE(IPRT, 1003) (NLPPA(LAG), LAG = IMIN, IMAX) 30 CONTINUE C IF (SDRHO(LAGMAX) .EQ. FPLM) WRITE(IPRT, 1004) FPLM C WRITE (IPRT, 1005) CHIA, NDFCHI, CHIAP C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/19H LAG , 12(1X, I6)) 1001 FORMAT( 19H ACF , 12(2X, F5.2)) 1002 FORMAT( 19H STANDARD ERROR , 12(2X, F5.2)) 1003 FORMAT( 19H NO. OF OBS. USED , 12(1X, I6)) 1004 FORMAT(///5X, F5.2, 38H INDICATES VALUE COULD NOT BE COMPUTED, + ' DUE TO MISSING DATA.') 1005 FORMAT(///33H THE CHI SQUARE TEST STATISTIC OF/ + 40H THE NULL HYPOTHESIS OF WHITE NOISE =, G21.4/ + 40H DEGREES OF FREEDOM =, I17/ + 40H OBSERVED SIGNIFICANCE LEVEL =, F17.4) END *ACFM SUBROUTINE ACFM (Y, YMISS, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C WITH MISSING VALUES (SHORT CALL). 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 REAL + YMISS INTEGER + N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + IAR,IPRT,LACOV,LAGLST,LAGMAX,LAIC,LDSMIN,LDSTAK,LYFFT, + NFAC,NFFT,NPRT LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + ACOV(101),AIC(101),FTEST(2,100),PHI(100),PRHO(100),RHO(100), + SDRHO(100),WORK(100) INTEGER + IOD(1),ND(1),NDUM(1),NLPPA(101) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMNM,ACFOUT,IPRINT,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (ACOV(2),RHO(1)) EQUIVALENCE (WORK(1),SDRHO(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE VECTOR. C REAL AIC(101) C THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C REAL FTEST(2, 100) C THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE C SERIES NOT TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C A DUMMY VARIABLE. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY ARRAY. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPA(101) C THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS C USED TO COMPUTE EACH ACVF ESTIMATE. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C REAL PRHO(100) C THE ARRAY CONTAINING THE PACF ESTIMATES. C REAL RHO(100) C THE ARRAY CONTAINING THE ACF ESTIMATES. C REAL SDRHO(100) C THE ARRAY CONTAINING THE STANDARD ERRORS OF THE ACF. C REAL WORK(100) C THE ARRAY CONTAINING WORK AREA FOR THE PACF COMPUTATIONS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER C OR NOT AN OBSERVATION IN THE SERIES IS MISSING. C IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING. C IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING. C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'M', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 LAGMAX = 1 LACOV = 101 LAIC = 101 NPRT = 1 LDSMIN = 0 LDSTAK = 0 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .FALSE. LYFFT = N NFFT = N C C CALL ERROR CHECKING ROUTINES C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET LARGEST LAG TO BE USED. C CALL SETLAG(N, LAGMAX) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMNM (Y, YMISS, N, LAGMAX, RHO, SDRHO, NLPPA, YMEAN, + PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, + CHIAP, LAGLST, WORK, NPRT) C YSD = ACOV(1) IF (LAGLST.GE.0) YSD = SQRT (ACOV(1) * N / (N - 1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL ACFOUT (YMEAN, YSD, N, NLPPA(1), LAGMAX, RHO, SDRHO, PRHO, + NLPPA, AIC, LAGMAX+1, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP, + LAGLST, .TRUE., YMISS, .FALSE., .FALSE., 0, NDUM, NDUM, 0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 30H CALL ACFM (Y, YMISS, N)) END *ACFMN SUBROUTINE ACFMN(Y, N, LAGMAX, RHO, SDRHO, YMEAN, PRHO, AIC, + FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, CHIAP, WORK, + NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND C PARTIAL AUTOCORRELATIONS OF A 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 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + CHIA,CHIAP,OSPVAR,YMEAN INTEGER + IAR,LACOV,LAGMAX,LAIC,N,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*), + WORK(*),Y(*) C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL ACFSD,ACVF,AOS,CHIRHO C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR. C REAL AIC(LAIC) C THE ARRAY CONTAINING AKAIAES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C REAL FTEST(2, LAGMAX) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER (IAR). C REAL PRHO(LAGMAX) C THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED C REAL RHO(LAGMAX) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(LAGMAX) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C REAL WORK(LAGMAX) C AN ARRAY USED IN THE COMPUTATIONS OF THE PARTIAL C AUTOCORRELATIONS COEFFICIENTS. C ARE STORED C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C COMPUTE AUTOCOVARIANCESS AND STANDARD DEVIATION OF THE SERIES. C CALL ACVF(Y, N, YMEAN, ACOV, LAGMAX, LACOV) C IF (ACOV(1) .EQ. 0.0E0) RETURN C C COMPUTE PARTIAL AUTOCORRELATIONS AND THE AUTOREGRESSIVE MODEL C ORDER SELECTION STATISTICS. C CALL AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK, + AIC, FTEST, LACOV, LAIC) C IF (NPRT .EQ. 0) RETURN C C COMPUTE AUTOCORRELATIONS C DO 10 I = 1, LAGMAX RHO(I) = ACOV(I+1) / ACOV(1) 10 CONTINUE C C COMPUTE STANDARD ERROR OF AUTOCORRELATIONS. C CALL ACFSD (RHO, SDRHO, LAGMAX, N) C C COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES C CALL CHIRHO (RHO, N, LAGMAX, CHIA, CHIAP) C RETURN END *ACFMNF SUBROUTINE ACFMNF (YFFT, N, NFFT, LAGMAX, RHO, SDRHO, YMEAN, + PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, + CHIA, CHIAP, LYFFT, WORK, LWORK, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND C PARTIAL AUTOCORRELATIONS OF A 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 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + CHIA,CHIAP,OSPVAR,YMEAN INTEGER + IAR,LACOV,LAGMAX,LAIC,LWORK,LYFFT,N,NFFT,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*), + WORK(*),YFFT(*) C C LOCAL SCALARS INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL ACFSD,ACVFF,AOS,CHIRHO C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR. C REAL AIC(LAIC) C THE AKAIKES INFORMATION CRITERION VECTOR. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C REAL FTEST(2, LAGMAX) C THE ARRAY IN WHICH THE PARTIAL F RATIOS AND PROBABILITIES C ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER (IAR). C REAL PRHO(LAGMAX) C THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED C REAL RHO(LAGMAX) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(LAGMAX) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C REAL WORK(LWORK) C A WORK ARRAY. C REAL YFFT(LYFFT) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C COMPUTE AUTOCOVARIANCESS AND STANDARD DEVIATION OF THE SERIES. C CALL ACVFF(YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, LYFFT, WORK, + LWORK) C IF (ACOV(1) .EQ. 0.0E0) RETURN C C COMPUTE PARTIAL AUTOCORRELATIONS AND AUTOREGRESSIVE ORDER C SELECTION STATISTICS. C CALL AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK, + AIC, FTEST, LACOV, LAIC) C IF (NPRT .EQ. 0) RETURN C C COMPUTE AUTOCORRELATIONS C DO 10 I = 1, LAGMAX RHO(I) = ACOV(I+1) / ACOV(1) 10 CONTINUE C C COMPUTE STANDARD ERROR OF AUTOCORRELATIONS. C CALL ACFSD (RHO, SDRHO, LAGMAX, N) C C COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES C CALL CHIRHO (RHO, N, LAGMAX, CHIA, CHIAP) C RETURN END *ACFMNM SUBROUTINE ACFMNM(Y, YMISS, N, LAGMAX, RHO, SDRHO, NLPPA, YMEAN, + PRHO, AIC, FTEST, PHI, IAR, OSPVAR, ACOV, LACOV, LAIC, CHIA, + CHIAP, LAGLST, WORK, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND C PARTIAL AUTOCORRELATIONS OF A TIME SERIES WITH MISSING DATA. 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 REAL + CHIA,CHIAP,OSPVAR,YMEAN,YMISS INTEGER + IAR,LACOV,LAGLST,LAGMAX,LAIC,N,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),AIC(*),FTEST(2,*),PHI(*),PRHO(*),RHO(*),SDRHO(*), + WORK(*),Y(*) INTEGER + NLPPA(*) C C LOCAL SCALARS REAL + FPLM INTEGER + I,NUSED C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL ACFSDM,ACVFM,AOS,CHIRHO C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE FUNCTION ESTIMATE VECTOR. C REAL AIC(LAIC) C THE ARRAY CONTAINING AKAIAES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL FTEST(2, LAGMAX) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE C SERIES NOT TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER NLPPA(LACOV) C THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS C USED TO COMPUTE THE ACVF AT EACH LAG. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C INTEGER NUSED C THE NUMBER OF ACTIVE (NOT MISSING) OBSERVATIONS IN THE SERIES. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER (IAR). C REAL PRHO(LAGMAX) C THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED C REAL RHO(LAGMAX) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(LAGMAX) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C REAL WORK(LAGMAX) C AN ARRAY USED IN THE COMPUTATIONS OF THE PARTIAL C AUTOCORRELATIONS COEFFICIENTS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER C OR NOT AN OBSERVATION IN THE SERIES IS MISSING. C IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING. C IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING. C C FPLM = R1MACH(2) C C COMPUTE AUTOCOVARIANCES OF THE SERIES WITH MISSING DATA. C CALL ACVFM(Y, YMISS, N, YMEAN, ACOV, LAGMAX, LAGLST, NLPPA, LACOV) C IF (NLPPA(1) .EQ. 0 .OR. ACOV(1) .EQ. 0.0E0) RETURN C IF (NPRT .EQ. 0) RETURN C C COMPUTE PARTIAL AUTOCORRELATIONS AND THE AUTOREGRESSIVE MODEL C ORDER SELECTION STATISTICS IF THERE WERE NO MISSING DATA. C IF (NLPPA(1) .EQ. N) CALL AOS (N, LAGMAX, ACOV, PRHO, IAR, + OSPVAR, PHI, WORK, AIC, FTEST, LACOV, LAIC) C C COMPUTE AUTOCORRELATIONS. C DO 10 I = 1, LAGMAX IF (NLPPA(I+1) .GE. 1) RHO(I) = ACOV(I+1) / ACOV(1) 10 CONTINUE C C PRESET SDRHO VALUES FOR PRINTING ROUTINE C DO 20 I = LAGLST, LAGMAX SDRHO(I) = FPLM 20 CONTINUE C C COMPUTE STANDARD ERROR OF AUTOCORRELATIONS. C CALL ACFSDM (RHO, SDRHO, LAGLST, N, NLPPA(2)) C IF (LAGLST .EQ. 0) RETURN C C COMPUTE CHI STATISTIC BASED ON AUTOCORRELATION VALUES C NUSED = NLPPA(1) C CALL CHIRHO (RHO, NUSED, LAGLST, CHIA, CHIAP) C RETURN END *ACFMS SUBROUTINE ACFMS (Y, YMISS, N, LAGMAX, LACOV, ACOV, AMISS, NLPPA, + NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS OF A TIME SERIES WITH MISSING VALUES (LONG CALL). 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 REAL + AMISS,YMISS INTEGER + LACOV,LAGMAX,LDSTAK,N,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),Y(*) INTEGER + NLPPA(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + CHIA,CHIAP,FPLM,OSPVAR,YMEAN,YSD INTEGER + AIC,FTEST,I,IAR,IFP,IPRT,LAGLST,LDSMIN,LYFFT,NALL0,NFAC, + NFFT,PHI,PRHO,SDRHO,WORK LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + IOD(1),ND(1),NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + STKGET,STKST EXTERNAL R1MACH,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMNM,ACFOUT,IPRINT,LDSCMP,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE VECTOR. C INTEGER AIC C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER. C REAL AMISS C THE MISSING VALUE CODE FOR THE RETURNED ACVF ESTIMATES C (VECTOR ACOV). C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER FTEST C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 INTEGER IFP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING C POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION. C INTEGER IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF THE C SERIES NOT TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY ARRAY. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPA(LACOV) C THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS C USED TO COMPUTE EACH ACVF ESTIMATE. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C INTEGER PHI C THE STARTING LOCATION IN DSTAK FOR THE C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C INTEGER PRHO C THE STARTING LOCATION IN THE WORK AREA FOR PRHO. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHO C THE STARTING LOCATION IN THE WORK AREA FOR SDRHO. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR WORK. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER C OR NOT AN OBSERVATION IN THE SERIES IS MISSING. C IF Y(I) .EQ. YMISS, THE VALUE IS ASSUMED MISSING. C IF Y(I) .NE. YMISS, THE VALUE IS ASSUMED NOT MISSING. C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'M', 'S', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .FALSE. LYFFT = N NFFT = N C IF (NPRT .EQ. 0) THEN LDSMIN = 0 ELSE CALL LDSCMP(5, 0, 0, 0, 0, 0, 'S', 6*LAGMAX+1, LDSMIN) END IF C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C FPLM = R1MACH(2) C AMISS = FPLM C IF (NPRT.EQ.0) THEN C C SPECIFY STARTING LOCATIONS IN THE STACK FOR DUMMY VARIABLES C PRHO = 1 AIC = 1 FTEST = 1 PHI = 1 WORK = 1 SDRHO = 1 ELSE C IFP = 3 C PRHO = STKGET(LAGMAX, IFP) AIC = STKGET(LAGMAX+1, IFP) FTEST = STKGET(2*LAGMAX, IFP) PHI = STKGET(LAGMAX, IFP) WORK = STKGET(LAGMAX, IFP) SDRHO = WORK END IF C IF (IERR.EQ.0) THEN C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMNM (Y, YMISS, N, LAGMAX, ACOV(2), RSTAK(SDRHO), + NLPPA, YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST), + RSTAK(PHI), IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA, + CHIAP, LAGLST, RSTAK(WORK), NPRT) C IF (LAGLST .GE. 0) THEN YSD = SQRT (ACOV(1) * N / (N - 1)) ELSE YSD = ACOV(1) END IF C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C IF ((NPRT.NE.0) .OR. (ACOV(1).EQ.0.0E0)) + CALL ACFOUT (YMEAN, YSD, N, NLPPA(1), LAGMAX, ACOV(2), + RSTAK(SDRHO), RSTAK(PRHO), NLPPA, RSTAK(AIC), LAGMAX+1, + RSTAK(FTEST), IAR, RSTAK(PHI), OSPVAR, CHIA, CHIAP, + LAGLST, .TRUE., YMISS, .FALSE., .FALSE., 0, NDUM, NDUM, + 0) C IF (NPRT.NE.0) THEN DO 50 I = 1, LAGMAX ACOV(I+1) = ACOV(I+1) * ACOV(1) 50 CONTINUE END IF END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL ACFMS (Y, YMISS, N,'/ + ' + LAGMAX, LACOV, ACOV, AMISS, NLPPA, NPRT,', + ' LDSTAK)') END *ACFOUT SUBROUTINE ACFOUT (YMEAN, YSD, N, NUSED, LAGMAX, RHO, SDRHO, + PRHO, NLPPA, AIC, LAIC, FTEST, IAR, PHI, OSPVAR, CHIA, CHIAP, + NDFCHI, IFMISS, YMISS, DIFFER, NEWPG, NFAC, ND, IOD, NTIMES) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE AUTOCORRELATIONS AND THEIR C STANDARD ERRORS, AS WELL AND THE PARTIAL AUTOCORRELATIONS C AND MISCELLANEOUS SUMMARY INFORMATION. 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 REAL + CHIA,CHIAP,OSPVAR,YMEAN,YMISS,YSD INTEGER + IAR,LAGMAX,LAIC,N,NDFCHI,NFAC,NTIMES,NUSED LOGICAL + DIFFER,IFMISS,NEWPG C C ARRAY ARGUMENTS REAL + AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX),PRHO(LAGMAX), + RHO(LAGMAX),SDRHO(LAGMAX) INTEGER + IOD(*),ND(*),NLPPA(LAGMAX) C C LOCAL SCALARS REAL + FPLM,PMISS INTEGER + IPRT,NMISS C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL ACFDTL,ACFLST,AOSLST,IPRINT,VERSP,VPMN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AIC(LAIC) C THE ARRAY CONTAINING THE AKAIKES INFORMATION CRITERION. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE VARIABLE USED TO DESIGNATE WHETHER OR NOT THE SERIES C ANALYZED WAS DIFFERENCED OR NOT. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL FTEST(2, LAGMAX) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C LOGICAL IFMISS C THE INDICATOR VARIABLE USED TO DETERMINE C WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT. C INTEGER IOD(NFAC) C THE ORDER OF EACH OF THE DIFFERENCING FACTORS. C INTEGER IPRT C THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED C OUTPUT. C INTEGER ISYM(1) C A DUMMY ARRAY. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE USED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER ND(NFAC) C THE ARRAY CONTANING THE NUMBER OF TIMES THE DIFFERENCING C FACTORS ARE TO BE APPLIED. C INTEGER NDFCHI C THE DEGREES OF FREEDOM FOR THE CHI SQUARED STATISTIC. C LOGICAL NEWPG C THE VARIABLE DESIGNATING WHETHER OR NOT THE OUTPUT IS TO C START ON A NEW PAGE. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS. C INTEGER NLPPA(LAGMAX) C THE ARRAY OF NUMBERS OF LAGGED PRODUCT PAIRS USED TO C COMPUTE EACH ACF ESTIMATE. C INTEGER NMISS C THE NUMBER OF MISSING OBSERVATIONS. C INTEGER NTIMES C THE NUMBER OF TIMES THE FIRST DIFFERENCE FACTOR HAS BEEN C APPLIED. C INTEGER NUSED C THE ACTIVE NUMBER OF OBSERVATIONS. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C REAL PMISS C THE PERCENT OF MISSING OBSERVATIONS. C REAL PRHO(LAGMAX) C THE ARRAY IN WHICH THE PARTIAL AUTOCORRELATIONS ARE STORED C REAL RHO(LAGMAX) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(LAGMAX) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C REAL YMEAN C THE MEAN OF THE OBSERVED SERIES. C REAL YMISS, YMMISS(1) C THE MISSING VALUE CODE. C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED SERIES. C C FPLM = R1MACH(2) C YMMISS(1) = FPLM C C PRINT SUMMARY INFORMATION C CALL IPRINT(IPRT) C IF (NEWPG) WRITE(IPRT, 1004) C CALL VERSP (.TRUE.) WRITE(IPRT, 1005) IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES) WRITE(IPRT, 1000) YMEAN, YSD, N IF (.NOT. IFMISS) GO TO 10 NMISS = N - NUSED PMISS = 100.0E0 * NMISS / N WRITE(IPRT, 1003) NMISS, PMISS 10 WRITE(IPRT, 1006) LAGMAX IF (IFMISS) WRITE(IPRT, 1007) YMISS C IF (YSD .GT. 0.0E0) GO TO 20 C WRITE (IPRT, 1010) RETURN C 20 CONTINUE C C PRINT ACF INFORMATION C WRITE(IPRT, 1008) WRITE(IPRT, 1001) CALL ACFLST (RHO, SDRHO, NLPPA, LAGMAX, IFMISS, CHIA, NDFCHI, + CHIAP) C C PLOT ACF INFORMATION C WRITE(IPRT, 1004) CALL VERSP (.TRUE.) WRITE(IPRT, 1001) IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES) CALL VPMN(RHO, YMMISS, LAGMAX, 1, LAGMAX, 1, 0, ISYM, 1, 0, + -1.0E0, 1.0E0, 1.0E0, 1.0E0, IFMISS, 0, 0, 1) C C CHECK WHETHER PACF HAVE BEEN COMPUTED C IF (NUSED .LE. N-1) RETURN C C PRINT PACF INFORMATION AND AUTOREGRESSIVE MODEL ORDER SELECTION C STATISTICS C WRITE(IPRT, 1004) CALL VERSP (.TRUE.) WRITE(IPRT, 1002) WRITE (IPRT, 1009) IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES) CALL AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI, OSPVAR, + .TRUE., N) C C PLOT PACF INFORMATION C WRITE(IPRT, 1004) CALL VERSP (.TRUE.) WRITE(IPRT, 1002) IF (DIFFER) CALL ACFDTL(NFAC, ND, IOD, NTIMES) CALL VPMN(PRHO, YMMISS, NDFCHI, 1, NDFCHI, 1, 0, ISYM, 1, 0, + -1.0E0, 1.0E0, 1.0E0, 1.0E0, IFMISS, 0, 0, 1) RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/ + ' AVERAGE OF THE SERIES = ', G14.7/ + ' STANDARD DEVIATION OF THE SERIES = ', G14.7/ + ' NUMBER OF TIME POINTS = ', I10) 1001 FORMAT (40H AUTOCORRELATION FUNCTION ESTIMATE (ACF)/) 1002 FORMAT (49H PARTIAL AUTOCORRELATION FUNCTION ESTIMATE (PACF)/) 1003 FORMAT ( + ' NUMBER OF MISSING OBSERVATIONS = ', I10/ + ' PERCENTAGE OF OBSERVATIONS MISSING = ', F10.4) 1004 FORMAT ('1') 1005 FORMAT ( 25H AUTOCORRELATION ANALYSIS) 1006 FORMAT( + ' LARGEST LAG VALUE USED = ', I10) 1007 FORMAT( + ' MISSING VALUE CODE = ', G14.7) 1008 FORMAT(//) 1009 FORMAT (46H AND AUTOREGRESSIVE ORDER SELECTION STATISTICS///) 1010 FORMAT (///36H THE AUTOCORRELATIONS OF THIS SERIES, + 22H COULD NOT BE COMPUTED/ + 50H BECAUSE THE LAG ZERO AUTOCOVARIANCE OF THE SERIES, + 9H IS ZERO.) END *ACFSD SUBROUTINE ACFSD (RHO, SDRHO, NC, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE STANDARD ERROR OF THE AUTOCORRELATIONS 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 + N,NC C C ARRAY ARGUMENTS REAL + RHO(*),SDRHO(*) C C LOCAL SCALARS INTEGER + K,KLAST,LAG C C INTRINSIC FUNCTIONS INTRINSIC MIN,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER K C AN INDEX VARIABLE. C INTEGER KLAST C THE LAST LAG VALUE TO BE USED. C INTEGER LAG C THE INDEX VARIABLE USED TO INDICATE THE AUTOCORRELATION C BEING EXAMINED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NC C THE NUMBER OF AUTOCORRELATIONS COMPUTED C REAL RHO(NC) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(NC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C SDRHO(1) = SQRT(REAL(N - 1)) / N IF (NC .EQ. 1) RETURN DO 20 LAG = 2, NC SDRHO(LAG) = 0.0E0 KLAST = MIN(LAG-1, N-LAG) DO 10 K = 1, KLAST SDRHO(LAG) = SDRHO(LAG) + (N-LAG-K) * RHO(K) * RHO(K) 10 CONTINUE SDRHO(LAG) = SQRT((N-LAG) + 2.0E0 * SDRHO(LAG)) / N 20 CONTINUE RETURN END *ACFSDM SUBROUTINE ACFSDM (RHO, SDRHO, NC, N, NLPPA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE STANDARD ERROR OF THE AUTOCORRELATIONS C WHEN MISSING DATA ARE INVOLVED. 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 + N,NC C C ARRAY ARGUMENTS REAL + RHO(*),SDRHO(*) INTEGER + NLPPA(*) C C LOCAL SCALARS INTEGER + K,KLAST,LAG C C INTRINSIC FUNCTIONS INTRINSIC MIN,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER K C AN INDEX VARIABLE. C INTEGER KLAST C THE LAST LAG VALUE TO BE USED. C INTEGER LAG C THE INDEX VARIABLE USED TO INDICATE THE AUTOCORRELATION C BEING EXAMINED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NC C THE NUMBER OF AUTOCORRELATIONS COMPUTED C INTEGER NLPPA(NC) C THE ARRAY IN WHICH THE NUMBER OF OBSERVATIONS USED TO C COMPUTE EACH AUTOCORRELATION AND PARTIAL AUTOCORRELATION C IS STORED C REAL RHO(NC) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C REAL SDRHO(NC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C SDRHO(1) = SQRT(REAL(NLPPA(1))) * (N-1) / (N * NLPPA(1)) IF (NC .EQ. 1) RETURN DO 20 LAG = 2, NC SDRHO(LAG) = 0.0E0 KLAST = MIN(LAG-1, N-LAG) DO 10 K = 1, KLAST SDRHO(LAG) = SDRHO(LAG) + (N-LAG-K) * RHO(K) * RHO(K) 10 CONTINUE SDRHO(LAG) = SQRT((N-LAG) + 2.0E0 * SDRHO(LAG)) * + (N-LAG) / (N*NLPPA(LAG)) 20 CONTINUE RETURN END *ACFS SUBROUTINE ACFS(Y, N, LAGMAX, LACOV, ACOV, IAR, PHI, NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE AUTO- C CORRELATIONS AND PARTIAL AUTOCORRELATIONS OF A TIME SERIES C WITH THE COMPUTED ACVF ESTIMATES RETURNED TO THE USERS C ROUTINE (LONG CALL). 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 + IAR,LACOV,LAGMAX,LDSTAK,N,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),PHI(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + CHIA,CHIAP,OSPVAR,YMEAN,YSD INTEGER + AIC,FTEST,I,IFP,IPRT,LDSMIN,LYFFT,NALL0,NFAC,NFFT,PRHO, + SDRHO,WORK LOGICAL + DIFFER,ISFFT C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + IOD(1),ND(1),NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACFER,ACFMN,ACFOUT,IPRINT,LDSCMP,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE VECTOR. C INTEGER AIC C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE AKAIKES CRITERION FOR EACH ORDER. C REAL CHIA, CHIAP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARED STATISTIC PROBABILITY FOR THE AUTOCORRELATIONS C ARE STORED. C LOGICAL DIFFER C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE IS ACFD (DIFFER = TRUE) OR NOT (DIFFER = FALSE) C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER FTEST C THE STARTING LOCATION IN DSTAK FOR C THE ARRAY CONTAINING THE PARTIAL F RATIO AND PROBABILITIES C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 INTEGER IFP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE FLOATING C POINT VARIABLES ARE SINGLE (IFP=3) OR DOUBLE (IFP=4) PRECISION. C INTEGER IOD(1) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C INTEGER ND(1) C THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED C INTEGER NDUM(1) C A DUMMY DIMENSIONED VARIABLE. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS MADE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C INTEGER PRHO C THE STARTING LOCATION IN THE WORK AREA FOR PRHO. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHO C THE STARTING LOCATION IN THE WORK AREA FOR SDRHO. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR WORK. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'C', 'F', 'S', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 DIFFER = .FALSE. NFAC = 1 ND(1) = 0 IOD(1) = 0 ISFFT = .FALSE. LYFFT = N NFFT = N C C CALL LDSCMP(4, 0, 0, 0, 0, 0, 'S', 5*LAGMAX+1, LDSMIN) C CALL ACFER(NMSUB, N, LAGMAX, LACOV, LDSTAK, LDSMIN, + DIFFER, NFAC, ND, IOD, ISFFT, LYFFT, NFFT) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C PRHO = STKGET(LAGMAX, IFP) AIC = STKGET(LAGMAX+1, IFP) FTEST = STKGET(2*LAGMAX, IFP) WORK = STKGET(LAGMAX, IFP) SDRHO = WORK C IF (IERR.EQ.0) THEN C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C CALL ACFMN (Y, N, LAGMAX, ACOV(2), RSTAK(SDRHO), + YMEAN, RSTAK(PRHO), RSTAK(AIC), RSTAK(FTEST), PHI, + IAR, OSPVAR, ACOV, LACOV, LAGMAX+1, CHIA, CHIAP, + RSTAK(WORK), NPRT) C YSD = SQRT (ACOV(1) * N / (N - 1)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C IF ((NPRT.NE.0) .OR. (ACOV(1).EQ.0.0E0)) CALL ACFOUT + (YMEAN, YSD, N, N, LAGMAX, ACOV(2), RSTAK(SDRHO), + RSTAK(PRHO), NDUM, RSTAK(AIC), LAGMAX+1, RSTAK(FTEST), + IAR, PHI, OSPVAR, CHIA, CHIAP, LAGMAX, .FALSE., 0.0E0, + .FALSE., .FALSE., 0, NDUM, NDUM, 0) C IF (NPRT.NE.0) THEN DO 50 I = 1, LAGMAX ACOV(I+1) = ACOV(I+1) * ACOV(1) 50 CONTINUE END IF C END IF C CALL STKCLR(NALL0) C END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL ACFS (Y, N,'/ + ' + LAGMAX, LACOV, ACOV, IAR, PHI, NPRT, LDSTAK)') END *ACVF SUBROUTINE ACVF (Y, N, YMEAN, ACOV, LAGMAX, LACOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE AUTOCOVARIANCE FUNCTION OF A SERIES. 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 REAL + YMEAN INTEGER + LACOV,LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(*),Y(*) C C LOCAL SCALARS REAL + DOTXY,DOTYY INTEGER + LAG,NDOTXY,NDOTYY C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,DOTC C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED C REAL DOTXY, DOTYY C THE DOT PRODUCT BETWEEN VECTORS (Y(I) - YMEAN)) AND C (Y(LAG) - YMEAN)), AND (Y(I) - YMEAN)) AND (Y(I) - YMEAN)), C RESPECTIVELY. C INTEGER LACOV C THE ACTUAL DIMENSION OF ACOV. C INTEGER LAG, LAGMAX C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCOVARIANCE BEING COMPUTED AND THE MAXIMUM LAG TO BE USED, C RESPECTIVELY. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NDOTXY, NDOTYY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY AND C DOTYY, RESPECTIVELY. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C COMPUTE ARITHMETIC MEAN C CALL AMEAN(Y, N, YMEAN) C C COMPUTE THE VARIANCE OF THE SERIES Y C CALL DOTC (Y, YMEAN, N, Y, YMEAN, N, DOTYY, NDOTYY) ACOV(1) = DOTYY / NDOTYY C C COMPUTE AUTOCOVARIANCES. C DO 10 LAG = 1, LAGMAX CALL DOTC (Y, YMEAN, N, Y(LAG+1), YMEAN, N - LAG, + DOTXY, NDOTXY) ACOV(LAG + 1) = DOTXY / N 10 CONTINUE C RETURN END *ACVFF SUBROUTINE ACVFF (YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, + LYFFT, WORK, LWORK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE ACVF OF A SERIES USING TWO C PASSES OF A FFT. 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 REAL + YMEAN INTEGER + LACOV,LAGMAX,LWORK,LYFFT,N,NFFT C C ARRAY ARGUMENTS REAL + ACOV(*),WORK(*),YFFT(*) C C LOCAL SCALARS REAL + FAC INTEGER + I,ISN,N1,NF,NFFT2 C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,FFT,FFTCT,REALTR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED C REAL FAC C A FACTOR USED IN THE COMPUTATIONS. C INTEGER I C AN INDEX VARIABLE. C INTEGER ISN C AN INDICATOR VARIABLE USED BY THE FFT ROUTINES. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG TO BE USED. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NF C THE NUMBER OF FOURIER FREQUENCIES. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NFFT2 C THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM. C INTEGER N1 C THE VALUE N + 1. C REAL WORK(LWORK) C THE WORK AREA FOR THE COMPUTATIONS. C REAL YFFT(LYFFT) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C COMPUTE ARITHMETIC MEAN C CALL AMEAN(YFFT, N, YMEAN) C C SUBTRACT THE MEAN FROM THE SERIES C DO 10 I = 1, N YFFT(I) = YFFT(I) - YMEAN 10 CONTINUE C C APPEND ZEROS C N1 = N + 1 C DO 20 I = N1, NFFT YFFT(I) = 0.0E0 20 CONTINUE C C COMPUTE AUTOCOVARIANCES. C ISN = 2 NFFT2 = (NFFT - 2)/ 2 C CALL FFT(YFFT(1), YFFT(2), NFFT2, NFFT2, NFFT2, ISN) CALL REALTR (YFFT(1), YFFT(2), NFFT2, ISN) C NF = NFFT2 + 1 C DO 30 I = 1, NF WORK(I) = YFFT(2*I-1)*YFFT(2*I-1) + YFFT(2*I)*YFFT(2*I) 30 CONTINUE C CALL FFTCT (WORK, NFFT2, LWORK) C FAC = 1.0E0 / (4 * (NFFT - 2) * N) C ACOV(1) = WORK(1) * FAC C DO 40 I = 1, LAGMAX ACOV(I+1) = WORK(I+1) * FAC 40 CONTINUE C RETURN END *ACVFM SUBROUTINE ACVFM (Y, YMISS, N, YMEAN, ACOV, LAGMAX, + LAGLST, NLPPA, LACOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE AUTOCOVARIANCES WHEN MISSING DATA 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 - NOVEMBER 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YMEAN,YMISS INTEGER + LACOV,LAGLST,LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(*),Y(*) INTEGER + NLPPA(*) C C LOCAL SCALARS REAL + DOTXY,DOTYY,FPLM INTEGER + LAG,NDOTXY,NDOTYY,NUSED C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + LSTLAG EXTERNAL R1MACH,LSTLAG C C EXTERNAL SUBROUTINES EXTERNAL AMEANM,DOTCM C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED C REAL DOTXY, DOTYY C THE DOT PRODUCT BETWEEN VECTORS (Y(I) - YMEAN)) AND C (Y(LAG) - YMEAN)), AND (Y(I) - YMEAN)) AND (Y(I) - YMEAN)), C RESPECTIVELY. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAG, LAGLST, LAGMAX C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCORRELATION BEING COMPUTED, THE NUMBER OF AUTOCORRELATIONS C COMPUTED BEFORE A MISSING AUTOCORRELATION, AND THE NUMBER OF C AUTOCORRELATIONS DESIRED, RESPECTIVELY. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NDOTXY, NDOTYY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY AND C DOTYY, RESPECTIVELY. C INTEGER NLPPA(LACOV) C THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS C USED TO COMPUTE THE ACVF AT EACH LAG. C INTEGER NUSED C THE NUMBER OF ACTIVE OBSERVATIONS IN THE SERIES. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C C FPLM = R1MACH(2) C C COMPUTE ARITHMETIC MEAN, WITH MISSING VALUES TAKEN INTO ACCOUNT C CALL AMEANM (Y, YMISS, N, NUSED, YMEAN) C C COMPUTE THE VARIANCE OF THE SERIES Y C CALL DOTCM (Y, YMEAN, YMISS, N, Y, YMEAN, YMISS, N, + DOTYY, NDOTYY) NLPPA(1) = NDOTYY IF (NLPPA(1).EQ.0) THEN LAGLST = 0 ELSE ACOV(1) = DOTYY / NDOTYY C C COMPUTE AUTOCORRELATIONS, WITH MISSING VALUES TAKEN INTO ACCOUNT C DO 10 LAG = 1, LAGMAX CALL DOTCM (Y, YMEAN, YMISS, N, Y(LAG+1), YMEAN, + YMISS, N - LAG, DOTXY, NDOTXY) NLPPA(LAG + 1) = NDOTXY ACOV(LAG + 1) = FPLM IF (NLPPA(LAG + 1) .LE. 0) GO TO 10 ACOV(LAG + 1) = DOTXY * (N-LAG) / (NLPPA(LAG + 1) * N) 10 CONTINUE C C FIND THE LAST AUTOCORRELATION TO BE COMPUTED BEFORE C ONE COULD NOT BE COMPUTED DUE TO MISSING DATA C LAGLST = LSTLAG(NLPPA, LAGMAX, LACOV) END IF RETURN END *ADJLMT SUBROUTINE ADJLMT(YMN, YMX) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CORRECTS THE PLOT LIMITS WHEN ALL C OBSERVATIONS ARE IDENTICALLY EQUAL. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YMN,YMX C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL YMN, YMX C THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C write ( *, * ) 'DEBUG: ADJLMT' write ( *, * ) 'YMN = ', ymn write ( *, * ) 'YMX = ', ymx IF (YMN .LT. YMX) RETURN C C CORRECT FOR ALL OBSERVATIONS IDENTICALLY EQUAL C YMN = YMN - ABS(YMN/2.0E0) YMX = YMX + ABS(YMX/2.0E0) IF (YMN .LT. YMX) RETURN YMN = -0.5E0 YMX = 0.5E0 write ( *, * ) 'DEBUG: ADJLMT' write ( *, * ) 'Done now' RETURN END *AIME SUBROUTINE AIME (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK) 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 + LDSTAK,N,NFAC,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),Y(*) INTEGER + MSPEC(4,*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,MIT, + NPARE,NPRT LOGICAL + SAVE C C LOCAL ARRAYS REAL + PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1) INTEGER + IFIXED(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEDRV,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C THE PREDICTED VALUE OF THE FIT, UNUSED WHEN SAVE = FALSE. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL 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 REAL SCALE(1) 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 REAL SDPV(1) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES, UNUSED C WHEN SAVE = FALSE. C REAL SDRES(1) C THE STANDARDIZED RESIDUALS, UNUSED WHEN SAVE = FALSE. C REAL 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 REAL 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 REAL STP(1) 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 REAL VCV(1,1) C THE VARIANCE-COVARIANCE MATRIX, UNUSED WHEN SAVE = FALSE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'A','I','M','E',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C SAVE = .FALSE. C LIFIXD = 1 IFIXED(1) = -1 LSTP = 1 STP(1) = 0.0E0 MIT = -1 STOPSS = -1.0E0 STOPP = -1.0E0 LSCALE = 1 SCALE(1) = 0.0E0 DELTA = -1.0E0 IVAPRX = -1 NPRT = -1 LPV = 1 LSDPV = 1 LSDRES = 1 IVCV = 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 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C C 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'// + ' CALL AIME (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK)') END *AIMEC SUBROUTINE AIMEC(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK, + IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT) 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 REAL + DELTA,STOPP,STOPSS INTEGER + IVAPRX,LDSTAK,MIT,N,NFAC,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),SCALE(*),STP(*),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 REAL + RSD INTEGER + IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,NPARE LOGICAL + SAVE C C LOCAL ARRAYS REAL + PV(1),SDPV(1),SDRES(1),VCV(1,1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEDRV,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C THE PREDICTED VALUE OF THE FIT, UNUSED WHEN SAVE = FALSE. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL 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 REAL 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 REAL SDPV(1) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES, UNUSED C WHEN SAVE = FALSE. C REAL SDRES(1) C THE STANDARDIZED RESIDUALS, UNUSED WHEN SAVE = FALSE. C REAL 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 REAL 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 REAL STP(1) 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 REAL VCV(1,1) C THE VARIANCE-COVARIANCE MATRIX, UNUSED WHEN SAVE = FALSE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'A','I','M','E','C',' '/ C C SET VARIOUS PROGRAM PARAMETERS C SAVE = .FALSE. C LIFIXD = NPAR IF (IFIXED(1).LE.-1) LIFIXD = 1 LPV = 1 LSCALE = NPAR IF (SCALE(1).LE.0.0E0) LSCALE = 1 LSTP = NPAR IF (STP(1).LE.0.0E0) LSTP = 1 LSDPV = 1 LSDRES = 1 IVCV = 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 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'// + ' CALL AIMEC (Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, STP, MIT, STOPSS, STOPP, SCALE,'/ + ' + DELTA, IVAPRX, NPRT)') 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,LDSTAK,MIT,N,NFAC,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + 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 + IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP LOGICAL + SAVE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEDRV,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUE OF THE FIT. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL 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 REAL 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 REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL 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 REAL VCV(IVCV,NPAR) C THE VARIANCE-COVARIANCE MATRIX. C REAL Y(N) C THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS 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.0E0) LSCALE = 1 LSTP = NPAR IF (STP(1).LE.0.0E0) 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 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'// + ' CALL 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)') END *AIMF SUBROUTINE AIMF (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION C (SHORT 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 + LDSTAK,N,NFAC,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),Y(*) INTEGER + MSPEC(4,*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IFCST,IPRT,NFCST,NFCSTO,NPRT LOGICAL + SAVE C C LOCAL ARRAYS REAL + FCST(1,1),FCSTSD(1) INTEGER + IFCSTO(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMFCNT,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FCST(1,1) C THE STORAGE ARRAY FOR THE FORECASTS. C REAL FCSTSD(1) 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(1) 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 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 REAL 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 REAL Y(N) C THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'A','I','M','F',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C SAVE = .FALSE. C NFCST = N/10 + 1 NFCSTO = 1 IFCSTO(1) = N NPRT = -1 IFCST = 1 C CALL AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, NFCST, NFCSTO, + IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'// + ' CALL AIMF (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK)') 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 REAL + 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 + IPRT,NFCSTU LOGICAL + SAVE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMFCNT,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C REAL 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 REAL 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 REAL Y(N) C THE DEPENDENT VARIABLE. 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 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 IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/' THE CORRECT FORM OF THE CALL STATEMENT IS'// + ' CALL AIMFS (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,'/ + ' + NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST,', + ' FCSTSD)') END *AIMX1 SUBROUTINE AIMX1(MXN, MXPAR, MXFC, MXFCO, MXFAC, + MOD, N, MSPEC, NFAC, PAR, NPAR, RES, + IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT, + NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV, + NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD) C C LATEST REVISION - 03/15/90 (JRD) C C SET THE STARTING PARAMETER VALUES FOR AIMX 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IFCST,IVAPRX,IVCV,MIT,MOD,MXFAC,MXFC,MXFCO,MXN,MXPAR,N, + NFAC,NFCST,NFCSTO,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + FCST(MXFC,*),FCSTSD(*),PAR(*),PV(*),RES(*),SCALE(*),SDPV(*), + SDRES(*),STP(*),VCV(MXPAR,*) INTEGER + IFCSTO(*),IFIXED(*),MSPEC(4,*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + SQMEPS INTEGER + I,J C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C EXTERNAL SUBROUTINES EXTERNAL SETRV C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C REAL FCST(MXFC,MXFCO) C THE FORECASTS. C REAL FCSTSD(MXFC) C THE STANDARD DEVIATION OF THE FORECASTS. C INTEGER I C * 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 IFCST C * C INTEGER IFCSTO(MXFCO) C THE FORECAST ORIGINS. C INTEGER IFIXED(MXPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(I).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. C INTEGER IVAPRX C * C INTEGER IVCV C THE ACTUAL FIRST DIMENSION OF VCV. C INTEGER J C * C INTEGER MIT C * C INTEGER MOD C AN INDICATOR VALUE USED TO DESIGNATE THE MODEL FOR WHICH C THE PARAMETERS ARE TO BE SET. C INTEGER MSPEC(4,MXFAC) C THE VALUES OF P, D, Q AND S FOR EACH FACTOR. C INTEGER MXFAC C THE MAXIMUM NUMBER OF FACTORS ALLOWED. C INTEGER MXFC C THE MAXIMUM NUMBER OF FORECASTS ALLOWED. C INTEGER MXFCO C THE MAXIMUM NUMBER OF FORECASTS ORIGINS ALLOWED. C INTEGER MXN C THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED. C INTEGER MXPAR C THE MAXIMUM NUMBER OF PARAMETERS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NFAC C THE NUMBER OF FACTORS IN THE MODEL C INTEGER NFCST, NFCSTO C THE NUMBER OF FORECASTS AND FORCAST ORIGINS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C TO BE PROVIDED. C INTEGER NPARE C THE NUMBER OF PARAMETERS ESTIMATED BY THE ROUTINE. C INTEGER NPRT C * C REAL PAR(MXPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PV(MXN) C THE PREDICTED VALUES. C REAL RES(MXN) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL SCALE(MXPAR) C THE SCALE VALUES. C REAL SDPV(MXN) C THE STANDARD DEVIATION OF THE PREDICTED VALUES. C REAL SDRES(MXN) C THE STANDARDIZED RESIDUALS. C REAL SQMEPS, STOPP, STOPSS C * C REAL STP(MXPAR) C THE STEP VALUES. C REAL VCV(MXPAR,MXPAR) C THE VARIANCE COVARIANCE MATRIX. C GO TO (10, 20, 30, 40, 50, 60), MOD C 10 CONTINUE N = 144 NFAC = 2 MSPEC(1,1) = 0 MSPEC(2,1) = 1 MSPEC(3,1) = 1 MSPEC(4,1) = 1 MSPEC(1,2) = 0 MSPEC(2,2) = 1 MSPEC(3,2) = 1 MSPEC(4,2) = 12 NPAR = 3 PAR(1) = 0.0E0 PAR(2) = 0.4E0 PAR(3) = 0.6E0 IFIXED(1) = 1 IFIXED(2) = 0 IFIXED(3) = 0 C GO TO 70 C C 20 PAR(1) = 1.0E0 PAR(2) = 2.0E0 PAR(3) = 3.0E0 C GO TO 70 C C 30 PAR(1) = 6.0E0 PAR(2) = 5.0E0 PAR(3) = 4.0E0 PAR(4) = 3.0E0 PAR(5) = 2.0E0 C GO TO 70 C C 40 CALL SETRV(PAR, NPAR, 0.0E0) C GO TO 70 C C 50 CALL SETRV(PAR, NPAR, 0.5E0) C GO TO 70 C C 60 PAR(1) = 100.0E0 PAR(2) = 15.0E0 C 70 CONTINUE C SQMEPS = SQRT(RMDCON(3)) C MIT = 25 DO 80 I=1,10 STP(I) = SQMEPS SCALE(I) = 1.0E0 80 CONTINUE STOPSS = 10.0E-7 STOPP = 10.0E-7 DELTA = 0.5E0 NPRT = 11111 IVAPRX = 3 IVCV = MXPAR C NFCST = 36 NFCSTO = 2 IFCSTO(1) = 103 IFCSTO(2) = N IFCST = MXFC C DO 85 I=1,MXN RES(I) = -1.0E0 PV(I) = -1.0E0 SDPV(I) = -1.0E0 SDRES(I) = -1.0E0 85 CONTINUE C DO 100 I=1,MXPAR DO 90 J=1,MXPAR VCV(I,J) = -1.0E0 90 CONTINUE 100 CONTINUE C DO 110 I = 1, MXFC FCSTSD(I) = -1.0E0 DO 105 J = 1, MXFCO FCST(I,J) = -1.0E0 105 CONTINUE 110 CONTINUE C NPARE = -1 RSD = -1.0E0 C IERR = -1 C RETURN C END *ALBETA REAL FUNCTION ALBETA (A, B) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,B C C LOCAL SCALARS REAL CORR,P,Q,SQ2PIL C C EXTERNAL FUNCTIONS REAL ALNGAM,ALNREL,GAMMA,R9LGMC EXTERNAL ALNGAM,ALNREL,GAMMA,R9LGMC C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC LOG,MAX,MIN C DATA SQ2PIL / 0.91893853320467274E0 / C P = MIN (A, B) Q = MAX (A, B) C IF (P.LE.0.0) CALL XERROR ( 1 'ALBETA BOTH ARGUMENTS MUST BE GT ZERO', 38, 1, 2) IF (P.GE.10.0) GO TO 30 IF (Q.GE.10.0) GO TO 20 C C P AND Q ARE SMALL. C ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) ) RETURN C C P IS SMALL, BUT Q IS BIG. C 20 CORR = R9LGMC(Q) - R9LGMC(P+Q) ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) + 1 (Q-0.5)*ALNREL(-P/(P+Q)) RETURN C C P AND Q ARE BIG. C 30 CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q) ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q)) 1 + Q*ALNREL(-P/(P+Q)) RETURN C END *ALGAMS SUBROUTINE ALGAMS (X, ALGAM, SGNGAM) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE LOG ABS (GAMMA(X)) AND RETURN THE SIGN OF GAMMA(X) IN SGNGAM. C SGNGAM IS EITHER +1.0 OR -1.0. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL ALGAM,SGNGAM,X C C EXTERNAL FUNCTIONS REAL ALNGAM EXTERNAL ALNGAM C C INTRINSIC FUNCTIONS INTRINSIC INT,MOD C ALGAM = ALNGAM(X) SGNGAM = 1.0 IF (X.GT.0.0) RETURN C C INT = AMOD (-AINT(X), 2.0) + 0.1 IF (INT(MOD(-INT(X),2)+0.1).EQ.0) SGNGAM = -1.0 C RETURN END *ALNGAM REAL FUNCTION ALNGAM (X) C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL DXREL,PI,SINPIY,SQ2PIL,SQPI2L,XMAX,Y C C EXTERNAL FUNCTIONS REAL GAMMA,R1MACH,R9LGMC EXTERNAL GAMMA,R1MACH,R9LGMC C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,AINT,LOG,SIN,SQRT C DATA SQ2PIL / 0.9189385332 0467274E0/ C SQ2PIL = LOG(SQRT(2.*PI)), SQPI2L = LOG (SQRT(PI/2.)) DATA SQPI2L / 0.2257913526 4472743E0/ DATA PI / 3.1415926535 8979324E0/ C DATA XMAX, DXREL / 0., 0. / C IF (XMAX.NE.0.) GO TO 10 XMAX = R1MACH(2)/LOG(R1MACH(2)) DXREL = SQRT (R1MACH(4)) C 10 Y = ABS(X) IF (Y.GT.10.0) GO TO 20 C C LOG (ABS (GAMMA(X))) FOR ABS(X) .LE. 10.0 C ALNGAM = LOG (ABS (GAMMA(X))) RETURN C C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0 C 20 IF (Y.GT.XMAX) CALL XERROR ( 1 'ALNGAM ABS(X) SO BIG ALNGAM OVERFLOWS', 38, 2, 2) C IF (X.GT.0.0) THEN ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y) RETURN END IF C SINPIY = ABS (SIN(PI*Y)) IF (SINPIY.EQ.0.) CALL XERROR ('ALNGAM X IS A NEGATIVE INTEGER', 1 31, 3, 2) C IF (ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL XERROR ( 1 'ALNGAM ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE 2INTEGER', 68, 1, 1) C ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y) RETURN C END *ALNREL REAL FUNCTION ALNREL (X) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL XMIN INTEGER NLNREL C C LOCAL ARRAYS REAL ALNRCS(23) C C EXTERNAL FUNCTIONS REAL CSEVL,R1MACH INTEGER INITS EXTERNAL CSEVL,R1MACH,INITS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,SQRT C C SERIES FOR ALNR ON THE INTERVAL -3.75000D-01 TO 3.75000D-01 C WITH WEIGHTED ERROR 1.93E-17 C LOG WEIGHTED ERROR 16.72 C SIGNIFICANT FIGURES REQUIRED 16.44 C DECIMAL PLACES REQUIRED 17.40 C DATA ALNRCS( 1) / 1.0378693562 743770E0 / DATA ALNRCS( 2) / -.1336430150 4908918E0 / DATA ALNRCS( 3) / .0194082491 35520563E0 / DATA ALNRCS( 4) / -.0030107551 12753577E0 / DATA ALNRCS( 5) / .0004869461 47971548E0 / DATA ALNRCS( 6) / -.0000810548 81893175E0 / DATA ALNRCS( 7) / .0000137788 47799559E0 / DATA ALNRCS( 8) / -.0000023802 21089435E0 / DATA ALNRCS( 9) / .0000004164 04162138E0 / DATA ALNRCS(10) / -.0000000735 95828378E0 / DATA ALNRCS(11) / .0000000131 17611876E0 / DATA ALNRCS(12) / -.0000000023 54670931E0 / DATA ALNRCS(13) / .0000000004 25227732E0 / DATA ALNRCS(14) / -.0000000000 77190894E0 / DATA ALNRCS(15) / .0000000000 14075746E0 / DATA ALNRCS(16) / -.0000000000 02576907E0 / DATA ALNRCS(17) / .0000000000 00473424E0 / DATA ALNRCS(18) / -.0000000000 00087249E0 / DATA ALNRCS(19) / .0000000000 00016124E0 / DATA ALNRCS(20) / -.0000000000 00002987E0 / DATA ALNRCS(21) / .0000000000 00000554E0 / DATA ALNRCS(22) / -.0000000000 00000103E0 / DATA ALNRCS(23) / .0000000000 00000019E0 / C DATA NLNREL, XMIN /0, 0./ C IF (NLNREL.NE.0) GO TO 10 NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) XMIN = -1.0 + SQRT(R1MACH(4)) C 10 IF (X.LE.(-1.0)) CALL XERROR ( 1 'ALNREL X IS LE -1', 18, 2, 2) IF (X.LT.XMIN) CALL XERROR ( 1 'ALNREL ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 54, 2 1, 1) C IF (ABS(X).LE.0.375) THEN ALNREL = X*(1.0-X*CSEVL(X/0.375,ALNRCS,NLNREL)) ELSE ALNREL = LOG (1.0+X) END IF 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 REAL + 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 REAL + PJ,STPJ INTEGER + I,J,JPK C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PJ C A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER. C REAL RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C REAL SCL(LSCL) C THE SCALE VALUES. C REAL STPT(LSTPT) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. 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) write ( *, * ) 'DEBUG: SCL(JPK) = ', scl(jpk) write ( *, * ) 'DEBUG: STPT(J) = ', stpt(j) write ( *, * ) 'DEBUG: PAR(J) = ', par(j) IF (SCL(JPK).NE.0.0E0) THEN STPJ = STPT(J)*SIGN(1.0E0,PAR(J))*MAX(ABS(PAR(J)),1.0E0/ + ABS(SCL(JPK))) ELSE IF (PAR(J).NE.0.0E0) THEN STPJ = STPT(J)*SIGN(1.0E0,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 *AMEAN SUBROUTINE AMEAN(Y, N, YMEAN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE ARITHMETIC MEAN OF A SERIES. 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 REAL + YMEAN INTEGER + N C C ARRAY ARGUMENTS REAL + Y(*) C C LOCAL SCALARS REAL + SUMY INTEGER + I 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 REAL SUMY C THE VARIABLE USED TO SUM THE Y VALUES. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C SUMY = 0.0E0 DO 10 I = 1, N SUMY = SUMY + Y(I) 10 CONTINUE YMEAN = SUMY / N RETURN END *AMEANM SUBROUTINE AMEANM (Y, YMISS, N, NUSED, YMEAN) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE ARITHMETIC MEAN OF A SERIES WHEN MISSING C DATA ARE 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 REAL + YMEAN,YMISS INTEGER + N,NUSED C C ARRAY ARGUMENTS REAL + Y(*) C C LOCAL SCALARS REAL + SUMY INTEGER + I C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NUSED C THE NUMBER OF ACTIVE NUMBER OF OBSERVATIONS. C REAL SUMY C THE VARIABLE USED TO SUM THE NON-MISSING Y VALUES. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C NUSED = 0 SUMY = 0.0E0 DO 10 I = 1, N IF (MVCHK(Y(I), YMISS)) GO TO 10 SUMY = SUMY + Y(I) NUSED = NUSED + 1 10 CONTINUE IF (NUSED.GE.1) THEN YMEAN = SUMY / NUSED ELSE YMEAN = SUMY END IF RETURN 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 REAL + 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 REAL + 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 REAL + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL AMEMN,CPYASF,CPYVII,SCOPY,SETIV,STKCLR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER RWORK C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE REAL 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 REAL SCALE(LSCALE) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL 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 REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C INTEGER SDRESI C THE STARTING LOCATION IN RWORK OF THE C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL STP(LSTP) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C NALL0 = STKST(1) C IFP = 3 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 SCOPY(N, RSTAK(PVI), 1, PV, 1) CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1) CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1) CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV) C 10 CALL STKCLR(NALL0) C RETURN C 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 REAL + 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 REAL + 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 REAL + 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 REAL + 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,SCOPY, + STKCLR,STKSET,STPAMO C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 REAL 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 REAL PV(LPV) C THE PREDICTED VALUE OF THE FIT. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSTAK(12) C THE REAL 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL 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 REAL 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 REAL WT(1) C THE USER SUPPLIED WEIGHTS, UNUSED WHEN WEIGHT = FALSE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C WEIGHT = .FALSE. WT(1) = 1.0E0 LWT = 1 C HLFRPT = .FALSE. APRXDV = .TRUE. PRTFXD = .TRUE. EXMPT = -1.0E0 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.0E0) IS = 1 C CALL LDSCMP(25, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE) + 4*NFAC, + 0, 0, 0, 'S', 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 = 3 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 SCOPY(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.0E0) 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) write ( *, * ) 'DEBUG: RSTAK(STPT)=', rstak(stpt) 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 10 CONTINUE C CALL STKCLR(NALL0) C RETURN C 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 REAL + 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 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL STP(LSTP) C THE STEP SIZE ARRAY. 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.0E0, 0, HEAD, 6, NV, + ERROR(8), LZERO) CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 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 *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 REAL + RSD,RSSHLF INTEGER + IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS LOGICAL + PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + 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 REAL + COND,RSS,YSS INTEGER + I,IDF LOGICAL + EXACT,PRTFSM C C EXTERNAL SUBROUTINES EXTERNAL AMEOUT,NLCMP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COND C THE CONDITION NUMBER OF D. C REAL 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 REAL 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 REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL RD(N) C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RSSHLF C HALF THE RESIDUAL SUM OF SQUARES. C REAL SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDREST(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C REAL YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. 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 *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 INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT ('+NONLINEAR LEAST SQUARES ESTIMATION', + ' FOR THE PARAMETERS OF AN ARIMA MODEL, CONTINUED') 1010 FORMAT ('+', 77(1H*)/ + 1X, 37H* NONLINEAR LEAST SQUARES ESTIMATION, + 40H FOR THE PARAMETERS OF AN ARIMA MODEL */ + 2H *, 16X, 45H USING BACKFORECASTS , + 14X, 1H*/1X, 77(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) 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 REAL + 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 REAL + RSD,RSS INTEGER + IAMHD,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS REAL + SNRM2 EXTERNAL SNRM2 C C EXTERNAL SUBROUTINES EXTERNAL AMLST,IPRINT,MODSUM C C INTRINSIC FUNCTIONS INTRINSIC REAL,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 REAL 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 REAL RES(N) C THE RESIDUALS FROM THE FIT. C INTEGER RFCTOL C THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE C TOLERANCE. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RWORK(LRWORK) C WORK SPACE USED BY THE NL2 SUBROUTINES. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL 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 DATA MXFCAL/17/, MXITER/18/ C C RWORK SUBSCRIPT VALUES C DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/ C 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) WRITE (IPRT, 1170) NNZW WRITE(IPRT, 1070) IWORK(MXITER) WRITE(IPRT, 1090) IWORK(MXFCAL) WRITE(IPRT, 1080) WRITE(IPRT, 1100) RWORK(RFCTOL) WRITE(IPRT, 1110) RWORK(XCTOL) WRITE(IPRT, 1120) RWORK(LMAX0) RSD = SNRM2(NRESTS, RES, 1) RSS = RSD * RSD IF (N-NPARDF-NPARE.GE.1) + RSD = RSD / SQRT(REAL(N-NPARDF-NPARE)) WRITE (IPRT, 1200) RSS WRITE (IPRT, 1210) RSD WRITE (IPRT, 1220) N, NPARDF, NPARE, NNZW-NPARE C RETURN C C FORMAT STATEMENTS C 1070 FORMAT (/37H MAXIMUM NUMBER OF ITERATIONS ALLOWED, 32X, 5H(MIT), + 1X, I5) 1080 FORMAT(/44H CONVERGENCE CRITERION FOR TEST BASED ON THE/) 1090 FORMAT(/' MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS', + 8H ALLOWED, 26X, I5) 1100 FORMAT (5X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL, + 15H SUM OF SQUARES, 7X, 8H(STOPSS), 1X, G11.4) 1110 FORMAT(5X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS, + 13X, 7H(STOPP), 1X, G11.4) 1120 FORMAT(//' MAXIMUM CHANGE ALLOWED IN THE PARAMETERS', + 23H AT THE FIRST ITERATION, 3X, 7H(DELTA), 1X, G11.4) 1170 FORMAT (/' NUMBER OF NON ZERO WEIGHTED OBSERVATIONS', 27X, + 6H(NNZW), 1X, I5) 1200 FORMAT (/44H RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER, + 7H VALUES, 24X, G11.4, ' (BACKFORECASTS INCLUDED)') 1210 FORMAT (/48H RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER, + 7H VALUES, 14X, 5H(RSD), 1X, G11.4) 1220 FORMAT (/ 19H BASED ON DEGREES O, + 9HF FREEDOM, 1X, I4, 3H - , I3, 3H - , I3, 3H = , I4) 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 REAL + 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 REAL + 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,SCOPY C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 REAL D(NRESTS,NPAR) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C REAL 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 REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL 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 REAL 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 REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL 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 REAL 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 REAL RWORK(IRWORK) C THE REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. 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 SCOPY(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 *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 REAL + COND,RSD,RSS,YSS INTEGER + IDF,IVCVPT,LVCVL,N,NDIGIT,NPAR,NPARE LOGICAL + EXACT,PAGE,WIDE C C ARRAY ARGUMENTS REAL + 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 REAL + FPLM INTEGER + I,IAMHD,IPRT,ISUBHD C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL AMEPT1,AMEPT2,AMLST,IPRINT,MODSUM,NLSKL,VCVOTF C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 REAL 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 REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL 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 REAL 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 REAL Y(N) C THE DEPENDENT VARIABLE. C REAL YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. C C FPLM = R1MACH(2) C 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 10 IF (IPTOUT(4).EQ.0) GO TO 20 ISUBHD = 0 CALL AMEHDR(PAGE, WIDE, ISUBHD) C 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) 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 WRITE (IPRT,1000) IAMHD = 3 CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL, + PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF) WRITE (IPRT,1050) COND C IF (RSS.GT.YSS) WRITE (IPRT,1060) 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) WRITE (IPRT,1080) WRITE (IPRT,1000) 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) WRITE (IPRT,1050) COND C IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) WRITE + (IPRT,1070) IF ((IERR.EQ.0) .AND. EXACT) WRITE (IPRT,1090) C IF (IERR.NE.0) GO TO 100 C DO 90 I=1,N SDREST(I) = 0.0E0 SDPVT(I) = 0.0E0 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 1000 FORMAT (///33H ESTIMATES FROM LEAST SQUARES FIT/1X, 33('-')) 1050 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7) 1060 FORMAT (//52H THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES, + 20H FIT IS GREATER THAN/35H THE SUM OF SQUARES ABOUT THE MEAN , + 19HY OBSERVATION. THE, 14H MODEL IS LESS/17H REPRESENTATIVE O, + 39HF THE DATA THAN A SIMPLE AVERAGE. DATA, 15H AND MODEL SHOU, + 2HLD/48H BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.) 1070 FORMAT (/49H THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO., + 54H STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.) 1080 FORMAT (//40H THE FOLLOWING SUMMARY SHOULD BE USED TO, 8H ANALYZE, + 30H THE ABOVE MENTIONED PROBLEMS.) 1090 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS, + 35H EXACT TO WITHIN MACHINE PRECISION./20H STATISTICAL ANALYSI, + 33HS OF THE RESULTS IS NOT POSSIBLE.) 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 REAL + PVT(*),RES(*),SDPVT(*),SDREST(*),Y(*) INTEGER + IPTOUT(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + FPLM INTEGER + I,IPRT,NMAX C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,OBSSM2 C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDREST(N) C THE STANDARDIZED RESIDUALS. C REAL Y(N) C THE DEPENDENT VARIABLE. C FPLM = R1MACH(2) C CALL IPRINT(IPRT) C WRITE (IPRT,1100) WRITE (IPRT,1000) WRITE (IPRT, 1110) 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 (IPRT, 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)) WRITE (IPRT, 1080) IF ((IERR.GT.0) .AND. (IERR.NE.4)) WRITE (IPRT, 1090) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ 5X, 16X, ' -----PREDICTED ----STD DEV OF', 16X, + ' ---STD'/ + 2X, 3HROW, ' --------SERIES ---------VALUE', + ' ----PRED VALUE ------RESIDUAL ---RES') 1080 FORMAT (// 37H * NC - VALUE NOT COMPUTED BECAUSE, + 48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.) 1090 FORMAT (// 29H * NC - VALUE NOT COMPUTED, + 54H BECAUSE CONVERGENCE PROBLEMS PREVENTED THE COVARIANCE, + 28H MATRIX FROM BEING COMPUTED.) 1100 FORMAT (//' RESULTS FROM LEAST SQUARES FIT'/ 1X, 31('-')) 1110 FORMAT (' ') 1150 FORMAT (4X, '.', 4(15X, '.'), 7X, '.') END *AMEPT2 SUBROUTINE AMEPT2 (RES, SDREST, N, RSS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE, ADAPTED FROM OMNITAB II, PRINTS C THE FOUR STANDARDIZED RESIDUAL PLOTS. 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 REAL + RSS INTEGER + N C C ARRAY ARGUMENTS REAL + RES(*),SDREST(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + AN,DOT,FAC1,FAC2,FPLM,GAMMA,PI,RATIO,ROWDIV,ROWMAX,ROWMID, + ROWMIN,XDIV,XMAX,XMIN,YLABEL,YMAX,YMIN INTEGER + I,I1,I2,IMID,IPLOT,IPRB,IPRT,IROW,IX,K,L,NCOL,NCOLP1, + NCOLPL,NCOLT2,NDOT,NROW CHARACTER + IBLANK*1,IMINUS*1,IPLUS*1,ISTAR*1 C C LOCAL ARRAYS CHARACTER + LINE(113)*1 C C EXTERNAL FUNCTIONS REAL + R1MACH LOGICAL + MVCHK EXTERNAL R1MACH,MVCHK C C EXTERNAL SUBROUTINES EXTERNAL DOTC,GETPI,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC INT,MAX,MIN,MOD C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AN C THE NUMBER OF OBSERVATIONS, USED IN COMPUTING C THE NORMAL PROBABILITY PLOT. C REAL DOT C THE DOT PRODUCT USED TO COMPUTE THE CORRELATION COEFFICIENT. C REAL FAC1, FAC2 C FACTORS USED IN COMPUTING THE NORMAL PROBABILITY PLOT. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL GAMMA C A VALUE USED IN COMPUTING THE NORMAL PROBABILITY PLOT. C INTEGER I C AN INDEX VARIABLE. C CHARACTER*1 IBLANK C THE VALUE OF THE CHARACTER -BLANK-. 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 IMID C THE MIDPOINT OF THE AUTOCORRELATION PLOT. C CHARACTER*1 IMINUS C THE CHARACTER MINUS. C INTEGER IPLOT C AN INDICATOR VARIABLE DESIGNATING WHETHER THE FIRST OR C SECOND SET OF TWO PLOTS ARE BEING PRINTED. C CHARACTER*1 IPLUS C THE CHARACTER PLUS. C INTEGER IPRB C THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE C PROBABILITY PLOT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IROW C THE ROW OF THE VARIABLES BEING PLOTTED. C CHARACTER*1 ISTAR C THE CHARACTER STAR. C INTEGER IX C THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOTS C VERSUS THE INDEPENDENT VARIABLE. C INTEGER I1, I2 C INDEX VALUES. C INTEGER K C AN INDEX VARIABLE. C INTEGER L C AN INDEX VARIABLE. C CHARACTER*1 LINE(113) C THE SYMBOLS (BLANKS AND CHARACTERS) FOR A GIVEN LINE C OF THE PLOT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NCOL, NCOLPL, NCOLP1, NCOLT2 C THE NUMBER OF COLUMNS IN THE PLOT, NCOL+L, NCOL+1, C AND NCOL * 2. C INTEGER NDOT C THE NUMBER OF POINTS MAKING UP DOT. C INTEGER NROW C THE NUMBER OF COLUMNS IN THE PLOT. C REAL PI C THE VALUE OF PI. C REAL RATIO C A VALUE USED TO PRODUCE THE NORMAL PROBABILITY PLOT. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL ROWDIV C THE VALUE OF A DIVISION ALONG THE -ROW- AXIS. C REAL ROWMAX C THE LARGEST ROW VALUE. C REAL ROWMID C THE MIDPOINT OF THE RANGE OF THE ROWS PLOTTED. C REAL ROWMIN C THE SMALLEST ROW VALUE PLOTTED. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SDREST(N) C THE STANDARDIZED RESIDUALS. C REAL XDIV C THE VALUE OF A DIVISION ALONG THE X AXIS. C REAL XMAX C THE LARGEST VALUE ALONG THE X AXIS. C REAL XMIN C THE SMALLEST VALUE ALONG THE X AXIS. C REAL YLABEL C THE LABEL TO BE PRINTED ALONG THE Y AXIS. C REAL YMAX C THE LARGEST VALUE ALONG THE Y AXIS C REAL YMIN C THE SMALLEST VALUE ALONG THE Y AXIS. C DATA IPLUS/'+'/, IMINUS/'-'/, ISTAR/'*'/, IBLANK/' '/ C CALL IPRINT(IPRT) C FPLM = R1MACH(2) C C CHECK FOR INSUFFICIENT POINTS TO PLOT C IF (IERR.NE.4) GO TO 20 DO 10 I = 1, N IF (SDREST(I).NE.FPLM) GO TO 20 10 CONTINUE WRITE (IPRT, 1090) RETURN C 20 CONTINUE C C INITIALIZE VALUES FOR PROBABILITY PLOT C CALL GETPI(PI) GAMMA = PI/8.0E0 AN = N FAC1 = 1.0E0 / (AN - 2.0E0*GAMMA + 1.0E0) FAC2 = 10.0E0 C C INITIALIZE THE PLOT SIZE (IN PLOT UNITS) C NROW = 26 C C BEGIN COMPUTATIONS FOR FIRST SET OF PLOTS C IPLOT = 1 NCOL = 111 C C SET X AXIS LIMITS FOR STANDARDIZED RESIDUAL VS ROW PLOT, C ROWMIN = 1 ROWMAX = N C ROWMID = (ROWMAX+ROWMIN)/2.0E0 ROWDIV = (ROWMAX-ROWMIN)/(NCOL-1) C C PRINT TITLES FOR FIRST PLOTS C WRITE (IPRT,1000) GO TO 90 C C BEGIN COMPUTATIONS FOR SECOND SET OF PLOTS C 40 IPLOT = 2 NCOL = 51 C C SET AXIS LIMITS FOR THE STANDARDIZED RESIDUALS VS C STANDARDIZED RESIDUALS LAGGED BY ONE AND FOR PROBABILITY PLOT C XMIN = -3.75E0 XMAX = 3.75E0 XDIV = (XMAX-XMIN)/(NCOL-1) C C PRINT TITLES FOR SECOND PLOTS C WRITE (IPRT,1050) C C WRITE FIRST LINE OF PLOTS C 90 CONTINUE C C PRINT PLOTS, ONE LINE AT A TIME C NCOLP1 = NCOL + 1 NCOLT2 = 2*NCOL YLABEL = 3.75E0 YMAX = FPLM YMIN = 4.05E0 DO 160 K=1,NROW YMIN = YMIN - 0.3E0 IF (-3.70E0.GE.YMIN) YMIN = -FPLM DO 100 L=1,NCOL NCOLPL = L + NCOL LINE(L) = IBLANK IF (IPLOT.EQ.2) LINE(NCOLPL) = IBLANK IF ((K.NE.1) .AND. (K.NE.NROW)) GO TO 100 LINE(L) = IMINUS IF (IPLOT.EQ.2) LINE(NCOLPL) = IMINUS IF ((MOD(L,10).NE.1) .AND. (L.NE.1+NCOL/2)) GO TO 100 LINE(L) = IPLUS IF (IPLOT.EQ.2) LINE(NCOLPL) = IPLUS 100 CONTINUE DO 130 I=1,N IF (.NOT.MVCHK(SDREST(I),FPLM)) THEN IF ((SDREST(I).GT.YMIN) .AND. (SDREST(I).LE.YMAX)) THEN IF (IPLOT.EQ.1) THEN IROW = INT(((I-ROWMIN)/ROWDIV)+1.5E0) LINE(IROW) = ISTAR ELSE RATIO = (AN-GAMMA) * FAC1 IPRB = INT(4.91E0*(RATIO**0.14E0- + (1.0E0-RATIO)**0.14E0)*FAC2) + 77 IF (IPRB.LE.NCOL) IPRB = NCOL+1 IF (IPRB.GE.103) IPRB = 102 LINE(IPRB) = ISTAR AN = AN - 1.0E0 IF ((AN.LT.2.0E0) .AND. (N.LE.10)) THEN GAMMA = 1.0E0/3.0E0 END IF END IF END IF END IF 130 CONTINUE C C SET PLOT LINE FOR CORRELATION PLOT OF SECOND SET OF PLOTS C IF (IPLOT.EQ.2) THEN IMID = (NCOL-1)/2 IF (K.LE.N-1) THEN DOT = 0.0E0 CALL DOTC(RES, 0.0E0, N, RES(K+1), 0.0E0, + N-K, DOT, NDOT) IX = INT(IMID*DOT/RSS) + IMID + 1 I1 = MIN(IX,IMID+1) I2 = MAX(IX,IMID+1) DO 135 IX=I1,I2 LINE(IX) = ISTAR 135 CONTINUE END IF END IF IF (MOD(K,5).EQ.1) THEN IF (IPLOT.EQ.1) THEN WRITE (IPRT,2020) YLABEL, (LINE(L),L=1,NCOL) ELSE WRITE (IPRT,1020) K, (LINE(L),L=1,NCOL), YLABEL, + (LINE(L),L=NCOLP1,NCOLT2) END IF YLABEL = YLABEL - 1.5E0 ELSE IF (IPLOT.EQ.1) THEN WRITE (IPRT,2030) (LINE(L),L=1,111) ELSE WRITE (IPRT,1030) (LINE(L),L=1,102) END IF END IF YMAX = YMIN 160 CONTINUE C C PRINT BOTTOM LINE OF GRAPHS C IF (IPLOT.EQ.1) THEN C C PRINT X AXIS LABELS FOR FIRST SET OF PLOTS C WRITE (IPRT,1040) ROWMIN, ROWMID, ROWMAX GO TO 40 C C PRINT X AXIS LABELS FOR SECOND SET OF PLOTS C ELSE WRITE (IPRT,1070) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/51X, 23H STD RES VS ROW NUMBER ) 1020 FORMAT (1X, I5, '+', 51A1, '+', 2X, F5.2, '+', 51A1, '+') 1030 FORMAT (6X, '-', 51A1, '-', 7X, '-', 51A1, '-') 1040 FORMAT (1X, F8.1, 47X, F8.1, 47X, F8.1) 1050 FORMAT (/13X, 'AUTOCORRELATION FUNCTION OF RESIDUALS', + 23X, 36H NORMAL PROBABILITY PLOT OF STD RES ) 1070 FORMAT (4X, 5H-1.00, 22X, 3H0.0, 21X, 4H1.00, 5X, 4H-2.5, 23X, + 3H0.0, 22X, 3H2.5) 1090 FORMAT (// 1X, 13(1H*)/ 1X, 13H* WARNING */ 1X, 13(1H*)// + 54H THE STANDARDIZED RESIDUAL PLOTS HAVE BEEN SUPPRESSED., + 45H NONE OF THE STANDARDIZED RESIDUALS COULD BE, + 10H COMPUTED,/ + 50H BECAUSE FOR EACH OBSERVATION EITHER THE WEIGHT OR, + 48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.) 2020 FORMAT (1X, F5.2, '+', 111A1, '+') 2030 FORMAT (6X, '-', 111A1, '-') 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 REAL + EXMPT INTEGER + ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,PVPAD LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),STP(*),XM(IXM,*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL HDR,MDL,STPOUT C C SCALARS IN COMMON REAL + Q INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + 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 REAL + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + STKGET,STKST EXTERNAL R1MACH,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN C C INTRINSIC FUNCTIONS INTRINSIC ABS,INT,LOG10,MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL ETA C THE RELATIVE NOISE IN THE MODEL. C REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SCL C THE ACTUAL TYPICAL SIZE USED. C REAL STP(NPAR) C THE SELECTED STEP SIZES. C EXTERNAL STPOUT C THE ROUTINE FOR PRINTING THE OUTPUT. C REAL 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 REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C C NALL0 = STKST(1) C FPLRS = R1MACH(4) IFP = 3 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.0E0 ** (-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.25E0, 0.01E0) C EXM = EXMPT IF ((EXM.LT.0.0E0) .OR. (EXM.GT.1.0E0)) EXM = 0.10E0 NEXMPT = INT(EXM * N) IF (EXM .NE. 0.0E0) 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.0E0) THEN IF (PAR(J) .EQ. 0.0E0) THEN SCL = 1.0E0 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)) write ( *, * ) 'DEBUG: STPMN returns STP(J) = ', stp(j) 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 *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 REAL + 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 REAL + 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 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 REAL FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C REAL 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 REAL 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 REAL RSTAK(12) C THE REAL 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 REAL Y(N) C THE DEPENDENT VARIABLE. 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, 'S', 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 = 3 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 *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 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 *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 INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT ('+ARIMA FORECASTING, CONTINUED') 1010 FORMAT ('+', 23(1H*)/ ' * ARIMA FORECASTING *', /1X, 23(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//' MODEL SUMMARY'/' -------------') 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 REAL + F(*),FCST(IFCST,*),FCSTSD(*),FSD(*),PAR(*),PARAR(*),PARDF(*), + PARMA(*),PV(N1:N2),T(*),TEMP(*),Y(*) INTEGER + IFCSTO(*),MSPECT(NFAC,4) C C LOCAL SCALARS REAL + CONST,PMU,RSD,RSS,T975,WSUM,WSUMT INTEGER + I,I1,IDF,IF,IFC,IFLAG,IFO,IFOMIN,IPRT,J,K,NT LOGICAL + PAGE C C EXTERNAL FUNCTIONS REAL + PPFT,SDOT EXTERNAL PPFT,SDOT C C EXTERNAL SUBROUTINES EXTERNAL AMFHDR,AMFOUT,AMLST,DCOEF,IPRINT,MDLTS2,MODSUM,MULTBP C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CONST C THE CONSTANT TERM IN THE MODEL, MODELING EITHER THE SERIES C MEAN OR A DETERMINISTIC TREND. C REAL F(NFCST) C THE FORECASTS. C REAL FCST(IFCST,NFCSTO) C THE STORAGE ARRAY FOR THE FORECASTS. C REAL FCSTSD(NFCST) C THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS. C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PARAR(MBO) C THE AUTOREGRESSIVE PARAMETERS C REAL PARDF(NPARDF) C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS. C REAL PARMA(MBO) C THE MOVING AVERAGE PARAMETERS C REAL PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C REAL PV(N1:N2) C THE PREDICTED VALUE OF THE FIT. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL 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 REAL T(2*MBO) C A TEMPORARY WORK VECTOR. C REAL TEMP(MBO) C A TEMPORARY WORK VECTOR C REAL T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C REAL WSUM C THE SUM OF THE WEIGHTS SQUARED, USED TO COMPUTE THE C STANDARD DEVIATION OF THE FORECAST. C REAL WSUMT C A TEMPORARY STORAGE LOCATION FOR WSUM. C REAL Y(N) C THE DEPENDENT VARIABLE. C 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 = SDOT(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.0E0 IF (PMU.NE.0.0E0) THEN IF (NPARAR.GE.1) THEN DO 20 J = 1, NPARAR CONST = CONST - PARAR(J) 20 CONTINUE END IF CONST = (1.0E0 + 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.0E0 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.0E0 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.975E0, 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 IF (NPRT.NE.0) + CALL AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y, T975, + PAGE) C 100 CONTINUE C RETURN C 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 REAL + T975 INTEGER + IFO,N,NFCST,NFCSTO LOGICAL + PAGE C C ARRAY ARGUMENTS REAL + F(*),FSD(*),Y(*) INTEGER + IFCSTO(*) C C LOCAL SCALARS REAL + FL,FU,SCALE,YMN,YMX INTEGER + I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPRT,IPY,IY,J C C LOCAL ARRAYS REAL + YLIM(4) CHARACTER + LINE(53)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMFHDR,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC INT,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL F(NFCST) C THE FORECASTS. C REAL FL C THE LOWER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST C REAL FSD(NFCST) C THE STANDARD DEVIATIONS OF THE FORECASTS. C REAL 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 REAL SCALE C THE PLOT SCALE. C REAL T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C REAL Y(N) C THE DEPENDENT VARIABLE. C REAL YLIM(4) C THE VALUES OF THE AXIS LABELS. C REAL YMN C THE MINIMUM VALUE TO BE PLOTTED. C REAL YMX C THE MAXIMUM VALUE TO BE PLOTTED. C C SET VARIABLES FOR PLOTS C 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.0E0 30 CONTINUE C CALL AMFHDR(PAGE, .TRUE., 0) WRITE (IPRT, 1030) IFO WRITE (IPRT, 1000) YMN, YLIM(2), YLIM(4), + YLIM(1), YLIM(4), YMX 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.5E0) LINE(IPY) = '*' WRITE (IPRT, 1020) I, (LINE(J),J=1,IEND), I, Y(I) 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.5E0) IPFU = INT(((FU-YMN) / SCALE) + 1.5E0) DO 60 J = IPFL, IPFU LINE(J) = '-' 60 CONTINUE LINE(IPFL) = '(' LINE(IPFU) = ')' IPY = INT(((Y(I)-YMN) / SCALE) + 1.5E0) LINE(IPY) = '*' IPF = INT(((F(IF)-YMN) / SCALE) + 1.5E0) IF (IPF.NE.IPY) THEN LINE(IPF) = 'X' ELSE LINE(IPF) = '2' END IF WRITE (IPRT, 1010) I, (LINE(J),J=1,IEND), I, + F(IF), FL, FU, Y(I) ELSE IPFL = INT(((FL-YMN) / SCALE) + 1.5E0) IPFU = INT(((FU-YMN) / SCALE) + 1.5E0) DO 70 J = IPFL, IPFU LINE(J) = '-' 70 CONTINUE LINE(IPFL) = '(' LINE(IPFU) = ')' IPF = INT(((F(IF)-YMN) / SCALE) + 1.5E0) LINE(IPF) = 'X' WRITE (IPRT, 1010) I, (LINE(J),J=1,IEND), I, + F(IF), FL, FU END IF END IF 80 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (// + 82X, ' --------------------95 PERCENT'/ + 1X, 3(G15.8, 5X), 21X, + ' --------------CONFIDENCE LIMITS', + ' ---------ACTUAL'/ + 11X, 2(G15.8, 5X), G15.8, + ' ------FORECASTS ----------LOWER', + ' ----------UPPER -------IF KNOWN'/ + 9X, 5('I---------'), 'I', 6X, + ' ------------[X] ------------[(]', + ' ------------[)] ------------[*]') 1010 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 4(1X, G15.8)) 1020 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 49X, G15.8) 1030 FORMAT (//' FORECASTS FOR ORIGIN ', I2) 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 REAL + T975 INTEGER + IAMHD,IPARMN,IPARMX,LBLTYP,LSCALE,LSTPT,LVCVL,NFAC,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),STPT(*),VCVL(*) INTEGER + IFIXD(*),MSPECT(NFAC,4) C C LOCAL SCALARS REAL + FPLM,PLL,PUL,RATIO,SDPAR INTEGER + IPRT,J,K,L,LL,LPAR,ORDER C C LOCAL ARRAYS CHARACTER + FIXED(3)*1 C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL FIXPRT,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 FIXED(3) C THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT. C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PLL C THE LOWER CONFIDENCE LIMIT FOR A GIVEN PARAMETER. C REAL PUL C THE UPPER CONFIDENCE LIMIT FOR A GIVEN PARAMETER. C REAL RATIO C THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPAR C THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE. C REAL STPT(LSTPT) C THE STEP SIZE ARRAY. C REAL T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C REAL VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C C FPLM = R1MACH(2) C CALL IPRINT(IPRT) 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 ((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) GO TO 25 CALL FIXPRT(IFIXD(L), FIXED) IF (LBLTYP.EQ.1) WRITE(IPRT, 1000) L, J, ORDER, + (FIXED(K),K=1,3), PAR(L) IF (LBLTYP.EQ.2) WRITE(IPRT, 1004) L, + (FIXED(K),K=1,3), PAR(L) IF (LBLTYP.EQ.3) WRITE(IPRT, 1005) L, J, ORDER, + (FIXED(K),K=1,3), PAR(L) IF (IAMHD.EQ.3) GO TO 10 C IF (IFIXD(L).EQ.0) GO TO 5 WRITE (IPRT, 1007) GO TO 10 C 5 CONTINUE IF (SCALE(1).LE.0.0E0) WRITE (IPRT, 1001) STPT(L) IF (SCALE(1).GT.0.0E0) WRITE (IPRT, 1002) SCALE(L), STPT(L) 10 CONTINUE IF (IAMHD .EQ. 1) GO TO 30 C IF (IFIXD(L).EQ.0) GO TO 20 WRITE(IPRT, 1006) GO TO 30 C 20 CONTINUE LPAR = LPAR + 1 RATIO = FPLM LL = LPAR*(LPAR-1)/2 + LPAR IF (VCVL(LL).GT.0.0E0) RATIO = PAR(L)/SQRT(VCVL(LL)) SDPAR = SQRT(VCVL(LL)) PLL = PAR(L) - T975*SDPAR PUL = PAR(L) + T975*SDPAR WRITE(IPRT, 1003) SDPAR, RATIO, PLL, PUL GO TO 30 25 CONTINUE IF (LBLTYP.EQ.1) WRITE(IPRT, 1010) L, J, ORDER, PAR(L) IF (LBLTYP.EQ.2) WRITE(IPRT, 1014) L, PAR(L) IF (LBLTYP.EQ.3) WRITE(IPRT, 1015) L, J, ORDER, PAR(L) 30 CONTINUE IPARMN = IPARMX + 1 40 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,6X,3A1,E17.8) 1001 FORMAT ('+', 65X, 7HDEFAULT, E17.8) 1002 FORMAT ('+', 55X, 2E17.8) 1003 FORMAT ('+', 55X, 4(2X, E15.8)) 1004 FORMAT(1X, I5, 13X, 'MU', 4X, ' ---' ,6X,3A1,E17.8) 1005 FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,6X,3A1,E17.8) 1006 FORMAT('+', 55X, 4(14X, '---')) 1007 FORMAT('+', 69X, '---', 14X, '---') 1010 FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,E17.8) 1014 FORMAT(1X, I5, 13X, 'MU', 4X, ' ---' ,E17.8) 1015 FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,E17.8) 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 REAL + RSD,RSS INTEGER + IAMHD,IDF,LSCALE,LSTPT,LVCVL,N,NFAC,NPAR,NPARDF,NPARE C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),STPT(*),VCVL(*) INTEGER + IFIXD(*),MSPECT(NFAC,4) C C LOCAL SCALARS REAL + FPLM,T975 INTEGER + IPARMN,IPARMX,IPRT,LBLTYP C C EXTERNAL FUNCTIONS REAL + PPFT,R1MACH EXTERNAL PPFT,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL AMLST1,IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL STPT(LSTPT) C THE STEP SIZE ARRAY. C REAL T975 C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C REAL VCVL(LVCVL) C THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED C ROW WISE. C FPLM = R1MACH(2) C CALL IPRINT(IPRT) C C PRINT HEADING FOR INFORMATION ABOUT PARAMETERS C WRITE(IPRT, 1001) C IF (IAMHD .EQ. 1) WRITE(IPRT, 1004) IF (IAMHD .EQ. 2) WRITE(IPRT, 1005) IF (IAMHD .EQ. 3) WRITE(IPRT, 1006) WRITE(IPRT, 1001) C C PRINT MODEL SUMMARY INFORMATION C IPARMN = 1 IPARMX = 0 T975 = PPFT(0.95E0, 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 (IPRT, 1160) N IF (IAMHD.GE.2) + WRITE (IPRT, 1040) RSS, RSD, N, NPARDF, NPARE, IDF RETURN C C FORMAT STATEMENTS C 1001 FORMAT(1X) 1004 FORMAT (//73X, ' --STEP SIZE FOR'/ + 39X, ' ------PARAMETER', 17X, ' --APPROXIMATING'/ + ' -----------------PARAMETER DESCRIPTION STARTING VALUES', + ' ----------SCALE -----DERIVATIVE'/ + ' INDEX ---------TYPE --ORDER --FIXED ----------(PAR)', + ' --------(SCALE) ----------(STP)') 1005 FORMAT(30X, ' ------PARAMETER'/ + ' --------PARAMETER DESCRIPTION ------ESTIMATES'/ + ' INDEX ---------TYPE --ORDER ----------(PAR)') 1006 FORMAT( + 39X, ' ------PARAMETER -----STD DEV OF', 17X, + ' ---------------------APPROXIMATE'/ + ' -----------------PARAMETER DESCRIPTION ------ESTIMATES', + ' ------PARAMETER ----------RATIO', + ' ----95 PERCENT CONFIDENCE LIMITS'/ + ' INDEX ---------TYPE --ORDER --FIXED ----------(PAR)', + ' ------ESTIMATES', + ' PAR/(SD OF PAR) ----------LOWER ----------UPPER') 1040 FORMAT (//' RESIDUAL SUM OF SQUARES ', 8X, G15.7, + ' (BACKFORECASTS INCLUDED)'//6H RESID, + 25HUAL STANDARD DEVIATION , 8X, G15.7/19H BASED ON DEGREES O, + 9HF FREEDOM, 1X, I4, 3H - , I3, 3H - , I3, 3H = , I4) 1160 FORMAT (//23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5) END *AOS SUBROUTINE AOS (N, LAGMAX, ACOV, PRHO, IAR, OSPVAR, PHI, WORK, + AIC, FTEST, LACOV, LAIC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES AUTOREGRESSIVE MODEL ORDER SELECTION C STATISTICS. IT PERFORMS STEPWISE FITTING OF AUTOREGRESSIVE C COEFFICIENTS BY DURBINS METHOD USING AKAIKES AIC CRITERION C FOR SELECTING ORDER. THE ROUTINE IS MODELED AFTER C SUBROUTINE UFPE WRITTEN BY DICK JONES. 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 REAL + OSPVAR INTEGER + IAR,LACOV,LAGMAX,LAIC,N C C ARRAY ARGUMENTS REAL + ACOV(LACOV),AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX), + PRHO(LAGMAX),WORK(LAGMAX) C C LOCAL SCALARS REAL + ACOV0,AICMIN,FPLM,RSS,RSSMIN,SQPACF INTEGER + I,J C C EXTERNAL FUNCTIONS REAL + CDFF,R1MACH EXTERNAL CDFF,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL ARCOEF C C INTRINSIC FUNCTIONS INTRINSIC LOG,REAL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV), ACOV0 C THE AUTOCOVARIANCES FOR LAGS ZERO TO LAGMAX, AND THE C AUTOCOVARIANCE AT LAG ZERO. C REAL AIC(LAIC), AICMIN C THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER, WHERE C AIC(I+1) IS THE CRITERIA FOR ORDER I-1, AND THE MINIMUM C CRITERIA COMPUTED. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL FTEST(2, LAGMAX) C THE ARRAY IN WHICH THE F PERCENTAGE POINT AND PROBABILITY ARE C STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER J C AN INDEX VARIABLE. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED (IAR). C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL PRHO(LAGMAX) C THE ARRAY CONTAINING THE PARTIAL AUTOCORRELATION C COEFFICIENTS. C REAL RSS, RSSMIN C THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES AND THE C MINIMUM ONE STEP PREDICTION RESIDUAL SUM OF SQUARES. C REAL SQPACF C THE SQUARED VALUE OF THE PARTIAL AUTOCORRELATION FUNCTION AT C LAG I. C REAL WORK(LAGMAX) C A REAL WORK AREA. C FPLM = R1MACH(2) C RSS = ACOV(1) * N RSSMIN = RSS AIC(1) = N * LOG(RSS * (N+1) / (N-1)) AICMIN = AIC(1) IAR = 0 C C START STEPWISE PROCEDURE C WORK(1) = ACOV(2) / ACOV(1) PRHO(1) = WORK(1) RSS = RSS * (1.0E0 - WORK(1)*WORK(1)) AIC(2) = N * LOG(RSS * (N+2) / (N-2)) C SQPACF = WORK(1) * WORK(1) FTEST(1, 1) = FPLM FTEST(2, 1) = 0.0E0 IF (SQPACF .GE. 1.0E0) GO TO 5 C FTEST(1,1) = (N-2) * SQPACF / (1.0E0 - SQPACF) C FTEST(2,1) = 1.0E0 - CDFF(FTEST(1,1), 1.0E0, REAL(N-2)) C 5 CONTINUE C IF (AIC(2).GE.AICMIN) GO TO 10 AICMIN = AIC(2) RSSMIN = RSS IAR = 1 PHI(1) = WORK(1) C 10 IF (LAGMAX.LE.1) GO TO 40 C ACOV0 = ACOV(1) C DO 30 I=2,LAGMAX CALL ARCOEF (ACOV(2), WORK, RSS, I, LAGMAX, ACOV0) PRHO(I) = WORK(I) AIC(I+1) = FPLM FTEST(1,I) = FPLM FTEST(2,I) = FPLM IF (I.EQ.N-1) GO TO 15 C AIC(I+1) = N * LOG(RSS * (N+I+1) / (N-I-1)) C SQPACF = WORK(I) * WORK(I) IF (SQPACF .GE. 1.0E0) GO TO 15 C FTEST(1,I) = (N-I-1) * SQPACF / (1.0E0 - SQPACF) C FTEST(2,I) = 1.0E0 - CDFF(FTEST(1,I), 1.0E0, REAL(N-I-1)) C 15 CONTINUE C C IF THIS AIC IS A MINIMUM AND ITS LAG DOES NOT EXCEED N/2, C SAVE THE COEFFICIENTS. C IF ((AIC(I+1).GE.AICMIN) .OR. (I.GT.N/2)) GO TO 30 AICMIN = AIC(I+1) RSSMIN = RSS IAR = I DO 20 J=1,I PHI(J) = WORK(J) 20 CONTINUE 30 CONTINUE C C NORMALIZE AIC C 40 CONTINUE AIC(1) = AIC(1) - AICMIN DO 50 I=1,LAGMAX AIC(I+1) = AIC(I+1) - AICMIN 50 CONTINUE C OSPVAR = RSSMIN / (N-IAR-1) C RETURN END *AOSLST SUBROUTINE AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI, + OSPVAR, IFPRHO, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE LISTS THE AUTOREGRESSIVE MODEL ORDER SELECTION C STATISTICS. 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 REAL + OSPVAR INTEGER + IAR,LAGMAX,LAIC,N LOGICAL + IFPRHO C C ARRAY ARGUMENTS REAL + AIC(*),FTEST(2,*),PHI(*),PRHO(*) C C LOCAL SCALARS INTEGER + I,IMAX,IMIN,IPRT,LAG,M,NPERL CHARACTER + FMT*160 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AIC(LAIC) C THE ARRAY CONTAINING THE AKAIKES INFORMATION CRITERION. C CHARACTER*160 FMT C THE FORMAT USED. C REAL FTEST(2, LAGMAX) C THE ARRAY CONTIANING THE PARTIAL F RATIO AND ITS PROBABILITY C OF BEING EXCEEDED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE MODEL SELECTED. C LOGICAL IFPRHO C THE LOGICAL VARIABLE USED TO INDICATE IF THE PARTIAL C AUTOCORRELATIONS ARE BEING PRINTED. IF -IFPRHO- IS C .FALSE. THE AUTOCORRELATIONA AND THEIR STANDARD ERRORS C ARE PRINTED, IF .TRUE., THE PARTIALS. C INTEGER IMAX, IMIN C THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION C TO BE PRINTED PER LINE C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT C INTEGER LAG C THE LAG VALUE OF THE AUTOREGRESSIVE ORDER SELECTION STATISTIC C BEING PRINTED. C INTEGER LAGMAX C THE MAXIMUM LAG AT WHICH THE AUTOREGRESSIVE ORDER SELECTION C STATISTICS WERE COMPUTED. C INTEGER LAIC C THE LENGTH OF THE VECTOR AIC. C INTEGER M C AN INDEX VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NPERL C THE NUMBER OF VALUES TO BE PRINTED PER LINE. C REAL OSPVAR C THE ONE STEP PREDICTION VARIANCE FOR THE ORDER SELECTED. C REAL PHI(LAGMAX) C THE AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED ORDER. C REAL PRHO(LAGMAX) C THE ARRAY CONTAINING THE PARTIAL AUTOCORRELATION C COEFFICIENTS. C CALL IPRINT(IPRT) C NPERL = 12 DO 30 I = 1, LAGMAX, NPERL IMIN = I IMAX = MIN(I + NPERL - 1, LAGMAX) WRITE(IPRT, 1000) (LAG, LAG = IMIN, IMAX) IF (IFPRHO) WRITE (IPRT, 1001) (PRHO(LAG), LAG = IMIN, IMAX) C IF ((IMAX.EQ.LAGMAX) .AND. (LAGMAX.EQ.(N-1))) THEN IF (IMAX-IMIN.GE.1) THEN WRITE(FMT, 1002) IMAX-IMIN ELSE WRITE(FMT, 1003) END IF WRITE(IPRT, FMT) ' AIC ', + (AIC(LAG+1), LAG = IMIN, IMAX-1) WRITE(IPRT, FMT) ' F RATIO ', + (FTEST(1, LAG), LAG = IMIN, IMAX-1) WRITE(IPRT, FMT) ' F PROBABILITY ', + (FTEST(2, LAG), LAG = IMIN, IMAX-1) ELSE WRITE(FMT, 1004) NPERL WRITE(IPRT, FMT) ' AIC ', + (AIC(LAG+1), LAG = IMIN, IMAX) WRITE(IPRT, FMT) ' F RATIO ', + (FTEST(1, LAG), LAG = IMIN, IMAX) WRITE(IPRT, FMT) ' F PROBABILITY ', + (FTEST(2, LAG), LAG = IMIN, IMAX) END IF 30 CONTINUE C IF (LAGMAX.EQ.N-1) WRITE(IPRT, 1009) C C PRINT INFORMATION ON ORDER SELECTED C WRITE (IPRT, 1005) IAR, OSPVAR C IF (IAR .EQ. 0) RETURN C WRITE(IPRT, 1008) C DO 40 I = 1, IAR, NPERL IMIN = I IMAX = MIN(I + NPERL - 1, IAR) WRITE (IPRT, 1006) (M, M = IMIN, IMAX) WRITE (IPRT, 1007) (PHI(M), M = IMIN, IMAX) 40 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/19H LAG , 12(1X, I6)) 1001 FORMAT( 19H PACF , 12(2X, F5.2)) 1002 FORMAT('(A19,',I2,'(1X, F6.2), 7H ******)') 1003 FORMAT('(A19, 7H ******)') 1004 FORMAT('(A19,',I2,'(1X, F6.2))') 1005 FORMAT (// + 49H ORDER AUTOREGRESSIVE PROCESS SELECTED = , I6/ + 51H ONE STEP PREDICTION VARIANCE OF PROCESS SELECTED =, G15.8/) 1006 FORMAT (/19H COEFFICIENT NUMBER, 12(1X, I6)) 1007 FORMAT ( 19H COEFFICIENT VALUE , 12(1X, F6.4)) 1008 FORMAT (45H YULE-WALKER ESTIMATES OF THE COEFFICIENTS OF, + 36H THE AUTOREGRESSIVE PROCESS SELECTED) 1009 FORMAT (/'****** THIS VALUE CANNOT BE COMPUTED', + ' BECAUSE LAG = N-1'//) C END *AOV1ER SUBROUTINE AOV1ER(Y, TAG, N, IGSTAT, NZTAGS, NG, LDSTAK, NMSUB, + INDEX, ISAOV1, NALL0) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE DOES PRELIMINARY CHECKING FOR ERRORS IN THE INPUT C PARAMETERS OF THE ONEWAY FAMILY. C C WRITTEN BY - C LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IGSTAT,INDEX,ISAOV1,LDSTAK,N,NALL0,NG,NZTAGS C C ARRAY ARGUMENTS REAL + TAG(*),Y(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,IPRT,J,LDSMIN,NV LOGICAL + ERROR,HEAD C C LOCAL ARRAYS INTEGER + ISTAK(12) CHARACTER + LIGSTA(8)*1,LLDS(8)*1,LN(8)*1,LNG(8)*1,LTAG(8)*1, + LTWO(8)*1,LZERO(8)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERVGT,GENI,IPRINT,LDSCMP,SRTIRR,SRTRRI, + STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERROR C SET TRUE IF THE ERROR CHECKING ROUTINE FOUND ANY ERRORS C LOGICAL HEAD C INDICATES WHETHER HEADING NEEDS TO BE PRINTED C TRUE - YES, NEEDS TO BE PRINTED C FALSE - NO, HAS BEEN PRINTED C INTEGER I C * C INTEGER IERR C IF IERR .NE. 0, THEN ERRORS WHERE FOUND IN THE PARAMETERS C INTEGER IGSTAT C * C INTEGER INDEX C THE STARTING LOCATION IN THE STACH AREA OF THE INDEX FOR C THE SORTED TAGS. C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C INTEGER ISAOV1 C AN INDICATOR VARIABLE USED FOR THE COMPUTATION OF WORK C SPACE. IF ISAOV1 = 0, THE CALLING ROUTINE IS AOV1S. IF C ISAOV1 = 1, THE CALLING ROUTINE IS AOV1. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER J C * C INTEGER LDSMIN C THE MINIMUM SIZE ALLOWED FOR THE STACK C INTEGER LDSTAK C SIZE OF STACK ALLOCATED IN THE USERS MAIN PROGRAM C CHARACTER*1 LIGSTA(8), LLDS(8), LN(8), LNG(8), LTAG(8), C * LTWO(8), LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLE(S) CHECKED C ERRORS C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NALL0 C OUTPUT PARAMETER. NUMBER OF STACK ALLOCATIONS AFTER C STACK IS INITIALIZED. C INTEGER NG C * C CHARACTER*1 NMSUB(6) C NAME OF THE CALLING SUBROUTINE C INTEGER NV C THE NUMBER OF VALUES LESS THAN OR EQUAL TO ZERO. C INTEGER NZTAGS C THE NUMBER OF POSITIVE NON-ZERO TAGS, TO BE DETERMINED BY C THIS ROUTINE C REAL TAG(N) C THE VECTOR OF TAGS. C REAL Y(N) C THE VECTOR OF OBSERVATIONS. C DATA LIGSTA(1),LIGSTA(2),LIGSTA(3),LIGSTA(4),LIGSTA(5),LIGSTA(6), + LIGSTA(7),LIGSTA(8) + / 'I', 'G', 'S', 'T', 'A', '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 LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LNG(1), LNG(2), LNG(3), LNG(4), LNG(5), LNG(6), + LNG(7), LNG(8) + / 'N', 'G', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LTAG(1), LTAG(2), LTAG(3), LTAG(4), LTAG(5), LTAG(6), + LTAG(7), LTAG(8) + / 'T', 'A', 'G', ' ', ' ', ' ', ' ', ' '/ DATA LTWO(1), LTWO(2), LTWO(3), LTWO(4), LTWO(5), LTWO(6), + LTWO(7), LTWO(8) + / 'T', 'W', 'O', ' ', ' ', ' ', ' ', ' '/ DATA LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5), LZERO(6), + LZERO(7), LZERO(8) + / 'Z', 'E', 'R', 'O', ' ', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C IERR = 0 HEAD = .TRUE. C C SET UP OUTPUT UNIT CALL IPRINT(IPRT) C C BEGIN ERROR CHECKING. C C NUMBER OF OBSERVATIONS LESS THAN 2 C CALL EISGE(NMSUB, LN, N, 2, 2, HEAD, ERROR, LTWO) IF (ERROR) GO TO 50 C C NUMBER OF NON-ZERO TAGS LESS THAN 2 C CALL ERVGT(NMSUB, LTAG, TAG, N, 0.0E0, (N-2), HEAD, 7, NV, ERROR, + LZERO) IF (ERROR) GO TO 50 C NZTAGS = N - NV C C STACK MUST BE LARGE ENOUGH FOR A VECTOR OF LENGTH N TO CONTINUE C CALL LDSCMP(1, 0, N, 0, 0, 0, 'S', 0, LDSMIN) CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR, LLDS) IF (ERROR) WRITE(IPRT, 1000) IF (ERROR) GO TO 50 C C INITIALIZE STACK AND NALL0 C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C INDEX = STKGET(N,2) C C SORT TAG VECTOR CARRYING ALONG INDEX TO ORIGINAL ORDER AND THE C VECTOR OF OBSERVATIONS C CALL GENI(ISTAK(INDEX), N, 1, 1) CALL SRTIRR(ISTAK(INDEX), Y, N, TAG) C C COUNT THE NUMBER OF DIFFERENT TAG VALUES C J = N - NZTAGS + 2 NG = 1 DO 10 I=J,N IF (TAG(I).GT.TAG(I-1)) NG = NG + 1 10 CONTINUE C C LESS THAN 2 DIFFERENT TAG GROUPS C CALL EISII(NMSUB, LNG, NG, 2, NZTAGS-1, 3, HEAD, ERROR, + LTWO, LN) IF (ERROR) GO TO 40 C C CHECK THAT DIMENSION OF STATISTICS MATRIX IS SUFFICIENT C CALL EISGE(NMSUB, LIGSTA, IGSTAT, NG, 3, HEAD, ERROR, LNG) IF (ERROR) GO TO 40 C C COMPUTE AND CHECK FOR SUFFICIENT STACK C CALL LDSCMP(11, 0, N+NZTAGS, 0, 0, 0, + 'S', ISAOV1*4*NG+4*NG+NZTAGS, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR, LLDS) IF (.NOT.ERROR) RETURN C 40 CONTINUE C C REORDER DATA C CALL SRTRRI(TAG, Y, N, ISTAK(INDEX)) C C CLEAR STACK, IN CASE WHERE ERROR FOLLOWS ALLOCATION OF STACK. C CALL STKCLR (NALL0) C 50 CONTINUE IERR = 1 RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/' NOTE. THE VALUE OF LDSTAK MENTIONED ABOVE IS THE', + ' MINIMUM NECESSARY'/ + ' TO CONTINUE CHECKING FOR ERRORS AND', + ' TO CALCULATE THE CORRECT VALUE'/ + ' OF LDSTAK. THE CORRECT', + ' VALUE WILL BE LARGER. CONSULT THE DOCUMENTATION'/ + ' FOR THE FORMULAS USED TO CALCULATE LDSTAK.') END *AOV1 SUBROUTINE AOV1(Y, TAG, N, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE - C 1. CALLS OTHER ROUTINES TO CHECK THE INPUT PARAMETERS C 2. SETS UP THE NEEDED STORAGE LOCATIONS, AND C 3. CALLS AOV1MN TO COMPUTE A COMPREHENSIVE SET OF RESULTS FOR A C ONEWAY ANALYSIS OF VARIANCE WITH AUTOMATIC PRINTOUT. C C WRITTEN BY - C LINDA MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C BASED ON EARLIER VERSION BY J. R. DONALDSON C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N C C ARRAY ARGUMENTS REAL + TAG(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + B10,DTMEAN,DTSD,DTSIZE,GPMAX,GPMIN,IFP,INDEX,INT,IPRT, + ITEMP,NALL0,NG,NPRT,NZTAGS,RANKS,SRANK,TVAL C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET EXTERNAL STKGET C C EXTERNAL SUBROUTINES EXTERNAL AOV1ER,AOV1HD,AOV1MN,IPRINT,STKCLR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER B10 C STARTING LOCATION IN THE STACK AREA FOR B10 C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER DTMEAN C THE STARTING LOCATION IN THE STACK AREA FOR THE MEANS C OF EACH GROUP C INTEGER DTSD C THE STARTING LOCATION IN THE STACK AREA OF THE C STANDARD DEVIATIONS C INTEGER DTSIZE C THE STARTING LOCATION IN THE STACK AREA OF THE SIZE OF THE C DIFFERENT GROUPS C INTEGER GPMAX C THE STARTING LOCATION IN THE STACK AREA OF MAXIMUM C OBSERVATION C INTEGER GPMIN C THE STARTING LOCATION IN THE STACK AREA OF THE MINUMUM C OBSERVATION C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG INDICATING WHETHER THERE C ARE ANY ERRORS, IF = 0 THEN NO ERRORS C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX C THE STARTING LOCATION IN THE STACK ARRAY OF THE INDEX FOR C THE SORTED TAGS C INTEGER INT C FRAMEWORK CODE VALUE FOR INTEGER NUMBERS C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ITEMP C STARTING LOCATION IN THE STACK FOR THE C TEMPORARY STORAGE ARRAY C INTEGER LDSTAK C SIZE OF THE STACK AREA ALLOCATED IN THE USERS MAIN PROGRAM C INTEGER N C THE NUMBER OF OBSERVATIONS TO BE ANALYZED C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT THIS C ROUTINE WAS CALLED. C INTEGER NG C THE NUMBER OF GROUPS WITH DIFFERENT POSITIVE TAG VALUES C CHARACTER*1 NMSUB(6) C SUBROUTINE NAME C INTEGER NPRT C THE VARIABLE CONTROLLING AUTOMATIC PRINTOUT C IF =0, PRINTOUT IS SUPRESSED C OTHERWISE PRINTOUT IS PROVIDED C INTEGER NZTAGS C THE NUMBER OF OBSERVATIONS WITH POSITIVE NON-ZERO WIEGHTS C INTEGER RANKS C THE STARTING LOCATION IN WORK AREA FOR THE RANKS OF Y C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SRANK C THE STARTING LOCATION IN STACK FOR THE SUM OF RANKS C REAL TAG(N) C THE VECTOR OF TAG VALUES C INTEGER TVAL C THE STARTING LOCATION IN THE STACK FOR THE VECTOR OF C THE DIFFERENT POSITIVE TAG VALUES, FOR AOV1 C REAL Y(N) C THE VECTOR OF OBSERVATIONS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'O', 'V', '1', ' ', ' '/ C CALL IPRINT(IPRT) C C SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES C INT = 2 IFP = 3 C C CHECK FOR ERRORS IN PARAMETERS, INITIALIZE STACK, AND SET NALL0. C CALL AOV1ER(Y, TAG, N, N, NZTAGS, NG, LDSTAK, NMSUB, INDEX, 1, + NALL0) C IF (IERR.EQ.0) GO TO 20 C C PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER C IERR = 1 WRITE (IPRT,1000) RETURN C C PRINT HEADING C 20 CALL AOV1HD(IPRT) C C SET UP ADDITIONAL WORK VECTORS FOR AOV1MN AS CALLED FROM AOV1 C TVAL = STKGET(NG,IFP) DTSIZE = STKGET(NG,IFP) DTMEAN = STKGET(NG,IFP) DTSD = STKGET(NG,IFP) SRANK = STKGET(NG,IFP) GPMIN = STKGET(NG,IFP) GPMAX = STKGET(NG,IFP) B10 = STKGET(NG,IFP) RANKS = STKGET(NZTAGS,IFP) ITEMP = STKGET(NZTAGS,INT) C NPRT = 1 C CALL AOV1MN(Y, TAG, N, RSTAK(TVAL), RSTAK(DTSIZE), RSTAK(DTMEAN), + RSTAK(DTSD), NPRT, ISTAK(INDEX), RSTAK(SRANK), RSTAK(GPMIN), + RSTAK(GPMAX), RSTAK(B10), RSTAK(RANKS), + ISTAK(ITEMP), NG, NZTAGS) C C RELEASE THE STACK AREA C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENT C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL AOV1 (Y, TAG, N, LDSTAK)') END *AOV1HD SUBROUTINE AOV1HD(IPRT) C C LATEST REVISION - 03/15/90 (JRD) C C A SUBROUTINE TO PRINT OUT THE HEADING FOR THE ONEWAY ANOVA C FAMILY, AND IS THE ONLY SOURCE FOR HEADINGS IN THAT FAMILY C C AUTHOR - C JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C CALL VERSP(.TRUE.) WRITE (IPRT,1000) RETURN 1000 FORMAT(///48X, 20HANALYSIS OF VARIANCE//) END *AOV1MN SUBROUTINE AOV1MN(Y, TAG, N, TVALUE, TSIZE, TMEAN, TSD, NPRT, + INDEX, SRANK, GPMIN, GPMAX, B10, RANKS, ITEMP, NG, NZW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES A COMPREHENSIVE SET OF RESULTS FOR C ANALYSIS OF A ONE-WAY CLASSIFICATION WITH OPTIONAL PRINTED OUTPUT. C TAG VALUES CAN BE ANY VALUE WHERE ALL MEASUREMENTS WITH TAG C VALUES LESS THAN OR EQUAL TO ZERO ARE EXCLUDED FROM ANALYSIS. C C ORIGINALLY WRITTEN FOR OMNITAB BY - C DAVID HOGBEN, STATISTICAL ENGINEERING DIVISION, NBS (10/25/69) C C ADAPTED BY - C JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NG,NPRT,NZW C C ARRAY ARGUMENTS REAL + B10(*),GPMAX(*),GPMIN(*),RANKS(*),SRANK(*),TAG(*),TMEAN(*), + TSD(*),TSIZE(*),TVALUE(*),Y(*) INTEGER + INDEX(*),ITEMP(*) C C LOCAL SCALARS REAL + AF,BF,BFRAT,BFSIG,BMS,BSS,C,CC,CFKW,DF,DFRAT,DFSIG,DMS,DSS,F, + F1KW,F2KW,FMLC,FMUC,FNZW,FPLM,FSTAT,G1,GM,GR,HSTAT,IBAR,K0, + MF,MKW,Q,RESSQ,RMLC,RMUC,RX,SBMS,SC,SFRAT,SFSIG,SIGKW,SLBF, + SLCC,SMAX,SMIN,SMS,SNC,SOS,SQB,SQMS,SQOM,SQT,SSF,SSS,STMS, + SUM,SWMS,T1,T2,T3,TIES,TMS,TSS,U1,U2,UMLC,UMUC,V1,V2,VKW,VLS, + WMS,WSS,YBMAX,YBMIN,YMAX,YMIN INTEGER + I,IPRT,ISZ,J,K,KK,KKK,L,M,M28,M3,M5,NN,NNE1,NZPNTR CHARACTER + BLANK*1,HIGH*1,ISD*1,LOW*1,MEAN*1 C C LOCAL ARRAYS REAL + STATS(15) C C EXTERNAL FUNCTIONS REAL + CDFF,PPFF,PPFT,R1MACH EXTERNAL CDFF,PPFF,PPFT,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,RANKO,SRTIR,SRTRI,SRTRRI C C INTRINSIC FUNCTIONS INTRINSIC ABS,ANINT,INT,LOG,MAX,MIN,NINT,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AF C A FOR F C REAL BF C BARTLETT F C REAL BFRAT C BETWEEN GROUPS F RATIO C REAL BFSIG C BETWEEN GROUPS SIGNIFICANCE LEVEL C CHARACTER*1 BLANK C HOLLERITH BLANK C REAL BMS C BETWEEN MS C REAL BSS C BETWEEN SS C REAL B10(NG) C * C REAL C C INTERMEDIATE RESULT STORAGE C REAL CC C COCHRANS C C REAL CFKW C CORRECTION FACTOR FOR KRUSKAL-WALLIS C REAL DF C D.F. C REAL DFRAT C DEVIATIONS ABOUT LINE F RATIO C REAL DFSIG C DEVIATIONS ABOUT LINE F SIGNIFICANCE LEVEL C REAL DMS C DEVIATIONS ABOUT LINE MS C REAL DSS C DEVIATIONS ABOUT LINE SS C REAL F C BETWEEN MEANS F-TEST C REAL FMLC C FIXED MODEL LOWER CONFIDENCE LIMIT FOR MEAN C REAL FMUC C FIXED MODEL UPPER CONFIDENCE LIMIT FOR MEAN C REAL FNZW C * C REAL FPLM C LARGEST SINGLE PRECISION MAGNITUDE OF MACHINE C REAL FSTAT C F STATISTIC ASSOCIATED WITH KRUSKAL-WALLIS H STATISTIC C REAL F1KW C F1 D.F. FOR KRUSKAL-WALLIS F C REAL F2KW C F2 D.F. FOR KRUSKAL-WALLIS F C REAL GM C GRAND MEAN, MEAN OF ALL OBSERVATIONS WITH POSITIVE C NON-ZERO TAGS C REAL GPMAX(NG) C THE VECTOR OF MAXIMUM OBSERVATIONS FOR EACH GROUP C REAL GPMIN(NG) C THE VECTOR OF MINIMUM OBSERVATIONS FOR EACH GROUP C REAL GR C NZW-NG C REAL G1 C NG-1 C CHARACTER*1 HIGH C HOLLERITH + (PLUS) C REAL HSTAT C KRUSKAL-WALLIS H STATISTIC, SEE BROWNLEE(1965), PAGE 256 C INTEGER I C INDEX VARIABLE C REAL IBAR C I BAR, ((SUM OF I)/NZW), WHERE I=1,NZW C INTEGER INDEX(N) C PERMUTATION VECTOR FOR Y AND LATER FOR TMEAN C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C CHARACTER*1 ISD C CAN CONTAIN FOLLOWING CHARACTERS FOR PRINTING C +, -, (BLANK) C INTEGER ISZ C INTEGER SIZE OF GROUP C INTEGER ITEMP(NZW) C TEMPORARY INDEX VECTOR USED IN COMPUTING RANKS C INTEGER J C AN INDEX VARIABLE C INTEGER K C INDEX VARIABLE C INTEGER KK C POINTER TO THE LARGEST OF THE GROUP MEANS C INTEGER KKK C POINTER TO THE SMALLEST OF THE GROUP MEANS C REAL K0 C = NZW - (SNC/NZW)/ G1 C INTEGER L C INDEX VARIABLE C CHARACTER*1 LOW C HOLLERITH - (MINUS) C INTEGER M C INDEX VARIABLE C CHARACTER*1 MEAN C CAN CONTAIN FOLLOWING CHARACTERS FOR PRINTING C +, -, (BLANK) C REAL MF C M FOR F C REAL MKW C M FOR KRUSKAL-WALLIS MEAN C INTEGER M28 C USED IN CREATING BACKWARD LOOP C INTEGER M3 C NG - 2 C INTEGER M5 C NZW - 1 C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NG C THE NUMBER OF GROUPS OF DIFFERENT POSITIVE TAG VALUES C INTEGER NN C AID IN PRINTING VALUES C INTEGER NNE1 C NUMBER OF GROUPS WITH SIZE NOT EQUAL TO ONE C INTEGER NPRT C THE VARAIBLE CONTROLLING AUTOMATIC PRINTOUT C IF NPRT = 0, PRINTOUT SUPPRESSED C OTHERWISE PRINTOUT PROVIDED C INTEGER NZPNTR C A POINTER TO THE FIRST NON-ZERO TAG IN THE SORTED TAG VECTOR C INTEGER NZW C THE NUMBER OF OBSERVATIONS WITH POSITIVE, NON-ZERO, TAG VALUES C REAL Q C SIGNIFICANCE LEVEL FROM F-DISTRIBUTION C REAL RANKS(NZW) C THE RANKS OF THE OBSERVATIONS WITH POSITIVE TAG VALUES C REAL RESSQ C RESIDUALS SQUARED C REAL RMLC C RANDOM MODEL LOWER CONFIDENCE LIMIT FOR MEAN C REAL RMUC C RANDOM MODEL UPPER CONFIDENCE LIMIT FOR MEAN C REAL RX C USED IN CALCULATING MANDEL APPROXIMATION C REAL SBMS C SQRT BETWEEN MS C REAL SC C SUM OF N(I) CUBED, WHERE N(I) IS THE SIZE OF GROUP I C REAL SFRAT C SLOPE F RATIO C REAL SFSIG C SLOPE F SIGNIFICANCE LEVEL C REAL SIGKW C SIGNIFICANCE LEVEL FOR KRUSKAL-WALLIS F (OR H) C REAL SLBF C SIGNIFICANCE LEVEL FOR BARLETT F C REAL SLCC C SIGNIFICANCE LEVEL FOR COCHRANS C C REAL SMAX C MAXIMUM OF S(I), WHERE S(I) IS THE STD. DEV. OF GROUP I C REAL SMIN C MINIMUM OF S(I) C REAL SMS C SLOPE MS C REAL SNC C SUM OF N(I) SQUARED C REAL SOS C SUM OF S(I) SQUARED C REAL SQB C SQRT BETWEEN MS / NZW C REAL SQMS C SQRT WITHIN MS / NZW C REAL SQOM C OMEGA HAT SQUARED C REAL SQT C SQRT TOTAL MS / NZW C REAL SRANK(NG) C THE SUM OF THE RANKS FOR THE OBSERVATIONS IN EACH GROUP C REAL SSF C S * SQRT(NG-1) * F C REAL SSS C SLOPE SS C REAL STATS(15) C VECTOR OF STATISTICS C REAL STMS C SQRT TOTAL MS C REAL SUM C INTERMIDIATE VALUE C REAL SWMS C SQRT WITHIN MS C REAL TAG(N) C VECTOR OF CLASSIFICATION VALUES - VALUES LESS THAN OR EQUAL C TO ZERO ARE IGNORED FOR ANALYSIS. ON ENTERING TAG IS C SORTED SMALLEST TO LARGEST C REAL TIES C * C REAL TMEAN(NG) C THE MEAN OF EACH OF THE GROUPS C REAL TMS C TOTAL MS C REAL TSD(NG) C THE STANDARD DEVIATIONS OF EACH OF THE GROUPS (NOT THE C STANDARD DEVIATIONS OF THE MEANS) C REAL TSIZE(NG) C THE SIZE OF EACH OF THE DIFFERENT GROUPS C REAL TSS C TOTAL SS C REAL TVALUE(NG) C THE DIFFERENT POSITIVE (NON-ZERO) TAG VALUES ANALYZED, ORDERED C FROM SMALLEST TO LARGEST C REAL T1 C T(.05,NG-1) C REAL T2 C T(.05,NG-1) C REAL T3 C T(.05,NZW-1) C REAL UMLC C UNGROUPED MODEL LOWER CONFIDENCE LIMIT FOR MEAN C REAL UMUC C UNGROUPED MODEL UPPER CONFIDENCE LIMIT FOR MEAN C REAL U1, U2 C USED IN CALCULATING MANDEL APPROXIMATION C REAL VKW C U FOR KRUSKAL-WALLIS F C REAL VLS C LARGEST VARIANCE / SMALLEST VARIANCE C REAL V1, V2 C USED IN CALCULATING MANDEL APPROXIMATION C REAL WMS C WITHIN MS C REAL WSS C WITHIN SS C REAL Y(N) C OBSERVATIONS TO BE ANALYZED, SORTED BY TAGS C Y(NZPNTR) IS THE FIRST ELEMENT WITH A NON-ZERO TAG C REAL YBMAX C MAXIMUM YBAR(I), WHERE YBAR(I) IS THE MEAN OF GROUP I C REAL YBMIN C MINIMUN YBAR(I) C REAL YMAX C MAXIMUM OBSERVATION C REAL YMIN C MINIMUM OBSERVATION C C MACHINE DEPENDENT VARIABLE - FPLM C DATA BLANK /' '/ DATA LOW /'-'/ DATA HIGH /'+'/ C CALL IPRINT(IPRT) FPLM = R1MACH(2) NZPNTR = N - NZW + 1 FNZW = NZW C C ZERO WORK VECTORS C DO 10 I=1,NG TVALUE(I) = 0.0E0 TSIZE(I) = 0.0E0 TMEAN(I) = 0.0E0 TSD(I) = 0.0E0 SRANK(I) = 0.0E0 GPMIN(I) = 0.0E0 GPMAX(I) = 0.0E0 B10(I) = 0.0E0 10 CONTINUE C DO 20 I=1,15 STATS(I) = 0.0E0 20 CONTINUE C CC = 0.0E0 F = 0.0E0 DMS = 0.0E0 BSS = 0.0E0 WSS = 0.0E0 HSTAT = 0.0E0 MF = 0.0E0 SC = 0.0E0 SMAX = 0.0E0 NNE1 = 0 SNC = 0.0E0 SOS = 0.0E0 SSS = 0.0E0 SUM = 0.0E0 TIES = 0.0E0 TSS = 0.0E0 SMIN = 0.0E0 SFRAT = 0.0E0 C C BEGIN COMPUTATIONS C C COMPUTE RANKS C CALL RANKO(NZW, Y(NZPNTR), ITEMP, RANKS, TIES) C C INITIALIZE FIRST ELEMENT BEFORE ENTERING LOOP C TVALUE(1) = TAG(NZPNTR) SRANK(1) = RANKS(1) GPMIN(1) = Y(NZPNTR) GPMAX(1) = Y(NZPNTR) YMIN = GPMIN(1) YMAX = GPMAX(1) GM = Y(NZPNTR) IBAR = 1.0E0 TMEAN(1) = Y(NZPNTR) TSIZE(1) = 1.0E0 C C DETERMINE MEANS AND MAXS, DO SUMMATION PRIOR TO C DETERIMING MEANS C HERE J IS THE GROUP NUMBER C J = 1 L = NZPNTR + 1 DO 50 I=L,N IF (TAG(I).EQ.TAG(I-1)) GO TO 40 C C NEW TAG GROUP J = J + 1 TVALUE(J) = TAG(I) GPMIN(J) = Y(I) GPMAX(J) = Y(I) 40 TSIZE(J) = TSIZE(J) + 1.0E0 TMEAN(J) = TMEAN(J) + Y(I) GM = GM + Y(I) C C UNNECESSARY COMPUTATIONS IF PRINTED OUTPUT IS SUPRESSED C IF (NPRT.EQ.0) GO TO 50 K = I + 1 - NZPNTR SRANK(J) = SRANK(J) + RANKS(K) GPMIN(J) = MIN(GPMIN(J),Y(I)) GPMAX(J) = MAX(GPMAX(J),Y(I)) YMIN = MIN(YMIN,GPMIN(J)) YMAX = MAX(YMAX,GPMAX(J)) IBAR = IBAR + J 50 CONTINUE C C CALCULATE MEANS C GM = GM/FNZW IBAR = IBAR/FNZW K = NZPNTR-1 I = NZPNTR DO 70 J=1,NG IF (TSIZE(J).GE.2.0E0) THEN TMEAN(J) = TMEAN(J)/TSIZE(J) ELSE TMEAN(J) = TMEAN(J) END IF K = K + INT(TSIZE(J)) C C L GIVES INDEX TO Y VALUE WITHIN GROUP J C DO 60 L=I,K RESSQ = (Y(L)-TMEAN(J))*(Y(L)-TMEAN(J)) TSD(J) = TSD(J) + RESSQ IF (NPRT.EQ.0) GO TO 60 BSS = BSS + (TMEAN(J)-GM)*(TMEAN(J)-GM) WSS = WSS + RESSQ TSS = TSS + (Y(L)-GM)*(Y(L)-GM) 60 CONTINUE I = K + 1 70 CONTINUE C C NOW DONE WITH TAG VECTOR, RETURN VECTOR TO INPUT ORDER C INDEX IS FREED FOR USE IN OTHER PLACES C CALL SRTRRI(TAG, Y, N, INDEX) C C CHECK FOR PRINTED OUTPUT C IF (NPRT.NE.0) GO TO 90 C C COMPUTE STANDARD DEVIATIONS WITHIN EACH GROUP C DO 80 J=1,NG TSD(J) = SQRT(TSD(J)) IF (TSIZE(J).LE.1.0E0) GO TO 80 TSD(J) = TSD(J)/SQRT(TSIZE(J)-1.0E0) 80 CONTINUE C C COMPUTATIONS COMPLETE FOR STORED OUTPUT - RETURN IF PRINTED C OUTPUT IS SUPRESSED C RETURN 90 YBMIN = TMEAN(1) YBMAX = TMEAN(1) SMIN = FPLM C HERE I IS THE GROUP NUMBER DO 120 I=1,NG IF (TSD(I).GT.0.0E0) THEN B10(I) = TSIZE(I)*(TSIZE(I)-1.0E0)/TSD(I) STATS(1) = STATS(1) + B10(I)*TMEAN(I) STATS(2) = STATS(2) + B10(I) IF (TSIZE(I).GT.1.0E0) THEN TSD(I) = SQRT(TSD(I)/(TSIZE(I)-1.0E0)) END IF MF = MF + (TSIZE(I)-1.0E0)*LOG(TSD(I)*TSD(I)) END IF IF (NINT(TSIZE(I)).GE.2) THEN NNE1 = NNE1 + 1 SMAX = MAX(SMAX,TSD(I)) SMIN = MIN(SMIN,TSD(I)) STATS(3) = STATS(3) + 1.0E0/(TSIZE(I)-1.0E0) END IF SSS = SSS + TSIZE(I)*(I-IBAR)*(TMEAN(I)-GM) STATS(4) = STATS(4) + TSIZE(I)*(I-IBAR)*(I-IBAR) C C LOOK FOR SMALLEST AND LARGEST MEANS (YBAR) C YBMIN = MIN(YBMIN,TMEAN(I)) YBMAX = MAX(YBMAX,TMEAN(I)) C HSTAT = HSTAT + SRANK(I)*SRANK(I)/TSIZE(I) SUM = SUM + 1.0E0/TSIZE(I) STATS(5) = STATS(5) + (TMEAN(I)-GM)*(TMEAN(I)-GM) SOS = SOS + TSD(I)*TSD(I) SNC = SNC + TSIZE(I)*TSIZE(I) SC = SC + TSIZE(I)*TSIZE(I)*TSIZE(I) 120 CONTINUE IF (STATS(2).NE.0.0E0) STATS(1) = STATS(1)/STATS(2) IF (STATS(4).NE.0.0E0) SSS = SSS*SSS/STATS(4) DSS = BSS - SSS C C DEGREES OF FREEDOM FOR ANOVA C G1 = NG-1 M3 = NG - 2 GR = NZW-NG M5 = NZW - 1 C C MEAN SQUARES C BMS = BSS/G1 SMS = SSS IF (NG.GE.3) DMS = DSS/M3 WMS = WSS/GR TMS = TSS/M5 IF (WMS.EQ.BMS) THEN BFRAT = 1.0E0 BFSIG = 1.0E0 ELSE IF (WMS.EQ.0.0E0) THEN BFRAT = FPLM BFSIG = 0.0E0 ELSE BFRAT = BMS/WMS BFSIG = 1.0E0 - CDFF(BFRAT,G1,GR) END IF IF (WMS.EQ.DMS) THEN DFRAT = 1.0E0 DFSIG = 1.0E0 ELSE IF (WMS.EQ.0.0E0) THEN DFRAT = FPLM DFSIG = 0.0E0 ELSE DFRAT = DMS/WMS DFSIG = 1.0E0 - CDFF(DFRAT,REAL(M3),REAL(NZW-2)) END IF IF (SMS.EQ.DSS+WSS) THEN SFRAT = 1.0E0 SFSIG = 1.0E0 ELSE IF (DSS+WSS.EQ.0.0E0) THEN SFRAT = FPLM SFSIG = 0.0E0 ELSE SFRAT = SMS/((DSS+WSS)/(FNZW-2.0E0)) SFSIG = 1.0E0 - CDFF(SFRAT,1.0E0,GR) END IF C C COMPUTE FOR KRUSKAL-WALLIS TEST C FOR FORMULAE WITH CLEARER FORM AND NAMES SEE C KRAFT AND VAN EEDEN A NON PARAMETRIC INTRODUCTION TO STATISTICS, C PP. 238 - 240 C STATS(6) = NZW*(NZW+1) HSTAT = (12.0E0*HSTAT/STATS(6)) - (3.0E0*(NZW+1)) IF (TIES.EQ.NZW*NZW*NZW-NZW) THEN CFKW = 0.0E0 HSTAT = 0.0E0 MKW = 0.0E0 ELSE CFKW = 1.0E0 - TIES/(NZW*NZW*NZW-NZW) HSTAT = HSTAT/CFKW MKW = ((NZW*NZW*NZW-SC)/STATS(6))/CFKW END IF VKW = 2.0E0*G1 - + (0.4E0*(3*NG*M3+NZW*(2*NG*(NG-3)+1)))/STATS(6) + - 6.0E0*SUM/5.0E0 IF (MKW-HSTAT.GT.0.0E0 .AND. + MKW.NE.0.0E0 .AND. VKW.NE.0.0E0) THEN F1KW = (G1*(G1*(MKW-G1)-VKW))/(0.5E0*VKW*MKW) F2KW = (MKW-G1)*F1KW/G1 FSTAT = (HSTAT*(MKW-G1))/(G1*(MKW-HSTAT)) SIGKW = 1.0E0 - CDFF(FSTAT,ANINT(F1KW),ANINT(F2KW)) ELSE SIGKW = 0.0E0 END IF C C COMPUTE TOTAL STATISTICS C SWMS = SQRT(WMS) SBMS = SQRT(STATS(5)/G1) STMS = SQRT(TMS) SQMS = SWMS/(SQRT(FNZW)) SQB = SBMS/(SQRT(REAL(NG))) SQT = STMS/(SQRT(FNZW)) T1 = PPFT(0.975E0,INT(GR)) T2 = PPFT(0.975E0,INT(G1)) T3 = PPFT(0.975E0,M5) FMLC = GM - SQMS*T1 RMLC = GM - SQB*T2 UMLC = GM - SQT*T3 FMUC = GM + SQMS*T1 RMUC = GM + SQB*T2 UMUC = GM + SQT*T3 C SSF = SWMS*SQRT(G1*PPFF(0.95E0,INT(G1),INT(GR))) C C TESTS FOR HOMOGENEITY OF VARIANCES C IF (SMAX*SMAX.EQ.SOS) THEN CC = 1.0E0 ELSE IF (SOS.NE.0.0E0) THEN CC = SMAX*SMAX/SOS END IF STATS(7) = ANINT(FNZW/NG) IF ((NNE1.GE.2) .AND. (CC.NE.1.0E0)) THEN SLCC = 1.0E0 - + CDFF((NNE1-1)*CC/(1.0E0-CC),STATS(7), + STATS(7)*(NNE1-1)) ELSE SLCC = 1.0E0 END IF SLCC = (NNE1-1)*SLCC IF (SLCC.GT.1.0E0) SLCC = 1.0E0 C IF (SMIN.EQ.SMAX) THEN VLS = 1.0E0 ELSE IF (SMIN.EQ.0.0E0) THEN VLS = FPLM ELSE VLS = (SMAX/SMIN)*(SMAX/SMIN) END IF END IF IF (WMS.GT.0.0E0) MF = GR*LOG(WMS) - MF AF = (STATS(3)-(1.0E0/GR))/(3.0E0*G1) SLBF = 1.0E0 IF ((AF.NE.1.0E0) .AND. (NNE1.GE.2)) THEN DF = (NNE1+1)/(AF*AF) BF = (DF*MF)/((NNE1-1)*(DF/(1.0E0-AF+(2.0E0/DF))-MF)) IF (BF.LT.0.0E0) BF = 0.0E0 SLBF = 1.0E0 - CDFF(BF,REAL(NNE1-1),ANINT(DF)) ELSE BF = FPLM END IF K0 = (FNZW-(SNC/FNZW))/G1 SQOM = (BMS-WMS)/K0 C C COMPUTATIONS ARE NOW COMPLETE ************************************ C C PRINT ANOVA C NN = N - NZW WRITE (IPRT,1000) NN NN = NG - 1 WRITE (IPRT,1010) NN, BSS, BMS, BFRAT, BFSIG IF (NG.LT.3) GO TO 180 IF (BFSIG.GE..10) GO TO 180 NN = 1 WRITE (IPRT,1020) NN, SSS, SMS, SFRAT, SFSIG WRITE (IPRT,1030) M3, DSS, DMS, DFRAT, DFSIG 180 NN = NZW - NG WRITE (IPRT,1040) NN, WSS, WMS WRITE (IPRT,1050) M5, TSS C C PRINT KRUSKAL-WALLIS TEST C WRITE (IPRT,1060) HSTAT, SIGKW C C PRINT ESTIMATES C WRITE (IPRT,1070) DO 200 I=1,NG MEAN = BLANK IF (TMEAN(I).LE.YBMIN) MEAN = LOW IF (TMEAN(I).GE.YBMAX) MEAN = HIGH ISD = BLANK IF (TSD(I).LE.SMIN) ISD = LOW IF (TSD(I).GE.SMAX) ISD = HIGH ISZ = INT(TSIZE(I)) IF (ISZ.LE.1) THEN WRITE (IPRT,1090) TVALUE(I), ISZ, TMEAN(I), MEAN, GPMIN(I), + GPMAX(I), SRANK(I) ELSE STATS(9) = TSD(I)/SQRT(TSIZE(I)) STATS(10) = PPFT(0.975E0,ISZ-1) STATS(8) = TMEAN(I) - STATS(9)*STATS(10) STATS(11) = TMEAN(I) + STATS(9)*STATS(10) WRITE (IPRT,1080) TVALUE(I), ISZ, TMEAN(I), MEAN, TSD(I), + ISD, STATS(9), GPMIN(I), GPMAX(I), + SRANK(I), STATS(8), STATS(11) END IF 200 CONTINUE WRITE (IPRT,1100) NZW, GM, YMIN, YMAX, SWMS, SQMS, FMLC, FMUC, + SBMS, SQB, RMLC, RMUC, STMS, SQT, UMLC, UMUC IF (BFSIG.LT.0.10) THEN C C SORT YBAR FOR MULTIPLE COMPARISIONS OF MEANS C CALL GENI(INDEX, NG, 1, 1) CALL SRTIR(INDEX, NG, TMEAN) C C COMPUTE AND PRINT FOR MULTIPLE COMPARISIONS C IF (NZW-NG.LT.4) GO TO 270 WRITE (IPRT,1110) C C NEWMAN-KEULS-HARTLEY C WRITE (IPRT,1120) RX = -.283917E0 + 2.63532E0*(GR-1.00123E0)**(-.95862E0) U1 = -.314115E0 + 2.38301E0*(GR-1.03428E0)**(-.864005E0) U2 = 3.65961E0*U1**2 - 1.00891E0*U1 - 0.166346E0 J = 1 M28 = 0 210 I = NG 220 IF (I.LE.M28) GO TO 260 IF (I.EQ.J) GO TO 230 STATS(14) = ABS(TMEAN(I)-TMEAN(J)) C C MANDEL APPROXMATION TO PERCENT POINT OF STUDENTIZED RANGE C STATS(12) = I-J+1 C = 2.3849867E0 - + 2.9051857E0*(STATS(12)-0.57583164E0)**(-.069648109E0) V1 = 1.30153E0 - + 1.95073E0*(STATS(12)+.394915E0)**(-.139783E0) V2 = 4.72863E0*V1**2 + 0.404271E0*V1 - 0.135104E0 STATS(13) = 6.15075E0 + 4.441409E0*RX + + 6.7514569E0*C + 7.4671282E0*U1*V1 - + 0.157537E0*U2*V2 KK = INDEX(I) KKK = INDEX(J) STATS(13) = STATS(13)* + SQRT(0.5E0*((1.0E0/TSIZE(KK))+(1.0E0/TSIZE(KKK))))* + SWMS IF (STATS(14).LE.STATS(13)) GO TO 230 I = I - 1 GO TO 220 230 IF (J.EQ.1) GO TO 250 IF (J.GT.M28) GO TO 240 WRITE (IPRT,1150) GO TO 250 240 WRITE (IPRT,1160) 250 WRITE (IPRT,1140) (TMEAN(M),M=J,I) IF (I.GE.NG) GO TO 270 M28 = I 260 J = J + 1 GO TO 210 C C SCHEFFE METHOD C 270 WRITE (IPRT,1130) J = 1 M28 = 0 280 I = NG 290 IF (I.LE.M28) GO TO 330 IF (I.EQ.J) GO TO 300 KK = INDEX(I) KKK = INDEX(J) STATS(14) = ABS(TMEAN(I)-TMEAN(J)) STATS(13) = SSF*SQRT((1.0E0/TSIZE(KK))+(1./TSIZE(KKK))) IF (STATS(14)-STATS(13).LE.0.0E0) GO TO 300 I = I - 1 GO TO 290 300 IF (J.EQ.1) GO TO 320 IF (J.GT.M28) GO TO 310 WRITE (IPRT,1150) GO TO 320 310 WRITE (IPRT,1160) 320 WRITE (IPRT,1140) (TMEAN(M),M=J,I) IF (I.GE.NG) GO TO 340 M28 = I 330 J = J + 1 GO TO 280 C C RETURN TAG MEANS TO ORIGINAL ORDER C 340 CALL SRTRI(TMEAN, NG, INDEX) END IF C IF (NNE1.LE.1) RETURN WRITE (IPRT,1170) CC, SLCC, BF, SLBF, VLS IF (SLCC.GT.0.1E0 .AND. SLBF.GT.0.1E0) GO TO 390 DO 360 I=1,NG F = F + B10(I)*(TMEAN(I)-STATS(1))*(TMEAN(I)-STATS(1)) IF (STATS(2).EQ.0.0E0 .OR. TSIZE(I).LE.1.0E0) GO TO 360 STATS(15) = STATS(15) + + (1.0E0-B10(I)*B10(I)/STATS(2)/STATS(2))/ + (TSIZE(I)-1.0E0) 360 CONTINUE IF (STATS(15).EQ.0.0E0) GO TO 370 STATS(15) = (NG*NG-1.0E0)/(3.0E0*STATS(15)) IF (NG.LE.1) GO TO 370 F = (F/G1)/(1.0E0+(2.0E0*M3/(3.0E0*STATS(15)))) GO TO 380 370 F = 0.0E0 380 Q = 1.0E0 - CDFF(F,G1,ANINT(STATS(15))) WRITE (IPRT,1180) F, Q 390 WRITE (IPRT,1190) SQOM RETURN C C AUTOMATIC PRINTOUT IS FINISHED C C FORMAT STATEMENTS C 1000 FORMAT(54H *GROUP NUMBERS HAVE BEEN ASSIGNED ACCORDING TO TAG VA, + 59HLUES GIVEN, WHERE THE SMALLEST TAG GREATER THAN ZERO HAS BE, + 14HEN ASSIGNED */41H *GROUP NUMBER 1, THE NEXT SMALLEST, GROU, + 59HP NUMBER 2, ETC. TAGS LESS THAN OR EQUAL TO ZERO HAVE NOT , + 27HBEEN INCLUDED IN ANALYSIS.*/28H *NUMBER OF VALUES EXCLUDED , + 17HFROM ANALYSIS IS , I4, 77X, 1H*//17X, 6HSOURCE, 14X, 4HD.F., + 4X, 14HSUM OF SQUARES, 5X, 12HMEAN SQUARES, 9X, 7HF RATIO, 4X, + 7HF PROB./) 1010 FORMAT(17X, 14HBETWEEN GROUPS, 5X, I4, 1P2E18.6, 4X, 0PE11.3, + F10.3) 1020 FORMAT(20X, 5HSLOPE, 14X, I4, 1P2E18.6, 3X, 0PE11.3, F10.3) 1030 FORMAT(20X, 16HDEVS. ABOUT LINE, 3X, I4, 1P2E18.6, 3X, 0PE11.3, + F10.3) 1040 FORMAT(17X, 13HWITHIN GROUPS, 6X, I4, 1P2E18.6) 1050 FORMAT(17X, 5HTOTAL, 14X, I4, 1PE18.6//) 1060 FORMAT(11X, 49HKRUSKAL-WALLIS RANK TEST FOR DIFFERENCE BETWEEN G, + 16HROUP MEANS * H =, E11.3, 10H, F PROB =, F6.3, 10H (APPROX.) + /) 1070 FORMAT(55X, 9HESTIMATES/96X, 6HSUM OF/5X, 5H TAG , 10X, 3HNO., + 6X, 4HMEAN, 7X, 11HWITHIN S.D., 2X, 12HS.D. OF MEAN, 5X, + 7HMINIMUM, 7X, 7HMAXIMUM, 6X, 5HRANKS, 3X, 16H95PCT CONF INT F, + 7HOR MEAN/) 1080 FORMAT(1X, 1PE14.6, I8, E14.5, A1, E13.5, A1, E13.5, 2E14.5, + 0PF9.1, 1PE13.5, 3H TO, E12.5) 1090 FORMAT(1X, 1PE14.6, I8, E14.5, A1, 3X, 23H ESTIMATE NOT AVAILABLE, + ' ', 2E14.5, 0PF9.1, 3X, 25H********** TO ********** ) 1100 FORMAT(/11X, 5HTOTAL, I7, 1PE14.5, 28X, 2E14.5// + 17X, 20HFIXED EFFECTS MODEL , 2E14.5, 37X, E13.5, 3H TO, E12.5/ + 17X, 7HRANDOM , + 13HEFFECTS MODEL, 2E14.5, 37X, E13.5, 3H TO, E12.5/17X, + 14HUNGROUPED DATA, 6X, 2E14.5, 37X, E13.5, 3H TO, E12.5/) 1110 FORMAT(1X, 50HPAIRWISE MULTIPLE COMPARISON OF MEANS. THE MEANS , + 59HARE PUT IN INCREASING ORDER IN GROUPS SEPARATED BY *****. , + 11HA MEAN IS /44H ADJUDGED NON-SIGNIFICANTLY DIFFERENT FROM A, + 59HNY MEAN IN THE SAME GROUP AND SIGNIFICANTLY DIFFERENT AT TH, + 17HE .05 LEVEL FROM /38H ANY MEAN IN ANOTHER GROUP. ***** ***, + 59H** INDICATES ADJACENT GROUPS HAVE NO COMMON MEAN. , + 23H ) 1120 FORMAT(/3X, 49HNEWMAN-KEULS TECHNIQUE, HARTLEY MODIFICATION. (AP, + 40HPROXIMATE IF GROUP NUMBERS ARE UNEQUAL.)) 1130 FORMAT(/3X, 18HSCHEFFE TECHNIQUE.) 1140 FORMAT(3X, 9(1PE12.5, ',')) 1150 FORMAT(6X, 5H*****) 1160 FORMAT(3X, 11H***** *****) 1170 FORMAT(/36H TESTS FOR HOMOGENEITY OF VARIANCES./7X, 9HCOCHRANS , + 35HC = MAX. VARIANCE/SUM(VARIANCES) = , F7.4, 6H, P = , F6.3, + 10H (APPROX.)/7X, 17HBARTLETT-BOX F = , F9.3, 6H, P = , + F6.3/7X, 38HMAXIMUM VARIANCE / MINIMUM VARIANCE = , F14.4) 1180 FORMAT(7X, 50HAPPROX BETWEEN MEANS F-TEST IN PRESENCE OF HETEROG, + 20HENEOUS VARIANCE. F =, F8.3, 5H, P =, F6.3) 1190 FORMAT(/35H MODEL II - COMPONENTS OF VARIANCE./7X, 10HESTIMATE O, + 20HF BETWEEN COMPONENT , 1PE14.6) END *AOV1S SUBROUTINE AOV1S(Y, TAG, N, LDSTAK, NPRT, GSTAT, IGSTAT, NG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE - C 1. CALLS OTHER ROUTINES TO CHECK THE INPUT PARAMETERS C 2. SETS UP NEEDED STORAGE LOCATIONS AND C 3. CALLS AOV1MN TO COMPUTE A COMPREHENSIVE SET OF RESULTS FOR A C ONEWAY ANALYSIS OF VARIANCE WITH OPTIONAL OUTPUT. C C WRITTEN BY - C LINDA MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C BASED ON EARLIER VERSION BY J. R. DONALDSON C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IGSTAT,LDSTAK,N,NG,NPRT C C ARRAY ARGUMENTS REAL + GSTAT(*),TAG(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + B10,GPMAX,GPMIN,IFP,INDEX,INT,IPRT,ITEMP,NALL0,NZTAGS, + RANKS,SRANK C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET EXTERNAL STKGET C C EXTERNAL SUBROUTINES EXTERNAL AOV1ER,AOV1HD,AOV1MN,IPRINT,STKCLR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER B10 C STARTING LOCATION IN THE STACK AREA FOR B10 C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER GPMAX C THE STARTING LOCATION IN THE STACK AREA OF MAXIMUM C OBSERVATION C INTEGER GPMIN C THE STARTING LOCATION IN THE STACK AREA OF THE MINUMUM C OBSERVATION C REAL GSTAT(IGSTAT,4) C THE GROUP STATISTICS. COLUMNS CORRESPOND TO THE TAG C VALUE, SAMPLE SIZE, GROUP MEAN, AND GROUP STANDARD DEVIATION. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG INDICATING WHETHER THERE C ARE ANY ERRORS, IF = 0 THEN NO ERRORS C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IGSTAT C THE FIRST DIMENSION OF GSTAT. C INTEGER INDEX C THE STARTING LOCATION IN THE STACK ARRAY OF THE INDEX FOR C THE SORTED TAGS C INTEGER INT C FRAMEWORK CODE VALUE FOR INTEGER NUMBERS C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ITEMP C STARTING LOCATION IN THE STACK FOR THE C TEMPORARY STORAGE ARRAY C INTEGER LDSTAK C SIZE OF THE STACK AREA ALLOCATED IN THE USERS MAIN PROGRAM C INTEGER N C THE NUMBER OF OBSERVATIONS TO BE ANALYZED C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT THIS C ROUTINE WAS CALLED. C INTEGER NG C THE COMPUTED NUMBER OF GROUPS WITH C DIFFERENT POSITIVE TAG VALUES C CHARACTER*1 NMSUB(6) C SUBROUTINE NAME C INTEGER NPRT C THE VARIABLE CONTROLLING AUTOMATIC PRINTOUT C IF =0, PRINTOUT IS SUPRESSED C OTHERWISE PRINTOUT IS PROVIDED C INTEGER NZTAGS C THE NUMBER OF OBSERVATIONS WITH POSITIVE NON-ZERO WIEGHTS C INTEGER RANKS C THE STARTING LOCATION IN STACK AREA FOR THE RANKS OF Y C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SRANK C THE STARTING LOCATION IN STACK FOR THE SUM OF RANKS C REAL TAG(N) C THE VECTOR OF TAG VALUES C REAL Y(N) C THE VECTOR OF OBSERVATIONS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'O', 'V', '1', 'S', ' '/ C C SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES C INT = 2 IFP = 3 C CALL IPRINT(IPRT) C C CHECK FOR ERRORS IN PARAMETERS, INITIALIZE STACK, AND SET C NALL0. C CALL AOV1ER(Y, TAG, N, IGSTAT, NZTAGS, NG, LDSTAK, NMSUB, INDEX, + 0, NALL0) C IF (IERR.EQ.0) GO TO 20 C C PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER C IERR = 1 WRITE (IPRT,1000) RETURN C C PRINT HEADING IF DESIRED C 20 IF (NPRT.EQ.0) GO TO 30 CALL AOV1HD(IPRT) C C SET UP ADDITIONAL WORK VECTORS FOR AOV1MN AS CALLED FROM AOV1S C 30 SRANK = STKGET(NG,IFP) GPMIN = STKGET(NG,IFP) GPMAX = STKGET(NG,IFP) B10 = STKGET(NG,IFP) RANKS = STKGET(NZTAGS,IFP) ITEMP = STKGET(NZTAGS,INT) C CALL AOV1MN(Y, TAG, N, + GSTAT(1), GSTAT(IGSTAT+1), + GSTAT(2*IGSTAT+1), GSTAT(3*IGSTAT+1), + NPRT, ISTAK(INDEX), RSTAK(SRANK), RSTAK(GPMIN), + RSTAK(GPMAX), RSTAK(B10), RSTAK(RANKS), + ISTAK(ITEMP), NG, NZTAGS) C C RELEASE THE STACK AREA C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL AOV1S (Y, TAG, N, LDSTAK, NPRT, GSTAT, IGSTAT, NG)') END *AOV1XP SUBROUTINE AOV1XP(GSTAT, IGSTAT, NG) C C LATEST REVISION - 03/15/90 (JRD) C C PRINT STORAGE FOR ONEWAY FAMILY EXERCISER C AND CLEAR STORAGE VECTORS C C WRITTEN BY - C LINDA MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IGSTAT,NG C C ARRAY ARGUMENTS REAL + GSTAT(IGSTAT,4) C C LOCAL SCALARS INTEGER + I,IPRT,J C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,SETRA C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL GSTAT(IGSTAT,4) C THE GROUP STATISTICS. COLUMNS CORRESPOND TO THE TAG C VALUE, SAMPLE SIZE, GROUP MEAN, AND GROUP STANDARD DEVIATION. C INTEGER I C AN INDEX VALUE C INTEGER IGSTAT C THE FIRST DIMENSION OF GSTAT. C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C INTEGER J, NG C * C C COMMENCE BODY OF ROUTINE C CALL IPRINT(IPRT) WRITE (IPRT,1000) WRITE (IPRT,1010) ((GSTAT(I,J),J=1,4),I=1,NG) CALL SETRA(GSTAT, IGSTAT, 4, NG, 0.0E0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(//21H STORAGE FROM AOV1 //6X, 8HTAGVALUE, + 11X, 10H GROUPSIZE, 11X, 10H GROUPMEAN, 13X, 8H GROUPSD/) 1010 FORMAT(4(1X, G20.14)) END *ARCOEF SUBROUTINE ARCOEF (ACOV, PHI, RSS, LAG, LAGMAX, ACOV0) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE USES DURBINS RECURSIVE METHOD TO COMPUTE C THE AUTOREGRESSIVE COEFFICIENTS OF AN ORDER LAG PROCESS, C GIVEN ON INPUT THE COEFFICIENTS OF AN ORDER (LAG-1) PROCESS. 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 REAL + ACOV0,RSS INTEGER + LAG,LAGMAX C C ARRAY ARGUMENTS REAL + ACOV(*),PHI(*) C C LOCAL SCALARS REAL + SUM1,SUM2,T INTEGER + J,L1,L2,LJ C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX) C THE ARRAY OF ACVF ESTIMATES FOR LAGS ONE TO LAGMAX. C REAL ACOV0 C THE ACVF FOR LAG ZERO. C INTEGER J, LAG C INDEX VARIABLES. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE USED. C INTEGER LJ, L2 C INDEX VARIABLES. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR AN AR C PROCESS OF ORDER LAG. C REAL RSS C THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES. C REAL SUM1, SUM2 C VARIABLES USED IN THE COMPUTATIONS OF THE AUTOREGRESSIVE C COEFFICIENTS. C REAL T C A TEMPORARY STORAGE LOCATION. C L1 = LAG - 1 SUM1 = 0.0E0 SUM2 = 0.0E0 DO 10 J = 1, L1 LJ = LAG - J SUM1 = SUM1 + PHI(J) * ACOV(LJ) SUM2 = SUM2 + PHI(J) * ACOV(J) 10 CONTINUE PHI(LAG) = (ACOV(LAG) - SUM1) / (ACOV0 - SUM2) L2 = LAG / 2 DO 20 J = 1, L2 LJ = LAG - J T = PHI(J) - PHI(LAG) * PHI(LJ) PHI(LJ) = PHI(LJ) - PHI(LAG) * PHI(J) PHI(J) = T 20 CONTINUE C RSS = RSS * (1.0E0 - PHI(LAG)*PHI(LAG)) C RETURN END *ARFLT SUBROUTINE ARFLT (Y, N, IAR, PHI, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS THE AUTOREGRESSIVE FILTERING C OPERATION DEFINED BY PHI, RETURNING THE FILTERED SERIES C IN YF. 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 + IAR,N,NYF C C ARRAY ARGUMENTS REAL + PHI(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + YMEAN INTEGER + I,IPRT LOGICAL + ERR01,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,EISGE,FLTAR,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 CHARACTER*1 LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. 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 REAL PHI(IAR) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C REAL YMEAN C THE MEAN OF THE INPUT SERIES Y. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'A', 'R', 'F', 'L', 'T', ' '/ 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 C IF (.NOT. ERR01) GO TO 10 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C COMPUTE ARITHMETIC MEAN C CALL AMEAN(Y, N, YMEAN) C DO 20 I = 1, N YF(I) = Y(I) - YMEAN 20 CONTINUE C CALL FLTAR (YF, N, IAR, PHI, YF, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 43H CALL ARFLT (Y, N, IAR, PHI, YF, NYF)) 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 REAL + D(P),STEP(P),STLSTG(P),V(*),X(P),X0(P) INTEGER + IV(*) C C LOCAL SCALARS REAL + 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 REAL + R1MACH,RELDST EXTERNAL R1MACH,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 REAL R1MACH, 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 REAL 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 C *** DATA INITIALIZATIONS *** C DATA HALF/0.5E0/, ONE/1.0E0/, TWO/2.0E0/, ZERO/0.0E0/ 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.R1MACH(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.R1MACH(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 *AXPBY SUBROUTINE AXPBY(N,SA,SX,INCX,SB,SY,INCY,SZ,INCZ) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE IS ADAPTED FROM BLAS SUBROUTINE SAXPY. C C OVERWRITE REAL SZ WITH REAL SA*SX + SB*SY. C FOR I = 0 TO N-1, REPLACE SZ(LZ+I*INCZ) WITH SA*SX(LX+I*INCX) + C SY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, C AND LY AND LZ ARE DEFINED IN A SIMILAR WAY USING INCY AND INCZ, C RESPECTIVELY. 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 REAL + SA,SB INTEGER + INCX,INCY,INCZ,N C C ARRAY ARGUMENTS REAL + SX(*),SY(*),SZ(*) C C LOCAL SCALARS INTEGER + I,IX,IY,IZ,M,MP1,NS C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL SX(N), SY(N), SZ(N) C IF(N.LE.0) RETURN IF ((INCX .EQ. 1) .AND. (INCY .EQ. 1) .AND. (INCZ .EQ. 1)) + GO TO 20 IF ((INCX .GE. 2) .AND. (INCX .EQ. INCY) .AND. (INCX .EQ. INCZ)) + GO TO 60 C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IZ = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 IF(INCZ.LT.0)IZ = (-N+1)*INCZ + 1 DO 10 I = 1,N SZ(IZ) = SA*SX(IX) + SB*SY(IY) IX = IX + INCX IY = IY + INCY IZ = IZ + INCZ 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 4. C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SZ(I) = SA*SX(I) + SB*SY(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SZ(I) = SA*SX(I) + SB*SY(I) SZ(I+1) = SA*SX(I+1) + SB*SY(I+1) SZ(I+2) = SA*SX(I+2) + SB*SY(I+2) SZ(I+3) = SA*SX(I+3) + SB*SY(I+3) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SZ(I) = SA*SX(I) + SB*SY(I) 70 CONTINUE RETURN 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 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 *BETAI REAL FUNCTION BETAI (X, PIN, QIN) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C BASED ON BOSTEN AND BATTISTE, REMARK ON ALGORITHM 179, COMM. ACM, C V 17, P 153, (1974). C C X VALUE TO WHICH FUNCTION IS TO BE INTEGRATED. X MUST BE IN (0,1). C P INPUT (1ST) PARAMETER (MUST BE GREATER THAN 0) C Q INPUT (2ND) PARAMETER (MUST BE GREATER THAN 0) C BETAI INCOMPLETE BETA FUNCTION RATIO, THE PROBABILITY THAT A RANDOM C VARIABLE FROM A BETA DISTRIBUTION HAVING PARAMETERS P AND Q C WILL BE LESS THAN OR EQUAL TO X. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL PIN,QIN,X C C LOCAL SCALARS REAL ALNEPS,ALNSML,C,EPS,FAC1,FAC2,FINSUM,P,P1,PS,Q,SML,TERM,XB,Y INTEGER I,IB,N C C EXTERNAL FUNCTIONS REAL ALBETA,R1MACH EXTERNAL ALBETA,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,AINT,EXP,FLOAT,LOG,MAX,MIN,REAL C DATA EPS, ALNEPS, SML, ALNSML / 4*0.0 / C IF (EPS.NE.0.) GO TO 10 EPS = R1MACH(3) ALNEPS = LOG(EPS) SML = R1MACH(1) ALNSML = LOG(SML) C 10 IF (X.LT.0. .OR. X.GT.1.0) CALL XERROR ( 1 'BETAI X IS NOT IN THE RANGE (0,1)', 35, 1, 2) IF (PIN.LE.0. .OR. QIN.LE.0.) CALL XERROR ( 1 'BETAI P AND/OR Q IS LE ZERO', 29, 2, 2) C Y = X P = PIN Q = QIN IF (Q.LE.P .AND. X.LT.0.8) GO TO 20 IF (X.LT.0.2) GO TO 20 Y = 1.0 - Y P = QIN Q = PIN C 20 IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80 C C EVALUATE THE INFINITE SUM FIRST. C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I) C PS = Q - AINT(Q) IF (PS.EQ.0.) PS = 1.0 XB = P*LOG(Y) - ALBETA(PS, P) - LOG(P) BETAI = 0.0 IF (XB.GE.ALNSML) THEN BETAI = EXP(XB) FAC2 = 1.0 IF (PS.NE.1.0E0) THEN FAC1 = 1.0 N = MAX(ALNEPS/LOG(Y), 4.0E0) DO 30 I=1,N IF ((I-PS.EQ.0.0E0) .OR. (FAC1.EQ.0.0E0)) THEN FAC1 = 0.0E0 ELSE IF (LOG(ABS(FAC1)) + LOG(ABS(I-PS)) + LOG(Y) - + LOG(REAL(I)) .LT. ALNSML) THEN FAC1 = 0.0E0 ELSE FAC1 = FAC1 * (I-PS)*Y/I END IF END IF FAC2 = FAC2 + FAC1*P/(P+I) 30 CONTINUE END IF BETAI = BETAI*FAC2 END IF C C NOW EVALUATE THE FINITE SUM, MAYBE. C IF (Q.LE.1.0) GO TO 70 C XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q) IB = MAX (XB/ALNSML, 0.0) TERM = EXP (XB - FLOAT(IB)*ALNSML) C = 1.0/(1.0-Y) P1 = Q*C/(P+Q-1.) C FINSUM = 0.0 N = Q IF (Q.EQ.FLOAT(N)) N = N - 1 DO 50 I=1,N IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 IF (Q-I+1.0E0 .EQ. 0.0E0) THEN TERM = 0.0E0 ELSE IF (LOG(ABS(Q-I+1.0E0)) + LOG(ABS(C)) + LOG(ABS(TERM)) - + LOG(ABS(P+Q-I)) .LT. ALNSML) THEN TERM = 0.0E0 ELSE TERM = (Q-I+1.0E0)*C*TERM/(P+Q-I) END IF END IF C IF (TERM.GT.1.0) IB = IB - 1 IF (TERM.GT.1.0) TERM = TERM*SML C IF (IB.EQ.0) FINSUM = FINSUM + TERM 50 CONTINUE C 60 BETAI = BETAI + FINSUM 70 IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI BETAI = MAX (MIN (BETAI, 1.0), 0.0) RETURN C 80 BETAI = 0.0 XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q) IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB) IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI RETURN C END *BFSDRV SUBROUTINE BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, + SPCF2, NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1, + WORK, LWORK, DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, + WINDOW, ICCOV, JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, + IPHAS, CODD, CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, + NFFT, INLPPC, JNLPPC, LY) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLING ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS . 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 REAL + ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC, + LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LWORK,LY,M,N,NF,NFFT, + NPRT,NW C C ARRAY ARGUMENTS REAL + CCOV(*),CEVEN(*),CODD(*),CSPC2(*),FREQ(*),PHAS(*),SPCF1(*), + SPCF2(*),W(*),WORK(*),XAXIS(*),Y1(*),Y2(*),YAXIS(*) INTEGER + ISYM(*),LAGS(*),NLPPC(*) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL WINDOW C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + BW,DF,FMN,FMX,XPLTMN,XPLTMX,YMEAN1,YMEAN2,YPLTMN,YPLTMX INTEGER + I,ILOG,ISPCER,J,K,LAG,LAGLST,NFUSED,NPTS,NWUSED LOGICAL + NEWPG,UNIVAR C C EXTERNAL FUNCTIONS INTEGER + LSTLAG EXTERNAL LSTLAG C C EXTERNAL SUBROUTINES EXTERNAL ACVF,ACVFF,ACVFM,BFSER,BFSLAG,BFSMN,CCVF,CCVFF,CCVFM, + DFBW,DFBWM,SETFRQ,UFSEST,UFSOUT C C INTRINSIC FUNCTIONS INTRINSIC INT,MAX,MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C STATEMENT FUNCTIONS INTEGER + I3C,I3N C C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL BW C THE BANDWIDTH. C REAL CCOV(ICCOV,JCCOV,M) C THE COVARIANCES. C REAL CEVEN(LAGMX1) C THE SUMS OF THE COVARIANCES FOR EACH LAG. C REAL CODD(LAGMX1) C THE DIFFERENCES OF THE COVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FMN, FMX C * C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. 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 ILOG C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF C ILOG = 1 THE PLOT IS LOG/LINEAR, IF C INTEGER ISPCER C AN ERROR FLAG USED FOR THE SPECTRUM PLOTS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER I3C C STATEMENT FUNCTION FOR FINDING LOCATIONS WITHIN CCOV. C INTEGER I3N C STATEMENT FUNCTION FOR FINDING LOCATIONS WITHIN NLPPC. C INTEGER JCCOV C THE SECOND DIMENSION OF CCOV C INTEGER JNLPPC C THE SECOND DIMENSION OF NLPPC C INTEGER LAG C THE LAG WINDWO TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED AN ACVF C TO BE UNABLE TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C THE VALUE LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C LOGICAL NEWPG C THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT C WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NFUSED C THE NUMBER OF FREQUENCIES ACTUALLY USED. C INTEGER NLPPC(INLPPC,JNLPPC,M) C THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C INTEGER NWUSED C THE NUMBER OF DIFFERENT BANDWIDTHS ACTUALLY USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRUM. C REAL SPCF1(NF), SPCF2(NF) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C LOGICAL UNIVAR C THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT C IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA. C REAL W(LW) C THE VECTOR OF WINDOWS. C EXTERNAL WINDOW C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL WORK(LWORK) C THE VECTOR OF WORK SPACE. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMEAN1, YMEAN2 C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS1, YMISS2 C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C REAL Y1(N), Y2(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C C STATEMENT FUNCTION DEFINITIONS C I3C(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV I3N(I,J,K) = I + (J-1)*INLPPC + (K-1)*JNLPPC*INLPPC C NFUSED = NF IF (OPTION(4)) THEN FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF ELSE C C SET VARIOUS VALUES FOR SHORT FORMS OF CALL STATEMENT C NPRT = -1 FMN = 0.0E0 FMX = 0.5E0 LAGMX1 = LAGMAX + 1 END IF C C CHECK FOR ERRORS C CALL BFSER(NMSUB, N, LAGMAX, ICCOV, JCCOV, INLPPC, JNLPPC, M, + INDEX1, INDEX2, ICSPC2, IPHAS, NF, NW, LAGS, + LDSTAK, LDSMIN, LY, NFFT, OPTION) C IF (IERR.EQ.1) RETURN C C SET VARIOUS PROGRAM PARAMETERS. C ALPHA = 0.95E0 DELTA = 1.0E0 C C COMPUTE COVARIANCES C LAGLST = LAGMAX IF (OPTION(1)) THEN CALL ACVFF(Y1, N, NFFT, YMEAN1, + CCOV(I3C(1,INDEX1,INDEX1)), + LAGMAX, ICCOV, N, WORK, NFFT) CALL ACVFF(Y2, N, NFFT, YMEAN2, + CCOV(I3C(1,INDEX2,INDEX2)), + LAGMAX, ICCOV, N, WORK, NFFT) CALL CCVFF(Y1, Y2, N, NFFT, LAGMAX, + CCOV(I3C(1,INDEX1,INDEX2)), + CCOV(I3C(1,INDEX2,INDEX1)), ICCOV, N, WORK, LWORK) C ELSE IF (OPTION(3)) THEN IF (OPTION(2)) LAGLST = LSTLAG(NLPPC,LAGMAX,INLPPC) ELSE IF (OPTION(2)) THEN CALL ACVFM(Y1, YMISS1, N, YMEAN1, + CCOV(I3C(1,INDEX1,INDEX1)), + LAGMAX, LAGLST, NLPPC, ICCOV) CALL ACVFM(Y2, YMISS2, N, YMEAN2, + CCOV(I3C(1,INDEX2,INDEX2)), + LAGMAX, LAGLST, NLPPC, ICCOV) CALL CCVFM(Y1, YMISS1, Y2, YMISS2, N, LAGMAX, YMEAN1, + YMEAN2, CCOV(I3C(1,INDEX1,INDEX2)), + CCOV(I3C(1,INDEX2,INDEX1)), ICCOV, + NLPPC(I3N(1,INDEX1,INDEX2)), + NLPPC(I3N(1,INDEX2,INDEX1))) C ELSE CALL ACVF(Y1, N, YMEAN1, CCOV(I3C(1,INDEX1,INDEX1)), LAGMAX, + ICCOV) CALL ACVF(Y2, N, YMEAN2, CCOV(I3C(1,INDEX2,INDEX2)), LAGMAX, + ICCOV) CALL CCVF(Y1, Y2, N, LAGMAX, YMEAN1, YMEAN2, + CCOV(I3C(1,INDEX1,INDEX2)), + CCOV(I3C(1,INDEX2,INDEX1)), ICCOV) END IF END IF END IF C IF (LAGLST.LE.0) THEN C C AN ERROR HAS BEEN DETECTED C IERR = 2 RETURN END IF C C COMPUTE THE VECTOR OF LAG WINDOW TRUNCATION POINTS, ORDERED C SMALLEST TO LARGEST. C NWUSED = NW IF (.NOT.OPTION(4)) CALL BFSLAG(CCOV, LAGLST, LAGS, N, NW, NWUSED, + ICCOV, JCCOV, INDEX1, INDEX2) C C BEGIN COMPUTING FOURIER SPECTRUM FOR SERIES C UNIVAR = .FALSE. C ILOG = 0 C XPLTMN = FMN XPLTMX = FMX C YPLTMN = 0.0E0 YPLTMX = 1.0E0 C C SET FREQUENCIES FOR THE SPECTRUM. C CALL SETFRQ(FREQ, NF, 1, FMN, FMX, DELTA) C C COMPUTE AND PLOT SPECTRUM VALUES. C NEWPG = .FALSE. C C COMPUTE THE EVEN AND ODD CCVF ESTIMATES C CEVEN(1) = CCOV(I3C(1,INDEX1,INDEX2)) CODD(1) = 0.0E0 DO 30 I=1,LAGLST CEVEN(I+1) = 0.5E0* + (CCOV(I3C(I+1,INDEX1,INDEX2))+ + CCOV(I3C(I+1,INDEX2,INDEX1))) CODD(I+1) = 0.5E0* + (CCOV(I3C(I+1,INDEX1,INDEX2))- + CCOV(I3C(I+1,INDEX2,INDEX1))) 30 CONTINUE C DO 60 I=1,NWUSED LAG = LAGS(I) IF (LAG.GT.LAGLST) THEN ISPCER = 2 DF = 0.0E0 ELSE C ISPCER = 0 C C COMPUTE THE WINDOW, AND EFFECTIVE DEGREES OF FREEDOM AND C BANDWIDTH BASED ON THE WINDOW C CALL WINDOW(LAG, W, LW) IF (OPTION(2)) THEN CALL DFBWM(N, LAG, W, LW, NLPPC(I3N(1,INDEX1,INDEX2)), + NLPPC(I3N(1,INDEX2,INDEX1)), INLPPC, DF, BW) ELSE CALL DFBW(N, LAG, W, LW, DF, BW) END IF C C COMPUTE THE SPECTRUM FOR EACH INDIVIDUAL SERIES C CALL UFSEST(CCOV(I3C(1,INDEX1,INDEX1)), W, LAG, SPCF1, + NFUSED, ICCOV, LAGMAX, NF, FREQ, DELTA) C CALL UFSEST(CCOV(I3C(1,INDEX2,INDEX2)), W, LAG, SPCF2, + NFUSED, ICCOV, LAGMAX, NF, FREQ, DELTA) C CALL BFSMN(SPCF1, SPCF2, CEVEN, CODD, W, LW, LAG, DF, NPRT, + NF, CSPC2(1+(I-1)*ICSPC2), PHAS(1+(I-1)*IPHAS), + FREQ, NPTS, XAXIS, + YAXIS, ISYM, LPCV, ALPHA, LAGMX1, DELTA) C IF (NPRT.EQ.0) GO TO 60 C END IF CALL UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, INT(DF+0.5E0), LAG, + LAGMAX, NEWPG, ISPCER, NFUSED+5, XPLTMN, XPLTMX, + YPLTMN, YPLTMX, ILOG, PHAS(1+(I-1)*IPHAS), FREQ, + NF, UNIVAR, NMSUB) C NEWPG = .TRUE. C 60 CONTINUE C RETURN C END *BFSER SUBROUTINE BFSER(NMSUB, N, LAGMAX, ICCOV, JCCOV, INLPPC, JNLPPC, + M, INDEX1, INDEX2, ICSPC2, IPHAS, NF, NW, LAGS, + LDSTAK, LDSMIN, LYFFT, NFFT, OPTION) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES C FOURIER UNIVARIATE SPECTRUM ANALYSIS 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 + ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC, + LAGMAX,LDSMIN,LDSTAK,LYFFT,M,N,NF,NFFT,NW C C ARRAY ARGUMENTS INTEGER + LAGS(*) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(30) CHARACTER + L1(8)*1,LICCOV(8)*1,LICSPC(8)*1,LINDX1(8)*1,LINDX2(8)*1, + LINLPP(8)*1,LIPHAS(8)*1,LJCCOV(8)*1,LJNLPP(8)*1, + LLAGMX(8)*1,LLAGS(8)*1,LLDS(8)*1,LLGMX1(8)*1, + LLYFFT(8)*1,LM(8)*1,LN(8)*1,LNF(8)*1,LNM1(8)*1,LNW(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,EISLE,EIVII C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(30) 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 VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER JCCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C CHARACTER*1 LICCOV(8), LICSPC(8), LINDX1(8), C * LINDX2(8), LINLPP(8), LIPHAS(8), LJCCOV(8), LJNLPP(8), C * LLAGMX(8), LLAGS(8), LLDS(8), LLGMX1(8), LLYFFT(8), LM(8), C * LN(8), LNF(8), LNM1(8), LNW(8), L1(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S) C CHECKED FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF VECTOR YFFT. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS. C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C C SET UP NAME ARRAYS C DATA LICCOV(1), LICCOV(2), LICCOV(3), LICCOV(4), LICCOV(5), + LICCOV(6), LICCOV(7), LICCOV(8) /'I','C','C','O','V',' ',' ', + ' '/ DATA LICSPC(1), LICSPC(2), LICSPC(3), LICSPC(4), LICSPC(5), + LICSPC(6), LICSPC(7), LICSPC(8) /'I','C','S','P','C','2',' ', + ' '/ DATA LINDX1(1), LINDX1(2), LINDX1(3), LINDX1(4), LINDX1(5), + LINDX1(6), LINDX1(7), LINDX1(8) /'I','N','D','E','X','1',' ', + ' '/ DATA LINDX2(1), LINDX2(2), LINDX2(3), LINDX2(4), LINDX2(5), + LINDX2(6), LINDX2(7), LINDX2(8) /'I','N','D','E','X','2',' ', + ' '/ DATA LIPHAS(1), LIPHAS(2), LIPHAS(3), LIPHAS(4), LIPHAS(5), + LIPHAS(6), LIPHAS(7), LIPHAS(8) /'I','P','H','A','S',' ',' ', + ' '/ DATA LINLPP(1), LINLPP(2), LINLPP(3), LINLPP(4), LINLPP(5), + LINLPP(6), LINLPP(7), LINLPP(8) /'I','N','L','P','P','C',' ', + ' '/ DATA LJCCOV(1), LJCCOV(2), LJCCOV(3), LJCCOV(4), LJCCOV(5), + LJCCOV(6), LJCCOV(7), LJCCOV(8) /'J','C','C','O','V',' ',' ', + ' '/ DATA LJNLPP(1), LJNLPP(2), LJNLPP(3), LJNLPP(4), LJNLPP(5), + LJNLPP(6), LJNLPP(7), LJNLPP(8) /'J','N','L','P','P','C',' ', + ' '/ DATA LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5), + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ', + ' '/ DATA LLAGS(1), LLAGS(2), LLAGS(3), LLAGS(4), LLAGS(5), LLAGS(6), + LLAGS(7), LLAGS(8) /'L','A','G','S',' ',' ',' ',' '/ DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5), + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+', + '1'/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), + LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/ DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), + LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/ DATA LNW(1), LNW(2), LNW(3), LNW(4), LNW(5), LNW(6), LNW(7), + LNW(8) /'N','W',' ',' ',' ',' ',' ',' '/ DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ', + ' '/ DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1', + ' ',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C DO 10 I=1,30 ERROR(I) = .FALSE. 10 CONTINUE C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERROR(1), LN) C IF ((.NOT.OPTION(3))) GO TO 20 C CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERROR(2), L1, + LNM1) C CALL EISGE(NMSUB, LM, M, 2, 1, HEAD, ERROR(3), LM) C CALL EISGE(NMSUB, LICCOV, ICCOV, LAGMAX+1, 3, HEAD, ERROR(4), + LLGMX1) C CALL EISGE(NMSUB, LJCCOV, JCCOV, M, 4, HEAD, ERROR(5), LM) C IF (OPTION(2)) THEN CALL EISGE(NMSUB, LINLPP, INLPPC, LAGMAX+1, 3, HEAD, ERROR(6), + LLGMX1) C CALL EISGE(NMSUB, LJNLPP, JNLPPC, M, 4, HEAD, ERROR(7), LM) END IF C CALL EISLE(NMSUB, LINDX1, INDEX1, M, 2, HEAD, ERROR(8), LM) C CALL EISLE(NMSUB, LINDX2, INDEX2, M, 2, HEAD, ERROR(9), LM) C 20 CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERROR(10), LLYFFT) C IF (OPTION(1) .AND. (.NOT.OPTION(4))) CALL EISGE(NMSUB, LLDS, + LDSTAK, LDSMIN, 9, HEAD, ERROR(15), LLDS) C IF (OPTION(4)) GO TO 40 C DO 30 I=1,15 IF (ERROR(I)) GO TO 70 30 CONTINUE C RETURN C 40 CONTINUE C CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERROR(16), LNF) C CALL EISGE(NMSUB, LNW, NW, 1, 1, HEAD, ERROR(18), LNW) C IF (ERROR(18)) GO TO 50 IF (OPTION(3)) THEN CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, LAGMAX, 0, + HEAD, 4, NV, ERROR(19), L1, LLAGMX) ELSE CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, N-1, 0, + HEAD, 4, NV, ERROR(19), L1, LNM1) END IF C 50 CONTINUE C CALL EISGE(NMSUB, LICSPC, ICSPC2, NF, 3, HEAD, ERROR(24), LNF) C CALL EISGE(NMSUB, LIPHAS, IPHAS, NF, 3, HEAD, ERROR(25), LNF) C IF (ERROR(2) .OR. ERROR(16) .OR. ERROR(18) .OR. ERROR(19)) GO TO + 70 C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(30), LLDS) C DO 60 I=1,30 IF (ERROR(I)) GO TO 70 60 CONTINUE C RETURN C 70 CONTINUE IERR = 1 RETURN C END *BFS SUBROUTINE BFS(Y1, Y2, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C BIVARIATE SPECTRUM ANALYSIS (SHORT 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 + N C C ARRAY ARGUMENTS REAL + Y1(*),Y2(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV,JNLPPC, + LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW C C LOCAL ARRAYS REAL + CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101), + PHAS(101,4),SPCF1(101),SPCF2(101),W(101),XAXIS(404), + YAXIS(404) INTEGER + ISYM(404),LAGS(4),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,PARZEN,SETLAG C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(101,2,2) C THE COVARIANCES. C REAL CEVEN(101) C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CODD(101) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(101,4) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISYM(404) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(1,1,1) C A DUMMY ARRAY. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(101,4) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL SPCF1(101), SPCF2(101) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL W(101) C THE WINDOWS. C REAL XAXIS(404) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(404) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL Y1(N) C THE FIRST TIME SERIES. C REAL Y2(N) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .FALSE. C ICCOV = 101 JCCOV = 2 M = 2 INDEX1 = 1 INDEX2 = 2 C ICSPC2 = 101 IPHAS = 101 C LDSTAK = 0 LDSMIN = 0 C NF = 101 YMISS1 = 1.0E0 YMISS2 = 1.0E0 INLPPC = 1 JNLPPC = 1 LW = 101 LY = N LPCV = 404 C C SET MAXIMUM LAG VALUE (LAGMAX) C SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW) C CALL SETLAG(N, LAGMAX) NW = 4 C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2, + NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1, W, LW, + DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD, + CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC, + JNLPPC, LY) C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFS (Y1, Y2, N)') END *BFSF SUBROUTINE BFSF(YFFT1, YFFT2, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C BIVARIATE SPECTRUM ANALYSIS (SHORT 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT1(*),YFFT2(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICCOV,ICSPC2,IFP,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV, + JNLPPC,LAGMAX,LAGMX1,LDSMIN,LPCV,LW,LWORK,M,NALL0,NF,NFFT, + NPRT,NW,WORK C C LOCAL ARRAYS REAL + CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101), + PHAS(101,4),RSTAK(12),SPCF1(101),SPCF2(101),W(101), + XAXIS(404),YAXIS(404) INTEGER + ISYM(404),LAGS(4),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(101,2,2) C THE COVARIANCES. C REAL CEVEN(101) C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CODD(101) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(101,4) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISYM(404) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LYFFT C THE LENGTH OF THE VECTORS Y1 AND YFFT1 AND YFFT2 C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPC(1,1,1) C A DUMMY ARRAY. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(101,4) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF1(101), SPCF2(101) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL W(101) C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR C THE WORK VECTOR C REAL XAXIS(404) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(404) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL YFFT1(LYFFT) C THE FIRST TIME SERIES. C REAL YFFT2(LYFFT) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','F',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .TRUE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .FALSE. C ICCOV = 101 JCCOV = 2 M = 2 INDEX1 = 1 INDEX2 = 2 C ICSPC2 = 101 IPHAS = 101 C LDSMIN = 0 C NF = 101 YMISS1 = 1.0E0 YMISS2 = 1.0E0 INLPPC = 1 JNLPPC = 1 LW = 101 LPCV = 404 C C SET MAXIMUM LAG VALUE (LAGMAX) C SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW) C SET EXTENDED SERIES LENGTH (NFFT) C CALL SETLAG(N, LAGMAX) NW = 4 CALL SETESL(N+LAGMAX, 4, NFFT) C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH (LDSMIN) C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C C SET SIZE OF WORK AREA C SET NUMBER OF OUTSTANDING ALLOCATIONS (NALL0) C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET THE STARTING LOCATIONS INTHE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.LE.LDSTAK) .AND. (LDSMIN.GE.7)) THEN WORK = STKGET(NFFT,IFP) LWORK = NFFT ELSE WORK = 1 LWORK = 1 END IF C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(YFFT1, YFFT2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, + SPCF2, NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, + LAGMX1, RSTAK(WORK), LWORK, DELTA, ISYM, XAXIS, + YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, JCCOV, M, + INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD, + CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, NFFT, + INLPPC, JNLPPC, LYFFT) C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSF (YFFT1, YFFT2, N, LYFFT, LDSTAK)') END *BFSFS SUBROUTINE BFSFS(YFFT1, YFFT2, N, LYFFT, LDSTAK, NW, LAGS, NF, + FMIN, FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C BIVARIATE SPECTRUM ANALYSIS (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 REAL + FMAX,FMIN INTEGER + ICSPC2,IPHAS,LDSTAK,LYFFT,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + CSPC2(*),FREQ(*),PHAS(*),YFFT1(*),YFFT2(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS1,YMISS2 INTEGER + CCOV,CCOV11,CCOV12,CCOV21,CCOV22,CEVEN,CODD,I,ICCOV,IFP, + INDEX1,INDEX2,INLPPC,IO,IPRT,ISYM,JCCOV,JNLPPC,LAGMAX, + LAGMX1,LDSMIN,LPCV,LW,LWORK,M,NALL0,NFFT,SPCF1,SPCF2,W, + WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C INTEGER CCOV, CCOV11, CCOV12, CCOV21, CCOV22 C THE STARTING LOCATION IN THE WORK AREA FOR C THE COVARIANCES. C INTEGER CEVEN C THE STARTING LOCATION IN THE WORK AREA FOR C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C INTEGER CODD C THE STARTING LOCATION IN THE WORK AREA FOR C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LYFFT C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPC(1,1,1) C A DUMMY ARRAY. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SPCF1, SPCF2 C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER W C THE STARTING LOCATION IN THE WORK AREA FOR C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL YFFT1(LYFFT) C THE FIRST TIME SERIES. C REAL YFFT2(LYFFT) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','F','S',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED. C IF (NW.GE.1) THEN LAGMAX = LAGS(1) DO 10 I=2,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE ELSE LAGMAX = N - 1 END IF LAGMX1 = LAGMAX + 1 CALL SETESL(N+LAGMAX, 4, NFFT) C ICCOV = LAGMAX + 1 JCCOV = 2 INLPPC = 1 JNLPPC = 1 M = 2 INDEX1 = 1 INDEX2 = 2 C C COMPUTE THE MINIMUM ALLOWABLE STACK AREA C IF (NPRT.EQ.0) THEN IO = 0 ELSE IO = 1 END IF C CALL LDSCMP(9, 0, IO*4*NF, 0, 0, 0, 'S', + 6*LAGMAX+6+NFFT+IO*8*NF, LDSMIN) C YMISS1 = 1.0E0 YMISS2 = 1.0E0 LPCV = 4*NF LW = NFFT C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0) C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN CCOV = 1 CEVEN = 1 CODD = 1 SPCF1 = 1 SPCF2 = 1 W = 1 C CCOV11 = 1 CCOV21 = 1 CCOV12 = 1 CCOV22 = 1 C ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE CCOV = STKGET(4*LAGMX1,IFP) CEVEN = STKGET(LAGMX1,IFP) CODD = STKGET(LAGMX1,IFP) SPCF1 = STKGET(NF,IFP) SPCF2 = STKGET(NF,IFP) W = STKGET(LW,IFP) C CCOV11 = CCOV CCOV21 = CCOV + LAGMX1 CCOV12 = CCOV21 + LAGMX1 CCOV22 = CCOV12 + LAGMX1 C IF (NPRT.EQ.0) THEN ISYM = W XAXIS = W YAXIS = W ELSE ISYM = STKGET(LPCV,2) XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) END IF END IF C WORK = W LWORK = LW C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(YFFT1, YFFT2, YMISS1, YMISS2, RSTAK(CCOV), NLPPC, + RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW, + LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM), + RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, + RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN, + LDSTAK, OPTION, NFFT, INLPPC, JNLPPC, LYFFT) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSFS (YFFT1, YFFT2, N, LYFFT, LDSTAK,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + CSPC2, ICSPC2, PHAS, IPHAS, FREQ)') END *BFSLAG SUBROUTINE BFSLAG(CCOV, LAGMAX, LAGS, N, NW, NWUSED, ICCOV, + JCCOV, INDEX1, INDEX2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE LAG WINDOW TRUNCATION POINTS FOR C FOURIER BIVARIATE SPECTRUM ANALYSIS. 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 + ICCOV,INDEX1,INDEX2,JCCOV,LAGMAX,N,NW,NWUSED C C ARRAY ARGUMENTS REAL + CCOV(ICCOV,JCCOV,*) INTEGER + LAGS(*) C C LOCAL SCALARS REAL + COVMX,COVMXI,FAC11,FAC12,FAC21,FAC22,P95LIM INTEGER + I,J,K,LAG,NWM1 C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(ICCOV,JCCOV,*) C THE COVARIANCES. C REAL COVMX C THE MAXIMUM COVARIANCE VALUE. C REAL COVMXI C THE MAXIMUM COVARIANCE VALUE FOR THE ITH LAG. C REAL FAC11, FAC12, FAC21, FAC22 C FACTORS USED TO COMPUTE THE CORRELATION COEFFICIENTS. C INTEGER I C AN INDEX VARIABLE C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER J C AN INDEX VALUE. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER K C AN INDEX VALUE. C INTEGER LAG, LAGMAX C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C BIVARIATE COVARIANCE BEING COMPUTED AND THE MAXIMUM LAG C TO BE USED, RESPECTIVELY. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NW C THE NUMBER OF DIFFERENT BANDWIDTHS REQUESTED. C INTEGER NWM1, NWUSED C THE NUMBER OF DIFFERENT BANDWIDTHS MINUS 1, AND THE C ACTUAL NUMBER OF BANDWIDTHS ACTUALLY USED. C REAL P95LIM C THE 95 PERCENT CONFIDENT LIMIT FOR WHITE NOISE. C LAGS(NW) = LAGMAX IF (LAGS(NW).LE.32) GO TO 30 C C COMPUTE 95 PERCENT CONFIDENCE LIMITS ON BIVARIATECOVARIANCES, C ASSUMING WHITE NOISE. C P95LIM = 1.96E0/SQRT(REAL(N)) C FAC11 = CCOV(1,INDEX1,INDEX1) FAC12 = SQRT(CCOV(1,INDEX1,INDEX1)*CCOV(1,INDEX2,INDEX2)) FAC21 = FAC12 FAC22 = CCOV(1,INDEX2,INDEX2) C C CHECK FOR FIRST CVF EXCEEDING 95 PERCENT LIMIT ON WHITE NOISE C DO 10 I=1,LAGMAX LAG = LAGMAX + 1 - I COVMXI = MAX(ABS(CCOV(LAG,INDEX1,INDEX1)*FAC11),ABS(CCOV(LAG, + INDEX1,INDEX2)*FAC12),ABS(CCOV(LAG,INDEX2,INDEX1)*FAC21), + ABS(CCOV(LAG,INDEX2,INDEX2)*FAC22)) IF (COVMXI.GE.P95LIM) GO TO 30 LAGS(NW) = LAGS(NW) - 1 10 CONTINUE C C IF NO ACVF EXCEEDS WHITE NOISE LIMITS, CHECK FOR LARGEST ACVF. C LAGS(NW) = 1 COVMX = ABS(CCOV(2,1,1)*FAC11) DO 20 LAG=1,LAGMAX COVMXI = MAX(ABS(CCOV(LAG,INDEX1,INDEX1)*FAC11),ABS(CCOV(LAG, + INDEX1,INDEX2)*FAC12),ABS(CCOV(LAG,INDEX2,INDEX1)*FAC21), + ABS(CCOV(LAG,INDEX2,INDEX2)*FAC22)) IF (COVMXI.LE.COVMX) GO TO 20 LAGS(NW) = LAG COVMX = COVMXI 20 CONTINUE C C COMPUTE LAG WINDOW TRUNCATION POINTS C 30 LAGS(NW) = LAGS(NW)*3.0E0/2.0E0 IF (LAGS(NW).LT.32) LAGS(NW) = 32 IF (LAGS(NW).GT.LAGMAX) LAGS(NW) = LAGMAX NWUSED = NW IF (NW.EQ.1) RETURN NWM1 = NW - 1 DO 40 I=1,NWM1 K = NW - I LAGS(K) = LAGS(K+1)/2 40 CONTINUE C C CHECK WHETHER ALL NW LAG WINDOW TRUNCATION POINTS CAN BE USED. C NWUSED = NW IF (LAGS(1).GE.4) RETURN C C RECONSTURCT -LAGS- VECTOR IF NOT ALL TRUNCATION POINTS ARE C TO BE USED C DO 50 I=2,NW NWUSED = NWUSED - 1 IF (LAGS(I).GE.4) GO TO 60 50 CONTINUE C 60 DO 70 I=1,NWUSED J = NW - NWUSED + I LAGS(I) = LAGS(J) 70 CONTINUE C RETURN END *BFSM SUBROUTINE BFSM(Y1, YMISS1, Y2, YMISS2, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS C (SHORT 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 REAL + YMISS1,YMISS2 INTEGER + N C C ARRAY ARGUMENTS REAL + Y1(*),Y2(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN INTEGER + ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,IPRT,JCCOV,JNLPPC, + LAGMAX,LAGMX1,LDSMIN,LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW C C LOCAL ARRAYS REAL + CCOV(101,2,2),CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101), + PHAS(101,4),SPCF1(101),SPCF2(101),W(101),XAXIS(404), + YAXIS(404) INTEGER + ISYM(404),LAGS(4),NLPPC(101,2,2) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,ECVF,IPRINT,PARZEN,SETLAG C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(101,2,2) C THE COVARIANCES. C REAL CEVEN(101) C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CODD(101) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(101,4) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISYM(404) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(101,2,2) C THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(101,4) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL SPCF1(101), SPCF2(101) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL W(101) C THE WINDOWS. C REAL XAXIS(404) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(404) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C THE MISSING VALUE CODES C REAL Y1(N) C THE FIRST TIME SERIES. C REAL Y2(N) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','M',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .TRUE. OPTION(3) = .FALSE. OPTION(4) = .FALSE. C ICCOV = 101 JCCOV = 2 M = 2 INDEX1 = 1 INDEX2 = 2 C ICSPC2 = 101 IPHAS = 101 C LDSTAK = 0 LDSMIN = 0 C NF = 101 INLPPC = 101 JNLPPC = 2 LW = 101 LY = N LPCV = 404 C C SET MAXIMUM LAG VALUE (LAGMAX) C SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW) C CALL SETLAG(N, LAGMAX) NW = 4 C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2, + NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, LAGMX1, W, LW, + DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD, + CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC, + JNLPPC, LY) C IF (IERR.NE.0) THEN IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSM (Y1, YMISS1, Y2, YMISS2, N)') END *BFSMN SUBROUTINE BFSMN(SPCF1, SPCF2, CEVEN, CODD, W, LW, LAG, DF, NPRT, + NF, CSPC2, PHAS, FREQ, NPTS, XAXIS, YAXIS, ISYM, LPCV, ALPHA, + LAGMX1, DELTA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE SQUARED COHERENCY AND PHASE COMPONENTS C OF A BIVARIATE SPECTRUM. C C REFERENCE - JENKINS AND WATTS C SPECTRAL ANALYSIS AND ITS APPLICATIONS C C WRITTEN BY - STEPHEN M. KEEFER AND 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 REAL + ALPHA,DELTA,DF INTEGER + LAG,LAGMX1,LPCV,LW,NF,NPRT,NPTS C C ARRAY ARGUMENTS REAL + CEVEN(*),CODD(*),CSPC2(*),FREQ(*),PHAS(*),SPCF1(*),SPCF2(*), + W(*),XAXIS(*),YAXIS(*) INTEGER + ISYM(*) C C LOCAL SCALARS REAL + ARG,BARL,BARQ,BARY,C,CI,FAC,FPLM,FPLRS,FPSPM,G,PI,PIT2,SN,V0, + V1,V2,Z0,Z1,Z2 INTEGER + I,K C C EXTERNAL FUNCTIONS REAL + PPFNML,R1MACH EXTERNAL PPFNML,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC ATAN2,COS,LOG,SIGN,SIN,SQRT,TANH C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL ARG C AN ARGUMENT USED IN THE SPECTRUM COMPUTATIONS. C REAL BARL C THE SMOOTHED COSPECTRAL ESTIMATES. C REAL BARQ C THE SMOOTHED QUADRATURE SPECTRAL ESTIMATES. C REAL BARY C A TRANSFORMATION OF THE SQUARED COHERENCY COMPONENT. C REAL C C AN ARGUMENT USED IN THE SPECTRUM COMPUTATIONS. C REAL CEVEN(LAGMX1) C THE SUMS OF THE COVARIANCES FOR EACH LAG. C REAL CI C THE CONFIDENCE INTERVAL FOR THE SQUARED COHERENCY COMPONENT. C REAL CODD(LAGMX1) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(NF) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C REAL FAC C THE CONVERSION FACTOR FROM RADIANS TO DEGREES. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C REAL FPSPM C THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE. C REAL FREQ(NF) C THE FREQUENCIES AT WHICH THE SPECTRUM IS COMPUTED. C REAL G C AN ARGUMENT USED IN THE COMPUTATION OF THE ALPHA PERCENT C SIGNIFICANCE LEVEL. C INTEGER I C AN INDEX VALUE. C INTEGER ISYM(LPCV) C THE VECTOR CONTAINING THE CODES FOR THE PLOT SYMBOLS. C INTEGER K C AN INDEX VALUE. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMX1 C THE VALUE LAGMAX+1. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF VECTOR W. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT = 2 THE PLOT IS PROVIDED. C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL PHAS(NF) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL PI, PIT2 C THE VALUE OF PI AND PI*2. C REAL SN C AN ARGUMENT USED IN THE COMPUTATION OF THE SPECTRUM. C REAL SPCF1(NF), SPCF2(NF) C THE UNIVARIATE SPECTRUM FOR EACH SERIES. C REAL V0, V1, V2 C ARGUMENTS USED IN THE COMPUTATION OF THE SPECTRUM. C REAL W(LW) C THE WINDOW. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL Z0, Z1, Z2 C ARGUMENTS USED IN THE COMPUTATION OF THE SPECTRUM. C C CALL GETPI(PI) PIT2 = PI*2.0E0 C FPSPM = R1MACH(1) FPLM = R1MACH(2) FPLRS = R1MACH(4) C FAC = 180.0E0/PI C C C COMPUTE SMOOTHED CO-SPECTRAL ESTIMATE C DO 40 I=1,NF C C COMPUTE SMOOTHED CO- AND QUADRATURE SPECTRA USING C THE ALGORITHM SHOWN ON PAGE 420 OF JENKINS AND WATTS C IF (FREQ(I).EQ.0.0E0) THEN C = 1.0E0 SN = 0.0E0 ELSE IF (FREQ(I).EQ.0.25E0) THEN C = 0.0E0 SN = 1.0E0 ELSE IF (FREQ(I).EQ.0.5E0) THEN C = -1.0E0 SN = 0.0 ELSE ARG = PIT2*FREQ(I) C = COS(ARG) SN = SIN(ARG) END IF V0 = 0.0E0 V1 = 0.0E0 Z0 = 0.0E0 Z1 = 0.0E0 DO 10 K=LAG-1,1,-1 V2 = 2.0E0*C*V1 - V0 + W(K+1)*CEVEN(K+1) Z2 = 2.0E0*C*Z1 - Z0 + W(K+1)*CODD(K+1) V0 = V1 V1 = V2 Z0 = Z1 Z1 = Z2 10 CONTINUE BARL = DELTA*(CEVEN(1)+2.0E0*(V1*C-V0)) BARQ = 2.0E0*DELTA*Z1*SN C C COMPUTE THE SMOOTHED SQUARED COHERENCY SPECTRA C IF (SPCF1(I)*SPCF2(I).GT.0.0E0) THEN CSPC2(I) = (BARL*BARL+BARQ*BARQ) CSPC2(I) = CSPC2(I)/(SPCF1(I)*SPCF2(I)) ELSE CSPC2(I) = FPLM END IF C C COMPUTE PHASE (IN RADIANS) C IF ((BARQ.NE.0.0E0) .OR. (BARL.NE.0.0E0)) THEN PHAS(I) = ATAN2(-BARQ,BARL) ELSE IF (I.EQ.1) THEN PHAS(I) = 0.0E0 ELSE PHAS(I) = SIGN(PI,PHAS(I-1)) END IF END IF 40 CONTINUE C IF (NPRT.EQ.0) RETURN C C COMPUTE SMOOTHED SQUARED COHERENCY PLOT VECTORS C CI = PPFNML(ALPHA)*SQRT(1.0E0/DF) G = 2.0E0/DF G = 1.0E0 - (1.0E0-ALPHA)**(G/(1.0E0-G)) NPTS = 0 DO 60 I=1,NF NPTS = NPTS + 1 C C COMPUTE 95 PER CENT SIGNIFICANCE LEVEL C YAXIS(NPTS) = G XAXIS(NPTS) = FREQ(I) ISYM(NPTS) = 4 IF (SPCF1(I)*SPCF2(I).LE.0.0E0) GO TO 60 C C COMPUTE COHERENCE SPECTRAL ESTIMATE C IF (CSPC2(I).GT.1.0E0) GO TO 60 NPTS = NPTS + 1 YAXIS(NPTS) = CSPC2(I) XAXIS(NPTS) = FREQ(I) ISYM(NPTS) = 1 IF (CSPC2(I).LT.G) GO TO 60 C C COMPUTE CONFIDENCE INTERVAL C BARY = SQRT(CSPC2(I)) BARY = 0.5E0*(LOG((1.0E0+BARY)/(1.0E0-BARY))) NPTS = NPTS + 1 YAXIS(NPTS) = (TANH(BARY+CI))*(TANH(BARY+CI)) XAXIS(NPTS) = FREQ(I) ISYM(NPTS) = 2 NPTS = NPTS + 1 YAXIS(NPTS) = (TANH(BARY-CI))*(TANH(BARY-CI)) XAXIS(NPTS) = FREQ(I) ISYM(NPTS) = 2 60 CONTINUE C RETURN C END *BFSMS SUBROUTINE BFSMS (Y1, YMISS1, Y2, YMISS2, N, NW, LAGS, NF, FMIN, + FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS 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 REAL + FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICSPC2,IPHAS,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + CSPC2(*),FREQ(*),PHAS(*),Y1(*),Y2(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA INTEGER + CCOV,CEVEN,CODD,I,ICCOV,IFP,INDEX1,INDEX2,INLPPC,IO,IPRT, + ISYM,JCCOV,JNLPPC,LAGMAX,LAGMX1,LDSMIN,LPCV,LW,LWORK,LY,M, + NALL0,NLPPC,SPCF1,SPCF2,W,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C INTEGER CCOV C THE STARTING LOCATION IN THE WORK AREA FOR C THE COVARIANCES. C INTEGER CEVEN C THE STARTING LOCATION IN THE WORK AREA FOR C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C INTEGER CODD C THE STARTING LOCATION IN THE WORK AREA FOR C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC C THE STARTING LOCATION IN THE WORK AREA FOR NLPPC C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SPCF1, SPCF2 C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER W C THE STARTING LOCATION IN THE WORK AREA FOR C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL Y1(N) C THE FIRST TIME SERIES. C REAL Y2(N) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','M','S',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .TRUE. OPTION(3) = .FALSE. OPTION(4) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED (LAGMAX). C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LAGMX1 = LAGMAX + 1 C ICCOV = LAGMAX + 1 JCCOV = 2 INLPPC = LAGMAX + 1 JNLPPC = 2 M = 2 INDEX1 = 1 INDEX2 = 2 C C COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN) C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(10, 0, 4*LAGMAX + 4 + IO*4*NF, 0, 0, 0, 'S', + 7*LAGMAX+7+2*NF+IO*8*NF, LDSMIN) C LY = N LPCV = 4*NF LW = LAGMX1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0). C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN CCOV = 1 NLPPC = 1 CEVEN = 1 CODD = 1 SPCF1 = 1 SPCF2 = 1 W = 1 C ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE CCOV = STKGET(4*LAGMX1,IFP) NLPPC = STKGET(4*LAGMX1,2) CEVEN = STKGET(LAGMX1,IFP) CODD = STKGET(LAGMX1,IFP) SPCF1 = STKGET(NF,IFP) SPCF2 = STKGET(NF,IFP) W = STKGET(LW,IFP) IF (NPRT.EQ.0) THEN ISYM = W XAXIS = W YAXIS = W ELSE ISYM = STKGET(LPCV,2) XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) END IF END IF C WORK = W LWORK = LW C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, RSTAK(CCOV), ISTAK(NLPPC), + RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW, + LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM), + RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, + RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN, + LDSTAK, OPTION, N, INLPPC, JNLPPC, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.NE.0) THEN IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSMS (Y1, YMISS1, Y2, YMISS2, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)') END *BFSMV SUBROUTINE BFSMV(CCOV, NLPPC, INDEX1, INDEX2, N, LAGMAX, ICCOV, + JCCOV, INLPPC, JNLPPC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS C AND COVARIANCES INPUT RATHER THAN ORIGINAL SERIES C (SHORT 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 + ICCOV,INDEX1,INDEX2,INLPPC,JCCOV,JNLPPC,LAGMAX,N C C ARRAY ARGUMENTS REAL + CCOV(*) INTEGER + NLPPC(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICSPC2,IPHAS,IPRT,LAGMX1,LAGMXU,LDSMIN,LDSTAK,LPCV,LW,LY, + M,NF,NPRT,NW C C LOCAL ARRAYS REAL + CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),PHAS(101,4), + SPCF1(101),SPCF2(101),W(101),XAXIS(404),Y1(1),Y2(1), + YAXIS(404) INTEGER + ISYM(404),LAGS(4) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,ECVF,IPRINT,PARZEN,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(ICCOV,JCCOV,*) C THE COVARIANCES. C REAL CEVEN(101) C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CODD(101) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(101,4) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISYM(404) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX, LAGMXU C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(INLPPC,JNLPPC,*) C THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(101,4) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL SPCF1(101), SPCF2(101) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL W(101) C THE WINDOWS. C REAL XAXIS(404) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(404) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C THE MISSING VALUE CODES C REAL Y1(1) C THE FIRST TIME SERIES. C REAL Y2(1) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','M','V',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .TRUE. OPTION(3) = .TRUE. OPTION(4) = .FALSE. C M = 2 C ICSPC2 = 101 IPHAS = 101 C LDSTAK = 0 LDSMIN = 0 C NF = 101 LW = 101 LY = N LPCV = 404 C C SET MAXIMUM LAG VALUE USED (LAGMXU) C SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW) C CALL SETLAG(N, LAGMXU) LAGMXU = MIN(LAGMXU,LAGMAX) NW = 4 C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2, + NF, FMIN, FMAX, FREQ, N, NW, LAGMXU, LAGS, LAGMX1, W, LW, + DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD, + CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC, + JNLPPC, LY) C IF (IERR.NE.0) THEN IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSMV (CCOV, NLPPC, INDEX1, INDEX2, N, LAGMAX,'/ + ' + ICCOV, JCCOV, INLPPC, JNLPPC)') END *BFSMVS SUBROUTINE BFSMVS(CCOV, NLPPC, INDEX1, INDEX2, N, ICCOV, JCCOV, + INLPPC, JNLPPC, NW, LAGS, NF, FMIN, + FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH MISSING OBSERVATIONS C WITH USER INPUT OF THE COVARIANCES RATHER THAN THE SERIES 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 REAL + FMAX,FMIN INTEGER + ICCOV,ICSPC2,INDEX1,INDEX2,INLPPC,IPHAS,JCCOV,JNLPPC, + LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + CCOV(*),CSPC2(*),FREQ(*),PHAS(*) INTEGER + LAGS(*),NLPPC(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS1,YMISS2 INTEGER + CEVEN,CODD,I,IFP,IO,IPRT,ISYM,LAGMAX,LAGMX1,LDSMIN,LPCV, + LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12),Y1(1),Y2(1) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(ICCOV,JCCOV,*) C THE COVARIANCES. C INTEGER CEVEN C THE STARTING LOCATION IN THE WORK AREA FOR C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C INTEGER CODD C THE STARTING LOCATION IN THE WORK AREA FOR C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(INLPPC,JNLPPC,*) C THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SPCF1, SPCF2 C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER W C THE STARTING LOCATION IN THE WORK AREA FOR C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL Y1(1) C THE FIRST TIME SERIES. C REAL Y2(1) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','M','V','S'/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .TRUE. OPTION(3) = .TRUE. OPTION(4) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED (LAGMAX). C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LAGMX1 = LAGMAX + 1 C M = 2 C C COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN) C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(8, 0, IO*4*NF, 0, 0, 0, 'S', + 7*LAGMAX+7+2*NF+IO*8*NF, LDSMIN) C LY = N LPCV = 4*NF LW = LAGMAX + 1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0). C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN CEVEN = 1 CODD = 1 SPCF1 = 1 SPCF2 = 1 W = 1 C ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE CEVEN = STKGET(LAGMX1,IFP) CODD = STKGET(LAGMX1,IFP) SPCF1 = STKGET(NF,IFP) SPCF2 = STKGET(NF,IFP) W = STKGET(LW,IFP) IF (NPRT.EQ.0) THEN ISYM = W XAXIS = W YAXIS = W ELSE ISYM = STKGET(LPCV,2) XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) END IF END IF C WORK = W LWORK = LW C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, + RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW, + LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM), + RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, + RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN, + LDSTAK, OPTION, N, INLPPC, JNLPPC, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.NE.0) THEN IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSMVS(CCOV, NLPPC, INDEX1, INDEX2, N,'/ + ' + ICCOV, JCCOV, INLPPC, JNLPPC,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)') END *BFSS SUBROUTINE BFSS(Y1, Y2, N, NW, LAGS, NF, FMIN, FMAX, NPRT, CSPC2, + ICSPC2, PHAS, IPHAS, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C BIVARIATE SPECTRUM ANALYSIS (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 REAL + FMAX,FMIN INTEGER + ICSPC2,IPHAS,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + CSPC2(*),FREQ(*),PHAS(*),Y1(*),Y2(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS1,YMISS2 INTEGER + CCOV,CCOV11,CCOV12,CCOV21,CCOV22,CEVEN,CODD,I,ICCOV,IFP, + INDEX1,INDEX2,INLPPC,IO,IPRT,ISYM,JCCOV,JNLPPC,LAGMAX, + LAGMX1,LDSMIN,LPCV,LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK, + XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C INTEGER CCOV, CCOV11, CCOV12, CCOV21, CCOV22 C THE STARTING LOCATION IN THE WORK AREA FOR C THE COVARIANCES. C INTEGER CEVEN C THE STARTING LOCATION IN THE WORK AREA FOR C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C INTEGER CODD C THE STARTING LOCATION IN THE WORK AREA FOR C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(1,1,1) C A DUMMY ARRAY. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT = 1 THE PLOT IS PROVIDED. C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SPCF1, SPCF2 C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER W C THE STARTING LOCATION IN THE WORK AREA FOR C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL Y1(N) C THE FIRST TIME SERIES. C REAL Y2(N) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','S',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED (LAGMAX). C IF (NW.GE.1) THEN LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE ELSE LAGMAX = N - 1 END IF LAGMX1 = LAGMAX + 1 C ICCOV = LAGMAX + 1 JCCOV = 2 INLPPC = 1 JNLPPC = 1 M = 2 INDEX1 = 1 INDEX2 = 2 C C COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN) C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(9, 0, IO*4*NF, 0, 0, 0, 'S', + 7*LAGMAX+7+IO*8*NF, LDSMIN) C LY = N YMISS1 = 1.0E0 YMISS2 = 1.0E0 LPCV = 4*NF LW = LAGMAX + 1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0). C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN CCOV = 1 CEVEN = 1 CODD = 1 SPCF1 = 1 SPCF2 = 1 W = 1 C CCOV11 = 1 CCOV21 = 1 CCOV12 = 1 CCOV22 = 1 C ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE CCOV = STKGET(4*LAGMX1,IFP) CEVEN = STKGET(LAGMX1,IFP) CODD = STKGET(LAGMX1,IFP) SPCF1 = STKGET(NF,IFP) SPCF2 = STKGET(NF,IFP) W = STKGET(LW,IFP) C CCOV11 = CCOV CCOV21 = CCOV + LAGMX1 CCOV12 = CCOV21 + LAGMX1 CCOV22 = CCOV12 + LAGMX1 C IF (NPRT.EQ.0) THEN ISYM = W XAXIS = W YAXIS = W ELSE ISYM = STKGET(LPCV,2) XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) END IF END IF C WORK = W LWORK = LW C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, RSTAK(CCOV), NLPPC, + RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW, + LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM), + RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, + RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN, + LDSTAK, OPTION, N, INLPPC, JNLPPC, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSS (Y1, Y2, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)') END *BFSV SUBROUTINE BFSV(CCOV, INDEX1, INDEX2, N, LAGMAX, ICCOV, JCCOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH C COVARIANCES INPUT RATHER THAN ORIGINAL SERIES C (SHORT 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 + ICCOV,INDEX1,INDEX2,JCCOV,LAGMAX,N C C ARRAY ARGUMENTS REAL + CCOV(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS1,YMISS2 INTEGER + ICSPC2,INLPPC,IPHAS,IPRT,JNLPPC,LAGMX1,LAGMXU,LDSMIN, + LDSTAK,LPCV,LW,LY,M,NF,NPRT,NW C C LOCAL ARRAYS REAL + CEVEN(101),CODD(101),CSPC2(101,4),FREQ(101),PHAS(101,4), + SPCF1(101),SPCF2(101),W(101),XAXIS(404),Y1(1),Y2(1), + YAXIS(404) INTEGER + ISYM(404),LAGS(4),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,PARZEN,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(ICCOV,JCCOV,*) C THE COVARIANCES. C REAL CEVEN(101) C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CODD(101) C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(101,4) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISYM(404) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC. C INTEGER LAGMAX, LAGMXU C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(1,1,1) C A DUMMY ARRAY. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(101,4) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL SPCF1(101), SPCF2(101) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL W(101) C THE WINDOWS. C REAL XAXIS(404) C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YAXIS(404) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C THE MISSING VALUE CODES C REAL Y1(1) C THE FIRST TIME SERIES. C REAL Y2(1) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','V',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .TRUE. OPTION(4) = .FALSE. C M = 2 C INLPPC = 1 JNLPPC = 1 ICSPC2 = 101 IPHAS = 101 C LDSTAK = 0 LDSMIN = 0 C NF = 101 LW = 101 LY = N LPCV = 404 C C SET MAXIMUM LAG VALUE USED (LAGMXU) C SET NUMBER OF LAG WINDOW TRUCCATION POINTS (NW) C CALL SETLAG(N, LAGMXU) LAGMXU = MIN(LAGMXU,LAGMAX) NW = 4 C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, SPCF1, SPCF2, + NF, FMIN, FMAX, FREQ, N, NW, LAGMXU, LAGS, LAGMX1, W, LW, + DELTA, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, CODD, + CEVEN, W, LW, NMSUB, LDSMIN, LDSTAK, OPTION, N, INLPPC, + JNLPPC, LY) C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSV(CCOV, INDEX1, INDEX2, N, LAGMAX, ICCOV,', + ' JCCOV)') END *BFSVS SUBROUTINE BFSVS(CCOV, INDEX1, INDEX2, N, ICCOV, JCCOV, + NW, LAGS, NF, FMIN, FMAX, NPRT, CSPC2, ICSPC2, PHAS, IPHAS, + FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES BIVARIATE C FOURIER SPECTRUM ANALYSIS OF SERIES WITH C USER INPUT OF THE COVARIANCES RATHER THAN THE SERIES 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 REAL + FMAX,FMIN INTEGER + ICCOV,ICSPC2,INDEX1,INDEX2,IPHAS,JCCOV,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + CCOV(*),CSPC2(*),FREQ(*),PHAS(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS1,YMISS2 INTEGER + CEVEN,CODD,I,IFP,INLPPC,IO,IPRT,ISYM,JNLPPC,LAGMAX,LAGMX1, + LDSMIN,LPCV,LW,LWORK,LY,M,NALL0,SPCF1,SPCF2,W,WORK,XAXIS, + YAXIS C C LOCAL ARRAYS REAL + RSTAK(12),Y1(1),Y2(1) INTEGER + ISTAK(12),NLPPC(1,1,1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL BFSDRV,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL CCOV(ICCOV,JCCOV,*) C THE COVARIANCES. C INTEGER CEVEN C THE STARTING LOCATION IN THE WORK AREA FOR C THE SUMS OF THE AUTOCOVARIANCES FOR EACH LAG. C INTEGER CODD C THE STARTING LOCATION IN THE WORK AREA FOR C THE DIFFERENCES OF THE AUTOCOVARIANCES FOR EACH LAG. C REAL CSPC2(ICSPC2,NW) C THE SQUARED COHERENCY COMPONENT OF THE BIVARIATE SPECTRA. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VALUE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. C INTEGER ICSPC2 C THE FIRST DIMENSION OF THE ARRAY CSPC2. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INDEX1, INDEX2 C THE INDICES OF THE COVARIANCES OF THE TWO SERIES. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPHAS C THE FIRST DIMENSION OF THE ARRAY PHAS. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER JCCOV C THE SECOND DIMENSION OF THE ARRAY CCOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGMX1 C LAGMAX+1. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER LY C THE LENGTH OF THE VECTORS Y1 AND Y2. C INTEGER M C THE NUMBER OF SERIES FOR WHICH THE COVARIANCES WERE C COMPUTED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPC(1,1,1) C THE NUMBER OF OBSERVATIONS IN EACH COVARIANCE ESTIMATE C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT. C IF NPRT < 0 THE PLOT IS DECIBLES/LINEAR C IF NPRT = 0 THE PLOT IS SUPPRESSED. C IF NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL PHAS(IPHAS,NW) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SPCF1, SPCF2 C THE STARTING LOCATION IN THE WORK AREA FOR C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER W C THE STARTING LOCATION IN THE WORK AREA FOR C THE WINDOWS. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE VECTOR WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOTS. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMISS1, YMISS2 C DUMMY VARIABLES. C REAL Y1(1) C THE FIRST TIME SERIES. C REAL Y2(1) C THE SECOND TIME SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'B','F','S','V','S',' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .TRUE. OPTION(4) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED (LAGMAX). C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LAGMX1 = LAGMAX + 1 C M = 2 C C COMPUTE THE MINIMUM ALLOWABLE STACK AREA (LDSMIN) C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(8, 0, IO*4*NF, 0, 0, 0, 'S', + 3*LAGMAX+3+2*NF+IO*8*NF, LDSMIN) C INLPPC = 1 JNLPPC = 1 LY = N LPCV = 4*NF LW = LAGMAX + 1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING STACK ALLOCATIONS (NALL0). C SET THE STACK ALLOCATION TYPE (IFP) C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN CEVEN = 1 CODD = 1 SPCF1 = 1 SPCF2 = 1 W = 1 ISYM = W XAXIS = W YAXIS = W ELSE CEVEN = STKGET(LAGMX1,IFP) CODD = STKGET(LAGMX1,IFP) SPCF1 = STKGET(NF,IFP) SPCF2 = STKGET(NF,IFP) W = STKGET(LW,IFP) IF (NPRT.EQ.0) THEN ISYM = W XAXIS = W YAXIS = W ELSE ISYM = STKGET(LPCV,2) XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) END IF END IF C WORK = W LWORK = LW C C CALL THE CONTROLING ROUTINE FOR THE BIVARIATE SPECTRUM ROUTINES C CALL BFSDRV(Y1, Y2, YMISS1, YMISS2, CCOV, NLPPC, + RSTAK(SPCF1), RSTAK(SPCF2), NF, FMIN, FMAX, FREQ, N, NW, + LAGMAX, LAGS, LAGMX1, RSTAK(WORK), LWORK, DELTA, ISTAK(ISYM), + RSTAK(XAXIS), RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, ICCOV, + JCCOV, M, INDEX1, INDEX2, CSPC2, PHAS, ICSPC2, IPHAS, + RSTAK(CODD), RSTAK(CEVEN), RSTAK(W), LW, NMSUB, LDSMIN, + LDSTAK, OPTION, N, INLPPC, JNLPPC, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL BFSVS(CCOV, INDEX1, INDEX2, N, ICCOV, JCCOV,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + CSPC2, ICSPC2, PHAS, IPHAS, FREQ, LDSTAK)') END *CCFER SUBROUTINE CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE CCF FAMILY 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 + ICCOV,INLPPC,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN,LDSTAK, + LYFFT,M,N,NFFT LOGICAL + ISFFT,ISLONG C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERR(15) CHARACTER + LICCOV(8)*1,LINLPP(8)*1,LIYM(8)*1,LIYMFF(8)*1, + LJCCOV(8)*1,LJNLPP(8)*1,LLAGMX(8)*1,LLDS(8)*1, + LLGMX1(8)*1,LLYFFT(8)*1,LM(8)*1,LN(8)*1,LNFFT(8)*1, + LNM1(8)*1,LONE(8)*1,LTHREE(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR(15) C VALUES 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 ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. 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 INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYM, IYMFFT C THE FIRST DIMENSION OF THE ARRAYS YM AND YMFFT, RESPECTIVELY. C INTEGER JCCOV, JNLPPC C THE SECOND DIMENSIONS OF THE ARRAYS CCOV AND NLPPC, C RESPECTIVELY. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. 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 LICCOV(8), LINLPP(8), LIYM(8), LIYMFF(8), LJCCOV(8), C * LJNLPP(8), LLAGMX(8), LLDS(8), LLGMX1(8), LLYFFT(8), C * LM(8), LN(8), LNFFT(8), LNM1(8), LONE(8), LTHREE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER M C THE NUMBER OF SERIES BEING ANALYZED C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C C SET UP NAME ARRAYS C DATA + LICCOV(1), LICCOV(2), LICCOV(3), LICCOV(4), LICCOV(5), + LICCOV(6), LICCOV(7), LICCOV(8) /'I','C','C','O','V',' ',' ',' '/ DATA + LINLPP(1), LINLPP(2), LINLPP(3), LINLPP(4), LINLPP(5), + LINLPP(6), LINLPP(7), LINLPP(8) /'I','N','L','P','P','C',' ',' '/ DATA + LIYM(1), LIYM(2), LIYM(3), LIYM(4), LIYM(5), + LIYM(6), LIYM(7), LIYM(8) /'I','Y','M',' ',' ',' ',' ',' '/ DATA + LIYMFF(1), LIYMFF(2), LIYMFF(3), LIYMFF(4), LIYMFF(5), + LIYMFF(6), LIYMFF(7), LIYMFF(8) /'I','Y','M','F','F','T',' ',' '/ DATA + LJCCOV(1), LJCCOV(2), LJCCOV(3), LJCCOV(4), LJCCOV(5), + LJCCOV(6), LJCCOV(7), LJCCOV(8) /'J','C','C','O','V',' ',' ',' '/ DATA + LJNLPP(1), LJNLPP(2), LJNLPP(3), LJNLPP(4), LJNLPP(5), + LJNLPP(6), LJNLPP(7), LJNLPP(8) /'J','N','L','P','P','C',' ',' '/ DATA + LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5), + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ',' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5), + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+','1'/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ',' '/ DATA + LM(1), LM(2), LM(3), LM(4), LM(5), + LM(6), LM(7), LM(8) /'M',' ',' ',' ',' ',' ',' ',' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), + LN(6), LN(7), LN(8) /'N',' ',' ',' ',' ',' ',' ',' '/ DATA + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), + LNM1(6), LNM1(7), LNM1(8) /'(','N','-','1',')',' ',' ',' '/ DATA + LNFFT(1), LNFFT(2), LNFFT(3), LNFFT(4), LNFFT(5), + LNFFT(6), LNFFT(7), LNFFT(8) /'N','F','F','T',' ',' ',' ',' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), + LONE(6), LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/ DATA + LTHREE(1), LTHREE(2), LTHREE(3), LTHREE(4), LTHREE(5), + LTHREE(6), LTHREE(7), LTHREE(8) /'T','H','R','E','E',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. DO 10 I = 1, 15 ERR(I) = .FALSE. 10 CONTINUE C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR(1), LTHREE) C CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERR(2), LONE) C IF (.NOT.ERR(1)) THEN C CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(3), LONE, + LNM1) C IF (ISFFT) THEN IF (ISLONG) THEN CALL EISGE(NMSUB, LIYMFF, IYMFFT, NFFT, 3, HEAD, ERR(4), + LNFFT) ELSE CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 3, HEAD, ERR(4), + LNFFT) END IF ELSE CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR(4), LN) END IF C IF (.NOT.ERR(3)) THEN C IF (ISLONG) THEN CALL EISGE(NMSUB, LICCOV, ICCOV, LAGMAX+1, 3, HEAD, ERR(5), + LLGMX1) CALL EISGE(NMSUB, LJCCOV, JCCOV, M, 3, HEAD, ERR(6), + LLGMX1) CALL EISGE(NMSUB, LINLPP, INLPPC, LAGMAX+1, 3, HEAD, ERR(7), + LLGMX1) CALL EISGE(NMSUB, LJNLPP, JNLPPC, M, 3, HEAD, ERR(8), + LLGMX1) END IF C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(9), LLDS) C END IF END IF C DO 20 I = 1, 15 IF (ERR(I)) IERR = 1 20 CONTINUE C RETURN C END *CCF SUBROUTINE CCF (Y1, Y2, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS OF TWO TIME SERIES (SHORT CALL). 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 + N C C ARRAY ARGUMENTS REAL + Y1(*),Y2(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + Y1MEAN,Y1SD,Y2MEAN,Y2SD INTEGER + ICCOV,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN, + LDSTAK,LYFFT,M,NFFT LOGICAL + ISFFT,ISLONG C C LOCAL ARRAYS REAL + CCOV(101,2,2),RHOC(201),SDRHOC(201) INTEGER + NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ACVF,CCFER,CCFMN,CCFOUT,IPRINT,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(101, 2, 2) C THE CCVF MATRIX. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYM C THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER LAGMAX C THE NUMBER OF AUTOCORRELATIONS DESIRED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YM. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NDUM(1) C A DUMMY DIMENSIONED VARIABLE. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C REAL RHOC(201) C THE ARRAY CONTAINING THE CCF. C REAL SDRHOC(201) C THE ARRAY CONTAINING THE SD OF THE CCF. C REAL Y1(N), Y1MEAN, Y1SD C THE FIRST SERIES, AND ITS MEAN AND STANDARD DEVIATION. C REAL Y2(N), Y2MEAN, Y2SD C THE SECOND SERIES, AND ITS MEAN AND STANDARD DEVIATION. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 ICCOV = 101 INLPPC = 1 IYM = N JCCOV = 2 JNLPPC = 1 LDSMIN = 0 LDSTAK = 0 LAGMAX = 1 LYFFT = N + LAGMAX IYMFFT = LYFFT M = 2 NFFT = N ISFFT = .FALSE. ISLONG = .FALSE. C C CALL ERROR CHECKING ROUTINES C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET THE MAXIMUM LAG VALUE TO BE USED. C CALL SETLAG (N, LAGMAX) C C COMPUTE THE SERIES ACVF AND SD C CALL ACVF (Y1, N, Y1MEAN, CCOV(1,1,1), LAGMAX, 101) Y1SD = SQRT(CCOV(1,1,1) * N / (N-1)) C CALL ACVF (Y2, N, Y2MEAN, CCOV(1,2,2), LAGMAX, 101) Y2SD = SQRT(CCOV(1,2,2) * N / (N-1)) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0) + CALL CCFMN (Y1, Y2, N, LAGMAX, 2*LAGMAX+1, CCOV(1,1,1), + CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101, Y1MEAN, Y2MEAN, + RHOC, SDRHOC, 1) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL CCFOUT (1, Y1MEAN, Y1SD, N, N, 2, Y2MEAN, Y2SD, N, + N, LAGMAX, 2*LAGMAX+1, RHOC, SDRHOC, .FALSE., NDUM, NDUM, 1, + 0.0E0, 0.0E0, .FALSE.) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 27H CALL CCF (Y1, Y2, N)) END *CCFF SUBROUTINE CCFF (YFFT1, YFFT2, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS OF TWO TIME SERIES USING THE SINGLETON FFT C (SHORT CALL). 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT1(*),YFFT2(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + Y1MEAN,Y1SD,Y2MEAN,Y2SD INTEGER + ICCOV,IFP,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX, + LDSMIN,M,NALL0,NFFT,WORK LOGICAL + ISFFT,ISLONG C C LOCAL ARRAYS REAL + CCOV(101,2,2),RHOC(201),RSTAK(12),SDRHOC(201),STAK(12) INTEGER + NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVFF,CCFER,CCFMNF,CCFOUT,FFTLEN,IPRINT,LDSCMP,SETLAG, + STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),STAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(101, 2, 2) C THE CCVF MATRIX. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE NUMBER OF LOCATIONS IN THE ARRAY YFFT1 AND YFFT2. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YM. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER NDUM(1) C A DUMMY ARRAY. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C REAL RHOC(201) C THE ARRAY CONTAINING THE CCF. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SDRHOC(201) C THE ARRAY CONTAINING THE SD OF THE CCF. C REAL STAK(12) C THE USED VERSION OF THE /CSTAK/ WORK AREA. C INTEGER WORK C THE STARTING LOCATION IN DSTAK FOR C THE WORK ARRAY NEEDED BY THE FFT. C REAL YFFT1(N), Y1MEAN, Y1SD C THE FIRST SERIES, AND ITS MEAN AND STANDARD DEVIATION. C REAL YFFT2(N), Y2MEAN, Y2SD C THE SECOND SERIES, AND ITS MEAN AND STANDARD DEVIATION. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', 'F', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 ICCOV = 101 INLPPC = 1 IYM = N JCCOV = 2 JNLPPC = 1 LAGMAX = 1 IYMFFT = LYFFT M = 2 NFFT = N ISFFT = .TRUE. ISLONG = .FALSE. C IF (N.GE.3) THEN C C SET LARGEST LAG VALUE TO BE USED C CALL SETLAG(N, LAGMAX) C C SET LENGTH OF THE EXTENDED SERIES C CALL FFTLEN(N+LAGMAX, 4, NFFT) END IF C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C WORK = STKGET(NFFT, IFP) C IF (IERR.EQ.0) THEN C C COMPUTE THE SERIES ACVF AND SD C CALL ACVFF (YFFT1, N, NFFT, Y1MEAN, CCOV(1,1,1), LAGMAX, 101, + LYFFT, STAK(WORK), NFFT) Y1SD = SQRT(CCOV(1,1,1) * N / (N-1)) C CALL ACVFF (YFFT2, N, NFFT, Y2MEAN, CCOV(1,2,2), LAGMAX, 101, + LYFFT, STAK(WORK), NFFT) Y2SD = SQRT(CCOV(1,2,2) * N / (N-1)) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0) + CALL CCFMNF (YFFT1, YFFT2, N, NFFT, LAGMAX, 2*LAGMAX+1, + CCOV(1,1,1), CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101, + RHOC, SDRHOC, 1, LYFFT, STAK(WORK), NFFT) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL CCFOUT (1, Y1MEAN, Y1SD, N, N, 2, Y2MEAN, Y2SD, N, + N, LAGMAX, 2*LAGMAX+1, RHOC, SDRHOC, .FALSE., NDUM, NDUM, + 1, 0.0E0, 0.0E0, .FALSE.) END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CCFF (YFFT1, YFFT2, N, LYFFT, LDSTAK)') END *CCFFS SUBROUTINE CCFFS (YMFFT, N, M, IYMFFT, LAGMAX, + CCOV, ICCOV, JCCOV, NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES USING THE C SINGLETON FFT (LONG CALL). 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 + ICCOV,IYMFFT,JCCOV,LAGMAX,LDSTAK,M,N,NPRT C C ARRAY ARGUMENTS REAL + CCOV(*),YMFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,IFP,INLPPC,IO,IPRT,IYM,J,JNLPPC,K,LDSMIN,LYFFT,NALL0, + NFFT,RHOC,SDRHOC,WORK,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK LOGICAL + ISFFT,ISLONG,NEWPG C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVFF,CCFER,CCFMNF,CCFOUT,FFTLEN,IPRINT,LDSCMP,STKCLR, + STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C STATEMENT FUNCTIONS INTEGER + I2,I3 C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(ICCOV, JCCOV, M) C THE CROSS COVARIANCE MATRIX. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER PRINTED OUTPUT IS DESIRED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYM C THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER I2 C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YMFFT C INTEGER I3 C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV C INTEGER J C THE INDEX OF -SERIES 1- IN THE ARRAY YMFFT. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER K C THE INDEX OF -SERIES 2- IN THE ARRAY YMFFT. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE NUMBER OF LOCATIONS IN EACH COLUMN OF YMFFT ALLOWED FOR C THE EXTENDED SERIES. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YMFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER NDUM(1) C A DUMMY DMENSIONED ARRAY. C LOGICAL NEWPG C AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE C IS APPROPRIATE FOR THE OUTPUT. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS GIVEN. C INTEGER RHOC C THE STARTING LOCATION IN STAK/DSTAK OF THE ARRAY RHOC. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHOC C THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC. C INTEGER WORK C THE STARGING LOCATION IN DSTAK OF C THE WORK VECTOR NEEDED BY THE FFT. C INTEGER YMEAN, YMEANJ, YMEANK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C MEANS OF EACH OF THE SERIES, AND THE LOCATION IN C THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES, C RESPECTIVELY. C REAL YMFFT(IYMFFT, M) C THE MATRIX CONTAINING THE OBSERVED TIME SERIES C INTEGER YSD, YSDJ, YSDK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE C LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF C THE JTH AND KTH SERIES, RESPECTIVELY. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', 'F', 'S', ' '/ C I2(I,J) = I + (J-1)*IYMFFT I3(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV C C SET UP FOR ERROR CHECKING C IERR = 0 INLPPC = ICCOV IYM = IYMFFT JNLPPC = JCCOV LYFFT = IYMFFT M = 2 ISFFT = .TRUE. ISLONG = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 C C SET LENGTH OF EXTENDED SERIES C IF ((N.GE.3) .AND. (LAGMAX.GE.1)) THEN CALL FFTLEN (N+LAGMAX, 4, NFFT) ELSE NFFT = N END IF C CALL LDSCMP(3+2*IO, 0, 0, 0, 0, 0, 'S', + 2*M+NFFT+IO*(4*LAGMAX+2), LDSMIN) C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C YMEAN = STKGET(M, IFP) YSD = STKGET(M, IFP) IF (NPRT.EQ.0) THEN RHOC = YSD SDRHOC = YSD ELSE RHOC = STKGET(2*LAGMAX+1, IFP) SDRHOC = STKGET(2*LAGMAX+1, IFP) END IF WORK = STKGET(NFFT, IFP) C IF (IERR.EQ.0) THEN C C BEGIN LOOP FOR COMPUTATIONS C NEWPG = .FALSE. C DO 40 K = 1, M C YMEANK = YMEAN + K - 1 YSDK = YSD + K - 1 C CALL ACVFF (YMFFT(I2(1,K)), N, NFFT, RSTAK(YMEANK), + CCOV(I3(1,K,K)), LAGMAX, ICCOV, LYFFT, + RSTAK(WORK), NFFT) RSTAK(YSDK) = SQRT(CCOV(I3(1,K,K)) * N / (N - 1)) C IF ((K-1).LE.0) GO TO 40 C DO 30 J = 1, (K-1) C YMEANJ = YMEAN + J - 1 YSDJ = YSD + J - 1 C CALL CCFMNF(YMFFT(I2(1,J)), YMFFT(I2(1,K)), + N, NFFT, LAGMAX, 2*LAGMAX+1, + CCOV(I3(1,J,J)), CCOV(I3(1,K,K)), + CCOV(I3(1,J,K)), CCOV(I3(1,K,J)), + ICCOV, RSTAK(RHOC), RSTAK(SDRHOC), NPRT, + LYFFT, RSTAK(WORK), NFFT) C IF (NPRT .EQ. 0) GO TO 30 C C CALL ROUTINE TO PRINT OUT CORRELATIONS C CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N, N, K, + RSTAK(YMEANK), RSTAK(YSDK), N, N, LAGMAX, 2*LAGMAX+1, + RSTAK(RHOC), RSTAK(SDRHOC), .FALSE., NDUM, NDUM, 1, + 0.0E0, 0.0E0, NEWPG) C NEWPG = .TRUE. C 30 CONTINUE 40 CONTINUE END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CCFFS (YMFFT, N, M, IYMFFT,'/ + ' + LAGMAX, CCOV, ICCOV, JCCOV, NPRT, LDSTAK)') END *CCFLST SUBROUTINE CCFLST (RHOC, SDRHOC, NLPP12, NLPP21, LAGMAX, LCCOV, + NCC, IFMISS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE ACTUALLY LISTS THE CROSS CORRELATIONS AND THEIR C STANDARD ERRORS, AND MISCELLANEOUS SUMMARY INFORMATION. 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 + LAGMAX,LCCOV,NCC LOGICAL + IFMISS C C ARRAY ARGUMENTS REAL + RHOC(*),SDRHOC(*) INTEGER + NLPP12(*),NLPP21(*) C C LOCAL SCALARS REAL + FPLM INTEGER + I,I1,IMAX,IMIN,IPRT,K,K0,K1,LAGN,NPERL C C LOCAL ARRAYS REAL + RLST(12),SDRLST(12) INTEGER + LAG(12),NLPLST(12) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN,MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE. C LOGICAL IFMISS C THE INDICATOR VARIABLE USED TO DETERMINE C WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT. C INTEGER IMAX, IMIN C THE INDEX VALUES OF THE FIRST AND LAST OBSERVATION C TO BE PRINTED PER LINE C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT C INTEGER I1 C AN INDEX VARIABLE. C INTEGER K, K0, K1 C INDEX VARIABLES. C INTEGER LAG(12) C THE LAG VALUE OF THE CORRELATION BEING PRINTED. C INTEGER LAGMAX C THE LARGEST LAG VALUE TO BE USED. C INTEGER LAGN C THE NUMBER OF LAG VALUES TO BE PRINTED PER LINE. C INTEGER LCCOV C THE NUMBER OF LOCATIONS ALLOWED FOR STORING THE NLPPC. C INTEGER NCC C THE NUMBER OF CROSS CORRELATIONS COMPUTED (FROM -LAGMAX C TO +LAGMAX). C INTEGER NLPLST(12) C THE ARRAY WHICH CONTAINS THE VALUES OF NLPPC TO BE PRINTED C ON EACH LINE, ORDERED PROPERLY. C INTEGER NLPP12(LCCOV), NLPP21(LCCOV) C THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE EACH C CCVF AT EACH LAG. C INTEGER NPERL C THE NUMBER OF VALUES TO BE PRINTED PER LINE. C REAL RHOC(NCC) C THE ARRAY IN WHICH THE AUTOCORRELATIONS OR PARTIAL C AUTOCORRELATIONS WILL BE PASSED TO THIS ROUTINE. C REAL RLST(12) C THE ARRAY WHICH CONTAINS THE VALUES OF RHO TO BE PRINTED C ON EACH LINE, ORDERED PROPERLY. C REAL SDRHOC(NCC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C REAL SDRLST(12) C THE ARRAY WHICH CONTAINS THE VALUES OF SDRHO TO BE PRINTED C ON EACH LINE, ORDERED PROPERLY. C C CALL IPRINT(IPRT) NPERL = 12 C K0 = LAGMAX + 1 C LAGN = MOD(LAGMAX, NPERL) IF (LAGN .EQ. 0) LAGN = NPERL I1 = LAGN + 1 C DO 20 I = I1, K0, NPERL DO 10 K = 1, LAGN LAG(K) = I - K0 - K K1 = I - K RLST(K) = RHOC(K1) SDRLST(K) = SDRHOC(K1) IF (.NOT. IFMISS) GO TO 10 K1 = K0 - K1 NLPLST(K) = NLPP21(K1+1) 10 CONTINUE WRITE(IPRT, 1000) (LAG(K), K = 1, LAGN) WRITE(IPRT, 1001) (RLST(K), K = 1, LAGN) WRITE(IPRT, 1002) (SDRLST(K), K = 1, LAGN) IF (IFMISS) WRITE(IPRT, 1003) (NLPLST(K), K = 1, LAGN) LAGN = NPERL 20 CONTINUE C LAG(1) = 0 WRITE(IPRT, 1000) LAG(1) WRITE(IPRT, 1001) RHOC(K0) WRITE(IPRT, 1002) SDRHOC(K0) IF (IFMISS) WRITE(IPRT, 1003) NLPP12(1) C DO 40 I = 1, LAGMAX, NPERL IMIN = I + K0 IMAX = MIN(IMIN + NPERL - 1, 2*LAGMAX+1) LAGN = IMAX - IMIN + 1 DO 30 K = 1, LAGN LAG(K) = I - 1 + K 30 CONTINUE WRITE(IPRT, 1000) (LAG(K), K = 1, LAGN) WRITE(IPRT, 1001) (RHOC(K), K = IMIN, IMAX) WRITE(IPRT, 1002) (SDRHOC(K), K = IMIN, IMAX) IF (.NOT. IFMISS) GO TO 40 IMIN = I IMAX = MIN(I + NPERL - 1, LAGMAX) WRITE (IPRT,1003) (NLPP12(K+1), K=IMIN,IMAX) 40 CONTINUE C FPLM = R1MACH(2) C IF (SDRHOC(1).EQ.FPLM .OR. SDRHOC(2*LAGMAX+1).EQ.FPLM) + WRITE(IPRT, 1004) FPLM C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/19H LAG , 12(1X, I6)) 1001 FORMAT( 19H CCF , 12(2X, F5.2)) 1002 FORMAT( 19H STANDARD ERROR , 12(2X, F5.2)) 1003 FORMAT( 19H NO. OF OBS. USED , 12(1X, I6)) 1004 FORMAT(///5X, F5.2, 38H INDICATES VALUE COULD NOT BE COMPUTED, + 21H DUE TO MISSING DATA.) END *CCFM SUBROUTINE CCFM (Y1, Y1MISS, Y2, Y2MISS, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS OF TWO TIME SERIES WITH MISSING OBSERVATIONS C (SHORT CALL). 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 REAL + Y1MISS,Y2MISS INTEGER + N C C ARRAY ARGUMENTS REAL + Y1(*),Y2(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + Y1MEAN,Y1SD,Y2MEAN,Y2SD INTEGER + ICCOV,INLPPC,IPRT,IYM,IYMFFT,JCCOV,JNLPPC,LAGMAX,LDSMIN, + LDSTAK,LGLST1,LGLST2,LYFFT,M,NFFT,NUSED1,NUSED2 LOGICAL + ISFFT,ISLONG C C LOCAL ARRAYS REAL + CCOV(101,2,2),RHOC(201),SDRHOC(201) INTEGER + NLPPC(101,2,2) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ACVFM,CCFER,CCFMNM,CCFOUT,IPRINT,SETLAG C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(101, 2, 2) C THE ARRAY USED FOR THE CCVF ESTIMATES. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYM C THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER LAGMAX C THE NUMBER OF AUTOCORRELATIONS DESIRED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LGLST1, LGLST2 C THE LAG VALUE OF THE LAST ACVF WHICH COULD BE COMPUTED C FOR SERIES 1 AND 2, RESPECTIVELY, BEFORE MISSING DATA C CAUSED A MISSING ACVF. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YM. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPC(101, 2, 2) C THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE THE CCVF. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NUSED1, NUSED2 C THE NUMBER OF ACTIVE (NON MISSING) OBSERVATIONS IN SERIES C 1 AND 2, RESPECTIVELY. C REAL RHOC(201) C THE CCF ESTIMATES. C REAL SDRHOC(201) C THE ARRAY CONTAINING THE SD OF THE CCFM. C REAL Y1(N), Y1MEAN, Y1MISS, Y1SD C THE FIRST SERIES, AND ITS MEAN, MISSING VALUE CODE AND C STANDARD DEVIATION. C REAL Y2(N), Y2MEAN, Y2MISS, Y2SD C THE SECOND SERIES, AND ITS MEAN, MISSING VALUE CODE AND C STANDARD DEVIATION. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', 'M', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 ICCOV = 101 INLPPC = 101 IYM = N JCCOV = 2 JNLPPC = 2 LDSMIN = 0 LDSTAK = 0 LAGMAX = 1 LYFFT = N + LAGMAX IYMFFT = LYFFT M = 2 NFFT = N ISFFT = .FALSE. ISLONG = .FALSE. C C CALL ERROR CHECKING ROUTINES C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET THE MAXIMUM LAG VALUE TO BE USED. C CALL SETLAG (N, LAGMAX) C C COMPUTE THE SERIES ACVF AND SD C CALL ACVFM (Y1, Y1MISS, N, Y1MEAN, CCOV(1,1,1), LAGMAX, LGLST1, + NLPPC(1,1,1), 101) C NUSED1 = NLPPC(1,1,1) Y1SD = SQRT(CCOV(1,1,1) * N / (NUSED1-1)) C CALL ACVFM (Y2, Y2MISS, N, Y2MEAN, CCOV(1,2,2), LAGMAX, LGLST2, + NLPPC(1,2,2), 101) C NUSED2 = NLPPC(1,2,2) Y2SD = SQRT(CCOV(1,2,2) * N / (NUSED2-1)) C C CALL ROUTINE FOR MAIN AUTOCORRELATION COMPUTATIONS. C IF (CCOV(1,1,1)*CCOV(1,2,2) .NE. 0.0E0) + CALL CCFMNM (Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, 201, + CCOV(1,1,1), + CCOV(1,2,2), CCOV(1,1,2), CCOV(1,2,1), 101, NLPPC(1,1,1), + NLPPC(1,2,2), NLPPC(1,1,2), NLPPC(1,2,1), 101, Y1MEAN, Y2MEAN, + RHOC, SDRHOC, 1, MIN(LGLST1, LGLST2)) C C CALL ROUTINE TO PRINT OUT AUTOCORRELATIONS C CALL CCFOUT (1, Y1MEAN, Y1SD, N, NUSED1, 2, Y2MEAN, Y2SD, N, + NUSED2, LAGMAX, 201, RHOC, SDRHOC, .TRUE., NLPPC(1,1,2), + NLPPC(1,2,1), 101, Y1MISS, Y2MISS, .FALSE.) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 44H CALL CCFM (Y1, YMISS1, Y2, YMISS2, N)) END *CCFMN SUBROUTINE CCFMN (Y1, Y2, N, LAGMAX, NCC, CCOV11, CCOV22, CCOV12, + CCOV21, LCCOV, Y1MEAN, Y2MEAN, RHOC, SDRHOC, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND C THEIR STANDARD ERRORS. 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 REAL + Y1MEAN,Y2MEAN INTEGER + LAGMAX,LCCOV,N,NCC,NPRT C C ARRAY ARGUMENTS REAL + CCOV11(LCCOV),CCOV12(LCCOV),CCOV21(LCCOV),CCOV22(LCCOV), + RHOC(NCC),SDRHOC(NCC),Y1(N),Y2(N) C C LOCAL SCALARS REAL + FAC INTEGER + I,I0,IM,IP C C EXTERNAL SUBROUTINES EXTERNAL CCFSD,CCVF C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV11(LCCOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES C FOR THE FIRST SERIES IS STORED. C REAL CCOV12(LCCOV), CCOV21(LCCOV) C THE ARRAYS IN WHICH THE CROSS COVARIANCE FUNCTION C ESTIMATES FOR THE FIRST SERIES LAGGED BEHIND THE SECOND C AND VISA VERSA, ARE STORED. C REAL CCOV22(LCCOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES C FOR THE SECOND SERIES IS STORED. C REAL FAC C THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE C AUTOCOVARIANCES AT LAG ZERO. C INTEGER I C THE INDEXING VARIABLE FOR THE LAG VALUE. C INTEGER IM, IP, I0 C THE LOCATIONS IN THE CCF RELATED ARRAYS C OF THE LAG -I, I, AND 0, RESPECTIVELY. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE AT WHICH THE CCVF IS TO BE COMPUTED. C INTEGER LCCOV C THE DIMENSION OF THE COVARIANCE RELATED ARRAYS. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NCC C THE NUMBER OF CCF COMPUTED. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO CONTROL COMPUTATIONS NEEDED C ONLY FOR PRINTED OUTPUT. C REAL RHOC(NCC) C THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED C REAL SDRHOC(NCC) C THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS. C ARE STORED C REAL Y1(N), Y1MEAN C THE FIRST SERIES, AND ITS MEAN. C REAL Y2(N), Y2MEAN C THE SECOND SERIES, AND ITS MEAN. C C COMPUTE THE CROSS CORRELATIONS. C CALL CCVF(Y1, Y2, N, LAGMAX, Y1MEAN, Y2MEAN, CCOV12, CCOV21, + LCCOV) C IF (NPRT .EQ. 0 .OR. CCOV11(1)*CCOV22(1) .EQ. 0.0E0) RETURN C FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1)) C I0 = LAGMAX + 1 RHOC(I0) = CCOV12(1) * FAC DO 10 I = 1, LAGMAX IP = I0 + I RHOC(IP) = CCOV12(I+1) * FAC C IM = I0 - I RHOC(IM) = CCOV21(I+1) * FAC 10 CONTINUE C C COMPUTE STANDARD ERROR OF THE CROSSCORRELATIONS. C CALL CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, LCCOV) C RETURN END *CCFMNF SUBROUTINE CCFMNF (Y1, Y2, N, NFFT, LAGMAX, NCC, CCOV11, CCOV22, + CCOV12, CCOV21, LCCOV, RHOC, SDRHOC, NPRT, LYFFT, WORK, LWORK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND C THEIR STANDARD ERRORS OF A TIME SERIES USING A FFT. 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 + LAGMAX,LCCOV,LWORK,LYFFT,N,NCC,NFFT,NPRT C C ARRAY ARGUMENTS REAL + CCOV11(LCCOV),CCOV12(LCCOV),CCOV21(LCCOV),CCOV22(LCCOV), + RHOC(NCC),SDRHOC(NCC),WORK(LWORK),Y1(LYFFT),Y2(LYFFT) C C LOCAL SCALARS REAL + FAC INTEGER + I,I0,IM,IP C C EXTERNAL SUBROUTINES EXTERNAL CCFSD,CCVFF C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV11(LCCOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES C FOR THE FIRST SERIES IS STORED. C REAL CCOV12(LCCOV), CCOV21(LCCOV) C THE ARRAYS IN WHICH THE CROSS COVARIANCE FUNCTION C ESTIMATES FOR THE FIRST SERIES LAGGED BEHIND THE SECOND C AND VISA VERSA, ARE STORED. C REAL CCOV22(LCCOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCE FUNCTION ESTIMATES C FOR THE SECOND SERIES IS STORED. C REAL FAC C THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE C AUTOCOVARIANCES AT LAG ZERO. C INTEGER I C THE INDEXING VARIABLE FOR THE LAG VALUE. C INTEGER IM, IP, I0 C THE LOCATIONS IN THE CCF RELATED ARRAYS C OF THE LAG -I, I, AND 0, RESPECTIVELY. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LCCOV C THE DIMENSION OF THE COVARANCE ARRAYS. C INTEGER LWORK C THE DIMENSION OF THE WORK ARRAY. C INTEGER LYFFT C THE DIMENSION OF THE DATA ARRAYS. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NCC C THE NUMBER OF CROSS CORRELATIONS COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO CONTROL COMPUTATIONS NEEDED C ONLY FOR PRINTED OUTPUT. C REAL RHOC(NCC) C THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED C REAL SDRHOC(NCC) C THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS. C ARE STORED. C REAL WORK(LWORK) C THE WORK ARRAY. C REAL Y1(LYFFT), Y2(LYFFT) C THE VECTORS CONTAINING THE OBSERVED SERIES C C COMPUTE THE CROSS CORRELATIONS. C CALL CCVFF (Y1, Y2, N, NFFT, LAGMAX, CCOV12, CCOV21, LCCOV, LYFFT, + WORK, LWORK) C IF (NPRT .EQ. 0 .OR. CCOV11(1)*CCOV22(1) .EQ. 0.0E0) RETURN C FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1)) C I0 = LAGMAX + 1 RHOC(I0) = CCOV12(1) * FAC DO 10 I = 1, LAGMAX IP = I0 + I RHOC(IP) = CCOV12(I+1) * FAC C IM = I0 - I RHOC(IM) = CCOV21(I+1) * FAC 10 CONTINUE C C COMPUTE STANDARD ERROR OF THE CROSSCORRELATIONS. C CALL CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, LCCOV) C RETURN END *CCFMNM SUBROUTINE CCFMNM (Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, NCC, + CCOV11, CCOV22, CCOV12, CCOV21, ICCOV, NLPP11, NLPP22, + NLPP12, NLPP21, INLPPC, Y1MEAN, Y2MEAN, RHOC, SDRHOC, NPRT, + LAGLST) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING CROSS CORRELATIONS AND C THEIR STANDARD ERRORS WHEN MISSING DATA ARE INVOLVED. 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 REAL + Y1MEAN,Y1MISS,Y2MEAN,Y2MISS INTEGER + ICCOV,INLPPC,LAGLST,LAGMAX,N,NCC,NPRT C C ARRAY ARGUMENTS REAL + CCOV11(ICCOV),CCOV12(ICCOV),CCOV21(ICCOV),CCOV22(ICCOV), + RHOC(NCC),SDRHOC(NCC),Y1(N),Y2(N) INTEGER + NLPP11(INLPPC),NLPP12(INLPPC),NLPP21(INLPPC), + NLPP22(INLPPC) C C LOCAL SCALARS REAL + FAC,FPLM INTEGER + I,I0,IM,IP C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL CCFSDM,CCVFM C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV11(ICCOV), CCOV12(ICCOV) C REAL CCOV21(ICCOV), CCOV22(ICCOV) C THE ARRAY CONTAINING THE AUTOCOVARIANCE AND CROSS COVARIANCE C ESTIMATES FOR SERIES 1 AND 2. C REAL FAC C THE INVERSE OF THE SQUARE ROOT OF THE PRODUCT OF THE C AUTOCOVARIANCES AT LAG ZERO. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C THE INDEXING VARIABLE FOR THE LAG. C INTEGER ICCOV C THE DIMENSION OF THE COVARIANCE VECTORS. C INTEGER IM C THE LOCATIONS IN THE VARIOUS CCF RELATED ARRAYS OF LAG -I. C INTEGER INLPPC C THE DIMENSION OF THE LAGGED PRODUCT PAIR COUNT VECTORS. C INTEGER IP C THE LOCATION IF THE VARIOUS CCF RELATED ARRAYS OF LAG I. C INTEGER I0 C THE LOCATION IF THE VARIOUS CCF RELATED ARRAYS OF LAG 0. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF EITHER C SERIES 1 OR 2 NOT TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NCC C THE NUMBER OF CROSS CORRELATIONS TO BE COMPUTED. C INTEGER NLPP11(INLPPC), NLPP12(INLPPC), NLPP21(INLPPC), C + NLPP22(INLPPC) C THE NUMBERS OF LAGGED PRODUCT PAIRS USED TO COMPUTE C THE AUTOCOVARIANCE AND CROSS COVARIANCE ESTIMATES. C INTEGER NPRT C THE VARIABLE USED TO CONTROL PRINTED OUTPUT. C REAL RHOC(NCC) C THE ARRAY IN WHICH THE AUTO AND CROSS CORRELATIONS ARE STORED C REAL SDRHOC(NCC) C THE ARRAY CONTAINING THE STD. ERRORS OF THE CROSS CORRELATIONS. C ARE STORED C REAL Y1(N), Y1MEAN, Y1MISS C THE FIRST SERIES, AND ITS MEAN, AND MISSING VALUE CODE. C REAL Y2(N), Y2MEAN, Y2MISS C THE SECOND SERIES, AND ITS MEAN, AND MISSING VALUE CODE. C FPLM = R1MACH(2) C C COMPUTE AUTOCORRELATIONS AND STANDARD DEVIATION OF THE SERIES. C CALL CCVFM(Y1, Y1MISS, Y2, Y2MISS, N, LAGMAX, Y1MEAN, Y2MEAN, + CCOV12, CCOV21, ICCOV, NLPP12, NLPP21) C IF (NPRT .EQ. 0 .OR. NLPP11(1) .EQ. 0) RETURN IF (CCOV11(1) *CCOV22(1) .EQ. 0.0E0) RETURN C FAC = 1.0E0 / SQRT(CCOV11(1) * CCOV22(1)) C I0 = LAGMAX + 1 RHOC(I0) = FPLM IF (NLPP12(1).GE.1) RHOC(I0) = CCOV12(1) * FAC C DO 10 I = 1, LAGMAX IP = I0 + I RHOC(IP) = FPLM IF (NLPP12(I+1).GE.1) RHOC(IP) = CCOV12(I+1) * FAC C IM = I0 - I RHOC(IM) = FPLM IF (NLPP21(I+1).GE.1) RHOC(IM) = CCOV21(I+1) * FAC 10 CONTINUE C C COMPUTE STANDARD ERROR OF AUTOCORRELATIONS. C CALL CCFSDM (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, LAGLST, N, + NLPP12, NLPP21, ICCOV, INLPPC) C RETURN END *CCFMS SUBROUTINE CCFMS (YM, YMMISS, N, M, IYM, LAGMAX, CCOV, + CMISS, ICCOV, JCCOV, NLPPC, INLPPC, JNLPPC, NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES (LONG CALL). 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 REAL + CMISS INTEGER + ICCOV,INLPPC,IYM,JCCOV,JNLPPC,LAGMAX,LDSTAK,M,N,NPRT C C ARRAY ARGUMENTS REAL + CCOV(*),YM(*),YMMISS(*) INTEGER + NLPPC(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + FPLM INTEGER + I,IFP,IO,IPRT,IYMFFT,J,K,LDSMIN,LGLST,LGLSTJ,LGLSTK,LYFFT, + NALL0,NFFT,RHOC,SDRHOC,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK LOGICAL + ISFFT,ISLONG,NEWPG C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + STKGET,STKST EXTERNAL R1MACH,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVFM,CCFER,CCFMNM,CCFOUT,IPRINT,LDSCMP,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C STATEMENT FUNCTIONS INTEGER + I2,I3C,I3N C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(ICCOV, JCCOV, M) C THE CROSS COVARIANCE MATRIX. C REAL CMISS C THE MISSING VALUE CODE FOR THE CCVF ESTIMATES. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER PRINTED OUTPUT IS DESIRED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IYM C THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER I2 C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YM C INTEGER I3C C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV C INTEGER I3N C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN NLPPC C INTEGER J C THE INDEX OF -SERIES 1- IN THE ARRAY YM. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER K C THE INDEX OF -SERIES 2- IN THE ARRAY YM. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LGLST, LGLSTJ, LGLSTK C THE STARTING LOCATION IN ISTAK FOR THE ARRAY LGLST, C AND THE LOCATIONS IN LGLST IN EHICH THE NUMBER OF THE C LAG OF THE LAST ACVF WHICH COULD BE COMPUTED FOR SERIES C J AND K, RESPECTIVELY, BEFORE A MISSNG ACVF (DUE TO MISSING C DATA). C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YM. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C LOGICAL NEWPG C AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE C IS APPROPRIATE FOR THE OUTPUT. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPC(INLPPC, JNLPPC, M) C THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS C USED TO COMPUTE EACH ACVF ESTIMATE. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS GIVEN. C INTEGER RHOC C THE STARTING LOCATION IN DSTAK OF THE ARRAY RHOC. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHOC C THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC. C REAL YM(IYM, M) C THE MATRIX CONTAINING THE OBSERVED TIME SERIES C INTEGER YMEAN, YMEANJ, YMEANK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C MEANS OF EACH OF THE SERIES, AND THE LOCATION IN C THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES, C RESPECTIVELY. C REAL YMMISS(M) C THE MISSING VALUE CODES FOR EACH OF THE SERIES IN YM. C INTEGER YSD, YSDJ, YSDK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE C LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF C THE JTH AND KTH SERIES, RESPECTIVELY. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', 'M', 'S', ' '/ C I2(I,J) = I + (J-1)*IYM I3C(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV I3N(I,J,K) = I + (J-1)*INLPPC + (K-1)*JNLPPC*INLPPC C C SET UP FOR ERROR CHECKING C IERR = 0 LYFFT = N + LAGMAX IYMFFT = LYFFT NFFT = N ISFFT = .FALSE. ISLONG = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 C CALL LDSCMP(3+2*IO, 0, M, 0, 0, 0, 'S', + 2*M+IO*(4*LAGMAX+2), LDSMIN) C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C FPLM = R1MACH(2) C C SET UP THE WORK AREA. C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) IFP = 3 C YMEAN = STKGET(M, IFP) YSD = STKGET(M, IFP) LGLST = STKGET(M, 2) IF (NPRT.EQ.0) THEN RHOC = YSD SDRHOC = YSD ELSE RHOC = STKGET(2*LAGMAX+1, IFP) SDRHOC = STKGET(2*LAGMAX+1, IFP) END IF C IF (IERR.EQ.0) THEN C C BEGIN LOOP FOR COMPUTATIONS C NEWPG = .FALSE. C DO 40 K = 1, M C YMEANK = YMEAN + K - 1 YSDK = YSD + K - 1 LGLSTK = LGLST + K - 1 C CALL ACVFM (YM(I2(1,K)), YMMISS(K), N, RSTAK(YMEANK), + CCOV(I3C(1,K,K)), LAGMAX, ISTAK(LGLSTK), + NLPPC(I3N(1,K,K)), LAGMAX+1) RSTAK(YSDK) = SQRT(CCOV(I3C(1,K,K)) * N / (N - 1)) C IF ((K-1).LE.0) GO TO 40 C DO 30 J = 1, (K-1) C YMEANJ = YMEAN + J - 1 YSDJ = YSD + J - 1 LGLSTJ = LGLST + J - 1 C CALL CCFMNM (YM(I2(1,J)), YMMISS(J), + YM(I2(1,K)), YMMISS(K), + N, LAGMAX, 2*LAGMAX+1, + CCOV(I3C(1,J,J)), CCOV(I3C(1,K,K)), + CCOV(I3C(1,J,K)), CCOV(I3C(1,K,J)), ICCOV, + NLPPC(I3N(1,J,J)), NLPPC(I3N(1,K,K)), + NLPPC(I3N(1,J,K)), NLPPC(I3N(1,K,J)), + INLPPC, + RSTAK(YMEANJ), RSTAK(YMEANK), RSTAK(RHOC), + RSTAK(SDRHOC), + NPRT, MIN(ISTAK(LGLSTJ), ISTAK(LGLSTK))) C IF (NPRT .EQ. 0) GO TO 30 C C CALL ROUTINE TO PRINT OUT CORRELATIONS C CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N, + NLPPC(I3N(1,J,J)), K, RSTAK(YMEANK), + RSTAK(YSDK), N, NLPPC(I3N(1,K,K)), LAGMAX, + 2*LAGMAX+1, RSTAK(RHOC), RSTAK(SDRHOC), + .TRUE., NLPPC(I3N(1,J,K)), + NLPPC(I3N(1,K,J)), + INLPPC, YMMISS(J), YMMISS(K), NEWPG) C NEWPG = .TRUE. C 30 CONTINUE 40 CONTINUE C CMISS = FPLM END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CCFMS (YM, YMMISS, N, M, IYM,'/ + ' + LAGMAX, CCOV, CMISS, ICCOV, JCCOV,'/ + ' + NLPPC, INLPPC, JNLPPC, NPRT, LDSTAK)') END *CCFOUT SUBROUTINE CCFOUT (J, YMEANJ, YSDJ, NJ, NUSEDJ, K, YMEANK, YSDK, + NK, NUSEDK, LAGMAX, NCC, RHOC, SDRHOC, IFMISS, NLPP12, + NLPP21, LCCOV, YMISSJ, YMISSK, NEWPG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE CROSS CORRELATIONS AND THEIR C STANDARD ERRORS, AND MISCELLANEOUS SUMMARY INFORMATION. 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 REAL + YMEANJ,YMEANK,YMISSJ,YMISSK,YSDJ,YSDK INTEGER + J,K,LAGMAX,LCCOV,NCC,NJ,NK,NUSEDJ,NUSEDK LOGICAL + IFMISS,NEWPG C C ARRAY ARGUMENTS REAL + RHOC(*),SDRHOC(*) INTEGER + NLPP12(*),NLPP21(*) C C LOCAL SCALARS REAL + FPLM,PMISSJ,PMISSK INTEGER + IPRT,NMISSJ,NMISSK C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL CCFLST,IPRINT,VERSP,VPMN C C INTRINSIC FUNCTIONS INTRINSIC REAL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C LOGICAL IFMISS C THE INDICATOR VARIABLE USED TO DETERMINE C WHETHER THE INPUT SERIES HAS MISSING DATA OR NOT. C INTEGER IPRT C THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED C OUTPUT. C INTEGER ISYM(1) C A DUMMY ARRAY. C INTEGER J, K C THE SUBSCRIPT VALUES OF THE TWO SERIES BEING COMPARED. C INTEGER LAGMAX C THE LARGEST LAG VALUE TO BE USED. C INTEGER LCCOV C THE NUMBER OF LOCATIONS ALLOWED FOR STORING THE NLPPC. C INTEGER NCC C THE NUMBER OF CROSS CORRELATIONS COMPUTED (FROM -LAGMAX C TO +LAGMAX). C LOGICAL NEWPG C AN INDICATOR VARIABLE USED TO DETERMINE IF THE OUTPUT SHOULD C START ON A NEW PAGE. C INTEGER NJ, NK C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NLPP12(LCCOV), NLPP21(LCCOV) C THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE EACH C CCVF AT EACH LAG. C INTEGER NMISSJ, NMISSK C THE NUMBER OF MISSING VALUES IN EACH SERIES. C INTEGER NUSEDJ, NUSEDK C THE ACTIVE NUMBER OF OBSERVATIONS IN EACH SERIES. C REAL PMISSJ, PMISSK C THE PERCENT OF MISSING OBSERVATIONS. C REAL RHOC(NCC) C THE ARRAY IN WHICH THE CROSS CORRELATIONS ARE STORED C REAL SDRHOC(NCC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE AUTOCORRELATIONS C ARE STORED C REAL YMEANJ, YMEANK C THE MEAN OF EACH OF THE SERIES. C REAL YMISSJ, YMISSK C THE MISSING VALUE CODE FOR EACH SERIES. C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE CROSS CORRELATIONS. C REAL YSDJ, YSDK C THE STANDARD DEVIAION OF EACH SERIES. C FPLM = R1MACH(2) C YMMISS(1) = FPLM C C PRINT SUMMARY INFORMATION C CALL IPRINT(IPRT) C IF (NEWPG) WRITE (IPRT, 1004) CALL VERSP (.TRUE.) WRITE(IPRT, 1005) C WRITE(IPRT, 1000) J, K, YMEANJ, YMEANK, YSDJ, YSDK, NJ, NK IF (.NOT. IFMISS) GO TO 10 NMISSJ = NJ - NUSEDJ PMISSJ = 100.0E0 * NMISSJ / NJ NMISSK = NK - NUSEDK PMISSK = 100.0E0 * NMISSK / NK WRITE(IPRT, 1003) NMISSJ, NMISSK, PMISSJ, PMISSK C 10 WRITE(IPRT, 1006) LAGMAX IF (IFMISS) WRITE(IPRT, 1007) YMISSJ, YMISSK C IF (YSDJ .GT. 0.0E0 .AND. YSDK .GT. 0.0E0) GO TO 20 WRITE (IPRT, 1008) J, K RETURN C C PRINT CCF INFORMATION C 20 CONTINUE WRITE(IPRT, 1002) WRITE (IPRT, 1001) J, K CALL CCFLST (RHOC, SDRHOC, NLPP12, NLPP21, LAGMAX, LCCOV, NCC, + IFMISS) C C PLOT CCF INFORMATION C WRITE(IPRT, 1004) CALL VERSP (.TRUE.) WRITE (IPRT, 1001) J, K CALL VPMN(RHOC, YMMISS, 2*LAGMAX+1, 1, 2*LAGMAX+1, 1, 0, + ISYM, 1, 0, -1.0E0, 1.0E0, REAL(-LAGMAX), 1.0E0, IFMISS, + 0, 0, 1) RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/ 42X, 7HSERIES , I2, 5X, 7HSERIES , I2// + 41H AVERAGE OF THE SERIES = , 2G14.7/ + 41H STANDARD DEVIATION OF THE SERIES = , 2G14.7/ + 41H NUMBER OF TIME POINTS = , 2(I10, 4X)) 1001 FORMAT (42H CROSS CORRELATION FUNCTION ESTIMATE (CCF)// + 22H CCF CORRELATES SERIES , I2, 22H AT TIME T WITH SERIES , I2, + 15H AT TIME T + K./ + 5X, 55H(IF PEAK CORRELATION OCCURES AT POSITIVE (NEGATIVE) LAG/ + 8X, 36HTHEN SERIES 1 LEADS (LAGS) SERIES 2)) 1002 FORMAT(//) 1003 FORMAT ( + 41H NUMBER OF MISSING OBSERVATIONS = , 2(I10, 4X)/ + 41H PERCENTAGE OF OBSERVATIONS MISSING = , 2(F10.4, 4X)) 1004 FORMAT ('1') 1005 FORMAT ( 27H CROSS CORRELATION ANALYSIS) 1006 FORMAT(/ + 41H LARGEST LAG VALUE TO BE USED = , I10) 1007 FORMAT( + 41H MISSING VALUE CODE = , 2G14.7) 1008 FORMAT (//35H CROSS CORRELATIONS BETWEEN SERIES , I2, 5H AND , + I2, 22H COULD NOT BE COMPUTED/ + 54H BECAUSE THE LAG ZERO AUTOCOVARIANCE OF ONE OR BOTH OF/ + 20H THE SERIES IS ZERO.) END *CCFSD SUBROUTINE CCFSD (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, N, ICCOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING THE STANDARD ERROR C OF THE CROSS CORRELATIONS. 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 + ICCOV,LAGMAX,N,NCC C C ARRAY ARGUMENTS REAL + CCOV11(ICCOV),CCOV22(ICCOV),SDRHOC(NCC) C C LOCAL SCALARS REAL + DIV,SUM INTEGER + I,ILAST,K,K0,KM,KP C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV11(ICCOV), CCOV22(ICCOV) C THE ARRAYS IN WHICH THE AUTOCOVARIANCES ARE STORED C REAL DIV C THE SQUARE ROOT OF THE PRODUCT OF THE AUTOCOVARIANCE C FUNCTION VALUES AT LAG ZERO. C INTEGER I C AN INDEX VARIABLE. C INTEGER ICCOV C THE DIMENSION OF THE ACVF ARRAYS. C INTEGER ILAST C THE LAST LAG AT WHICH THE STANDARD ERROR IS TO BE COMPUTED. C INTEGER K C AN INDEX VARIALBE. C INTEGER KM, KP, K0 C THE LOCATIONS IN THE ARRAYS -RHOC- AND -SDRHOC- C OF THE LAG -K, K AND 0, RESPECTIVELY. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE USED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NCC C THE NUMBER OF CCF COMPUTED. C REAL SDRHOC(NCC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE CROSS CORRELATION C ARE STORED C REAL SUM C A SUMMING VARIABLE. C K0 = LAGMAX + 1 C DIV = CCOV11(1) * CCOV22(1) C SUM = 0.0E0 DO 10 I = 1, LAGMAX SUM = SUM + CCOV11(I+1) * CCOV22(I+1) 10 CONTINUE SUM = SUM / DIV SDRHOC(K0) = SQRT(N + 2.0E0 * SUM) / N C DO 30 K = 1, LAGMAX SUM = 0.0E0 ILAST = MIN(LAGMAX, N-LAGMAX) DO 20 I = 1, ILAST SUM = SUM + (N-K-I)*CCOV11(I+1)*CCOV22(I+1) 20 CONTINUE SUM = SUM / DIV KM = K0 - K SDRHOC(KM) = SQRT((N - K) + 2.0E0 * SUM) / N C KP = K0 + K SDRHOC(KP) = SDRHOC(KM) C 30 CONTINUE C RETURN END *CCFSDM SUBROUTINE CCFSDM (CCOV11, CCOV22, SDRHOC, LAGMAX, NCC, LAGLST, N, + NLPP12, NLPP21, ICCOV, INLPPC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING THE STANDARD ERROR C OF THE CROSS CORRELATIONS WHEN THERE ARE MISSING VALUES. 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 + ICCOV,INLPPC,LAGLST,LAGMAX,N,NCC C C ARRAY ARGUMENTS REAL + CCOV11(ICCOV),CCOV22(ICCOV),SDRHOC(NCC) INTEGER + NLPP12(INLPPC),NLPP21(INLPPC) C C LOCAL SCALARS REAL + DIV,FPLM,SUM INTEGER + I,ILAST,K,K0,KM,KP C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV11(ICCOV), CCOV22(ICCOV) C THE ARRAYS IN WHICH THE AUTOCOVARIANCES ARE STORED. C REAL DIV C THE SQUARE ROOT OF THE PRODUCT OF THE AUTOCOVARIANCE C FUNCTION VALUES AT LAG ZERO. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C INDEXING VARIABLES. C INTEGER ICCOV C THE DIMENSION OF THE COVARIANCE VECTORS. C INTEGER ILAST C THE LAST LAG AT WHICH THE STANDARD ERRORS ARE TO BE COMPUTED. C INTEGER INLPPC C THE DIMENSION OF THE LAGGED PRODUCT PAIR COUNT VECTORS. C INTEGER K C INDEXING VARIABLES. C INTEGER KM, KP, K0 C THE LOCATIONS IN THE ARRAYS -RHOC- AND -SDRHOC- C OF THE LAG -K, K AND 0, RESPECTIVELY. C INTEGER LAGLST C THE LAST AUTOCORRELATION COMPUTED BEFORE A MISSING C AUTOCORRELATION WAS INCOUNTERED IN EITHER SERIES. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE USED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NCC C THE NUMBER OF CROSS CORRELATIONS COMPUTED. C INTEGER NLPP12(INLPPC), NLPP21(INLPPC) C THE ARRAYS IN WHICH THE NUMBER OF OBSERVATIONS USED TO C COMPUTE EACH CROSS CORRELATION ARE STORED. C REAL SDRHOC(NCC) C THE ARRAY IN WHICH THE STANDARD ERRORS OF THE CROSS CORRELATION C ARE STORED C REAL SUM C A SUMMING VARIABLE. C FPLM = R1MACH(2) C DIV = CCOV11(1) * CCOV22(1) C K0 = LAGMAX + 1 C SUM = 0.0E0 DO 10 I = 1, LAGLST SUM = SUM + CCOV11(I+1) * CCOV22(I+1) 10 CONTINUE SUM = SUM / DIV SDRHOC(K0) = FPLM IF (NLPP12(1) .GE. 1) SDRHOC(K0) = + SQRT(N + 2.0E0 * SUM) / NLPP12(1) C DO 30 K = 1, LAGMAX SUM = 0.0E0 ILAST = MIN(LAGLST, N-LAGLST) DO 20 I = 1, ILAST SUM = SUM + (N-K-I) * CCOV11(I+1) * CCOV22(I+1) 20 CONTINUE SUM = SUM / DIV KM = K0 - K SDRHOC(KM) = FPLM IF (NLPP21(K+1) .GE. 1) SDRHOC(KM) = + SQRT((N - K) + 2.0E0 * SUM) * (N - K)/ (N * NLPP21(K+1)) C KP = K0 + K SDRHOC(KP) = FPLM IF (NLPP12(K+1) .GE. 1) SDRHOC(KP) = + SQRT((N - K) + 2.0E0 * SUM) * (N - K) / (N * NLPP12(K+1)) 30 CONTINUE C RETURN END *CCFS SUBROUTINE CCFS (YM, N, M, IYM, LAGMAX, CCOV, ICCOV, JCCOV, + NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE CROSS C CORRELATIONS AND COVARIANCES OF A MULTIVARIATE SERIES (LONG CALL). 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 + ICCOV,IYM,JCCOV,LAGMAX,LDSTAK,M,N,NPRT C C ARRAY ARGUMENTS REAL + CCOV(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,IFP,INLPPC,IO,IPRT,IYMFFT,J,JNLPPC,K,LDSMIN,LYFFT,NALL0, + NFFT,RHOC,SDRHOC,YMEAN,YMEANJ,YMEANK,YSD,YSDJ,YSDK LOGICAL + ISFFT,ISLONG,NEWPG C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + NDUM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVF,CCFER,CCFMN,CCFOUT,IPRINT,LDSCMP,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C STATEMENT FUNCTIONS INTEGER + I2,I3 C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV(ICCOV, JCCOV, M) C THE CROSS COVARIANCE MATRIX. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ICCOV C THE ACTUAL FIRST DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER INLPPC C THE ACTUAL FIRST DIMENSION OF THE ARRAY NLPPC AS SPECIFIEC C IN THE USERS PROGRAM. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER PRINTED OUTPUT IS DESIRED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C LOGICAL ISFFT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX F (ISFFT = TRUE) OR NOT (ISFFT = FALSE) C LOGICAL ISLONG C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS SUFFIX S (ISLONG = TRUE) OR NOT (ISLONG = FALSE) C INTEGER IYM C THE ACTUAL FIRST DIMENSION OF THE MATRIX YM AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER IYMFFT C THE ACTUAL FIRST DIMENSION OF THE MATRIX YMFFT AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER I2 C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN YM C INTEGER I3 C STATEMENT FUNCTION SPECIFYING THE DESIRED LOCATION WITHIN CCOV C INTEGER J C THE INDEX OF -SERIES 1- IN THE ARRAY YM. C INTEGER JCCOV C THE ACTUAL SECOND DIMENSION OF THE ARRAY CCOV, AS C SPECIFIED IN THE USERS PROGRAM. C INTEGER JNLPPC C THE SECOND DIMENSION OF THE ARRAY NLPPC AS SPECIFIED C IN THE USERS PROGRAM. C INTEGER K C THE INDEX OF -SERIES 2- IN THE ARRAY YM. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER M C THE NUMBER OF SERIES BEING COMPARED, IE THE C NUMBER OF COLUMNS OF DATA IN YM. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER NDUM(1) C A DUMMY DIMENSIONED VARIABLE. C LOGICAL NEWPG C AN INDICATOR VARIABLE USED TO DETERMINE WHEN A NEW PAGE C IS APPROPRIATE FOR THE OUTPUT. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPEDIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF C NPRT IS ZERO, NO OUTPUT IS GIVEN. C INTEGER RHOC C THE STARTING LOCATION IN DSTAK OF THE ARRAY RHOC. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER SDRHOC C THE STARTING LOCATION IN THE WORK AREA FOR SDRHOC. C REAL YM(IYM, M) C THE MATRIX CONTAINING THE OBSERVED TIME SERIES C INTEGER YMEAN, YMEANJ, YMEANK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C MEANS OF EACH OF THE SERIES, AND THE LOCATION IN C THE ARRAY FOR THE MEAN OF THE JTH AND KTH SERIES, C RESPECTIVELY. C INTEGER YSD, YSDJ, YSDK C THE STARTING LOCATION FOR THE ARRAY CONTAINING THE C STANDARD DEVIATIONS OF EACH OF THE SERIES, AND THE C LOCATION IN THE ARRAY FOR THE STANDARD DEVIATION OF C THE JTH AND KTH SERIES, RESPECTIVELY. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'C', 'F', 'S', ' ', ' '/ C I2(I,J) = I + (J-1)*IYM I3(I,J,K) = I + (J-1)*ICCOV + (K-1)*JCCOV*ICCOV C C SET UP FOR ERROR CHECKING C IERR = 0 INLPPC = ICCOV JNLPPC = JCCOV LYFFT = N + LAGMAX IYMFFT = IYM NFFT = N ISFFT = .FALSE. ISLONG = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 C CALL LDSCMP(2+2*IO, 0, 0, 0, 0, 0, 'S', + 2*M+IO*(4*LAGMAX+2), LDSMIN) C CALL CCFER(NMSUB, N, LAGMAX, LDSTAK, LDSMIN, ICCOV, JCCOV, + INLPPC, JNLPPC, M, LYFFT, NFFT, IYM, IYMFFT, ISFFT, ISLONG) C C CHECK WHETHER AN ERROR HAS BEEN DETECTED C IF (IERR.EQ.0) THEN C C SET UP THE WORK AREA. C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C YMEAN = STKGET(M, IFP) YSD = STKGET(M, IFP) IF (NPRT.EQ.0) THEN RHOC = YSD SDRHOC = YSD ELSE RHOC = STKGET(2*LAGMAX+1, IFP) SDRHOC = STKGET(2*LAGMAX+1, IFP) END IF C IF (IERR.EQ.0) THEN C C BEGIN LOOP FOR COMPUTATIONS C NEWPG = .FALSE. C DO 40 K = 1, M C YMEANK = YMEAN + K - 1 YSDK = YSD + K - 1 C CALL ACVF (YM(I2(1,K)), N, RSTAK(YMEANK), + CCOV(I3(1,K,K)), LAGMAX, ICCOV) RSTAK(YSDK) = SQRT(CCOV(I3(1,K,K)) * N / (N - 1)) C IF ((K-1).LE.0) GO TO 40 C DO 30 J = 1, (K-1) C YMEANJ = YMEAN + J - 1 YSDJ = YSD + J - 1 C CALL CCFMN (YM(I2(1,J)), YM(I2(1,K)), + N, LAGMAX, 2*LAGMAX+1, + CCOV(I3(1,J,J)), CCOV(I3(1,K,K)), + CCOV(I3(1,J,K)), CCOV(I3(1,K,J)), + ICCOV, RSTAK(YMEANJ), RSTAK(YMEANK), + RSTAK(RHOC), RSTAK(SDRHOC), NPRT) C IF (NPRT .EQ. 0) GO TO 30 C C CALL ROUTINE TO PRINT OUT CORRELATIONS C CALL CCFOUT (J, RSTAK(YMEANJ), RSTAK(YSDJ), N, N, K, + RSTAK(YMEANK), RSTAK(YSDK), N, N, LAGMAX, 2*LAGMAX+1, + RSTAK(RHOC), RSTAK(SDRHOC), .FALSE., NDUM, NDUM, 1, + 0.0E0, 0.0E0, NEWPG) C NEWPG = .TRUE. C 30 CONTINUE 40 CONTINUE END IF C CALL STKCLR(NALL0) END IF C IF (IERR.NE.0) THEN C C PRINT PROPER CALL SEQUENCE AND RETURN C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CCFS (YM, N, M, IYM,'/ + ' + LAGMAX, CCOV, ICCOV, JCCOV, NPRT, LDSTAK)') END *CCFXP SUBROUTINE CCFXP (STORE, LAGMAX, M, CCOV, ICCOV, JCCOV, MISS, + NLPPC, INLPPC, JNLPPC, CMISS) C C LATEST REVISION - 03/15/90 (JRD) C C ROUTINE TO LIST THE COMPUTED RESULTS FROM THE TIME SERIES C CROSS CORRELATION 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 REAL + CMISS INTEGER + ICCOV,INLPPC,JCCOV,JNLPPC,LAGMAX,M LOGICAL + MISS,STORE C C ARRAY ARGUMENTS REAL + CCOV(ICCOV,JCCOV,*) INTEGER + NLPPC(INLPPC,JNLPPC,*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,IPRT,J,K,L,L1,LAG C C LOCAL ARRAYS REAL + CCF(16) C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCF(16) C AN ARRAY USED FOR PRINTING THE CCF. C REAL CCOV(ICCOV,JCCOV,M) C THE CROSS COVARIANCE ARRAY. C REAL CMISS C THE MISSING VALUE CODE FOR THE RETURNED CCVF ESTIMATES C (VECTOR CCOV). C INTEGER I C AN INDEXING VARIABLE. C INTEGER ICCOV C THE FIRST DIMENSION OF THE ARRAY CCOV. 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 INTEGER INLPPC C THE FIRST DIMENSION OF THE ARRAY NLPPC. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JCCOV, JNLPPC C THE SECOND DIMENSIONS OF THE ARRAYS CCOV AND NLPPC, C RESPECTIVELY. C INTEGER K C AN INDEXING VARIABLE. C INTEGER L1 C AN INDEX VARIABLE. C INTEGER LAG C THE LAG VALUE AT WHICH THE DATA IS BEING PRINTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE REQUESTED. C INTEGER M C THE NUMBER OF SERIES IN THE MULTIVARIATE TIME SERIES YM. C LOGICAL MISS C THE VALUE INDICATING WHETHER THE ANALYSIS INCLUDED MISSING C DATA (TRUE) OR NOT (FALSE). C INTEGER NLPPC(INLPPC,JNLPPC,M) C THE ARRAY CONTAINING THE NUMBER OF LAGGED PRODUCT PAIRS C USED TO COMPUTE EACH CCVF ESTIMATE. C LOGICAL STORE C THE VALUE INDICATING WHETHER THE RESULTS WERE RETURNED C TO THE USER (TRUE) OR NOT (FALSE). C CALL IPRINT(IPRT) C C PRINT IERR C WRITE (IPRT, 1000) IERR C IF (IERR.NE.0) RETURN C C CHECK FOR STORED RESULTS C IF (.NOT.STORE) RETURN C C PRINT HEADING FOR CCVF C WRITE (IPRT, 1010) WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M) C C PRINT CROSS COVARIANCES C LAG = 0 WRITE (IPRT, 1060) LAG, ((CCOV(1,J,K), K=1,M), J=1,M) DO 10 LAG = 1, LAGMAX WRITE (IPRT, 1060) LAG, ((CCOV(LAG+1,J,K), K=1,M), J=1,M) 10 CONTINUE C C PRINT HEADING FOR CCF C WRITE (IPRT, 1020) WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M) C C PRINT CROSS CORRELATIONS C LAG = 0 I = 0 DO 30 J = 1, M DO 20 K = 1, M I = I + 1 CCF(I) = CCOV(1,J,K) / SQRT(CCOV(1,J,J)*CCOV(1,K,K)) 20 CONTINUE 30 CONTINUE WRITE (IPRT, 1060) LAG, (CCF(L), L=1,I) C DO 60 LAG = 1, LAGMAX I = 0 DO 50 J = 1, M DO 40 K = 1, M I = I + 1 IF (.NOT.MISS) GO TO 35 CCF(I) = CMISS IF (MVCHK(CCOV(LAG+1,J,K),CMISS)) GO TO 40 35 CCF(I) = CCOV(LAG+1,J,K) / SQRT(CCOV(1,J,J)*CCOV(1,K,K)) 40 CONTINUE 50 CONTINUE WRITE (IPRT, 1060) LAG, (CCF(L1), L1=1,I) 60 CONTINUE C C CHECK FOR MISSING VALUES C IF (.NOT.MISS) RETURN C C PRINT HEADING FOR NUMBERS OF LAGGED PRODUCT PAIRS C WRITE (IPRT, 1030) WRITE (IPRT, 1040) ((J,K, K=1,M), J=1,M) C C PRINT NUMBERS OF LAGGED PRODUCT PAIRS FOR EACH CCVF C LAG = 0 WRITE (IPRT, 1070) LAG, ((NLPPC(1,J,K), K=1,M), J=1,M) DO 70 LAG = 1, LAGMAX WRITE (IPRT, 1070) LAG, ((NLPPC(LAG+1,J,K), K=1,M), J=1,M) 70 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//8H IERR = , I5) 1010 FORMAT (// 6X, 6H CCVF) 1020 FORMAT (// 6X, 6H CCF) 1030 FORMAT (// 6X, 6H NLPPC) 1040 FORMAT (1X, 3HLAG, 16(5X, I1, ',', I1)) 1060 FORMAT (1X, I3, 16F8.4) 1070 FORMAT (1X, I3, 16I8) END *CCVF SUBROUTINE CCVF(Y1, Y2, N, LAGMAX, Y1MEAN, Y2MEAN, CCOV12, CCOV21, + ICCOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION C BETWEEN TWO SERIES. 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 REAL + Y1MEAN,Y2MEAN INTEGER + ICCOV,LAGMAX,N C C ARRAY ARGUMENTS REAL + CCOV12(ICCOV),CCOV21(ICCOV),Y1(N),Y2(N) C C LOCAL SCALARS REAL + DOTXY INTEGER + LAG,NDOTXY C C EXTERNAL SUBROUTINES EXTERNAL DOTC C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV12(ICCOV), CCOV21(ICCOV) C THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED C BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE C STORED. C REAL DOTXY C VARIOUS CROSS PRUDUCTS BETWEEN SERIES Y1 AND Y2. C INTEGER ICCOV C THE ROW DIMENSION OF THE ARRAYS CCOV12 AND CCOV21. C INTEGER LAG C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCORRELATION BEING COMPUTED. C INTEGER LAGMAX C THE MAXIMUM NUMBER OF LAGS TO BE USED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NDOTXY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY. C REAL Y1(N), Y1MEAN C THE FIRST SERIES, AND ITS MEAN. C REAL Y2(N), Y2MEAN C THE SECOND SERIES, AND ITS MEAN. C C COMPUTE THE CROSS COVARIANCES C CALL DOTC ( Y1, Y1MEAN, N, Y2, Y2MEAN, N, DOTXY, NDOTXY) CCOV12(1) = DOTXY / N CCOV21(1) = CCOV12(1) C DO 10 LAG = 1, LAGMAX C CALL DOTC (Y1, Y1MEAN, N, Y2(LAG + 1), Y2MEAN, N - LAG, + DOTXY, NDOTXY) CCOV12(LAG+1) = DOTXY / N C CALL DOTC (Y2, Y2MEAN, N, Y1(LAG + 1), Y1MEAN, N - LAG, + DOTXY, NDOTXY) CCOV21(LAG+1) = DOTXY / N C 10 CONTINUE C RETURN END *CCVFF SUBROUTINE CCVFF (YFFT1, YFFT2, N, NFFT, LAGMAX, CCOV12, CCOV21, + ICCOV, LYFFT, WORK, LWORK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION C BETWEEN TWO SERIES. 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 + ICCOV,LAGMAX,LWORK,LYFFT,N,NFFT C C ARRAY ARGUMENTS REAL + CCOV12(ICCOV),CCOV21(ICCOV),WORK(LWORK),YFFT1(LYFFT), + YFFT2(LYFFT) C C LOCAL SCALARS REAL + FAC INTEGER + I,ISN,J,LAG,NF,NF2,NFFT2 C C EXTERNAL SUBROUTINES EXTERNAL FFT,REALTR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV12(ICCOV), CCOV21(ICCOV) C THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED C BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE STORED. C REAL FAC C THE APPROPRIATE FACTOR USED TO SCALE THE CCVF. C INTEGER I C AN INDEX VARIABLE. C INTEGER ICCOV C THE DIMENSION OF THE ARRAYS CCOV12 AND CCOV21. C INTEGER LAG, LAGMAX C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C CROSS CORRELATION BEING COMPUTED, AND THE MAXIMUM LAG C VALUE TO BE USED. C INTEGER LWORK C THE DIMENSION OF THE VECTOR WORK. C INTEGER LYFFT C THE ACTUAL LENGTH OF THE ARRAYS YFFT1 AND YFFT2. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NF C THE NUMBER OF FOURIER FREQUENCIES. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NFFT2 C THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM. C INTEGER NF2 C TWICE THE NUMBER OF FOURIER FREQUENCIES. C REAL WORK(LWORK) C THE WORK ARRAY NEEDED FOR THE COMPUTATIONS. C REAL YFFT1(LYFFT), YFFT2(LYFFT) C THE VECTORS CONTAINING THE OBSERVED SERIES ALREADY PROCESSED C BY ONE PASS OF A FFT. C NFFT2 = (NFFT-2) / 2 NF = NFFT2 + 1 NF2 = NF * 2 C C COMPUTE THE CROSS COVARIANCES C DO 10 I = 2, NF2, 2 WORK(I-1) = YFFT1(I-1)*YFFT2(I-1) + YFFT1(I)*YFFT2(I) WORK(I) = YFFT1(I)*YFFT2(I-1) - YFFT1(I-1)*YFFT2(I) 10 CONTINUE C FAC = 1.0E0 / (4 * (NFFT-2) * N) C ISN = -2 C CALL REALTR (WORK, WORK(2), NFFT2, ISN) C CALL FFT (WORK, WORK(2), NFFT2, NFFT2, NFFT2, ISN) C CCOV12(1) = WORK(1) * FAC CCOV21(1) = CCOV12(1) C DO 20 LAG = 1, LAGMAX CCOV21(LAG+1) = WORK(LAG+1) * FAC C J = NFFT - 1 - LAG CCOV12(LAG+1) = WORK(J) * FAC 20 CONTINUE C RETURN END *CCVFM SUBROUTINE CCVFM(Y1, Y1MISS, Y2, Y2MISS, N, NC, Y1MEAN, Y2MEAN, + CCOV12, CCOV21, ICCOV, NLPP12, NLPP21) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CROSS COVARIANCE FUNCTION C BETWEEN TWO SERIES WHEN MISSING DATA ARE INVOLVED. 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 REAL + Y1MEAN,Y1MISS,Y2MEAN,Y2MISS INTEGER + ICCOV,N,NC C C ARRAY ARGUMENTS REAL + CCOV12(ICCOV),CCOV21(ICCOV),Y1(N),Y2(N) INTEGER + NLPP12(ICCOV),NLPP21(ICCOV) C C LOCAL SCALARS REAL + DOTXY,FPLM INTEGER + LAG,NDOTXY C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL DOTCM C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CCOV12(ICCOV), CCOV21(ICCOV) C THE ARRAYS IN WHICH THE CCVF FOR SERIES 1 LAGGED C BEHIND SERIES 2 AND VISA VERSA, RESPECTIVELY, ARE C STORED. C REAL DOTXY C VARIOUS CROSS PRUDUCTS BETWEEN SERIES Y1 AND Y2. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER ICCOV C THE ROW DIMENSION OF THE ARRAYS CCOV12 AND CCOV21. C INTEGER LAG C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCORRELATION BEING COMPUTED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NC C THE NUMBER OF CROSS CORRELATIONS DESIRED. C INTEGER NLPP12(ICCOV), NLPP21(ICCOV) C THE NUMBER OF LAGGED PRODUCT PAIRS USED TO COMPUTE THE CCVF C FOR EACH PAIR OF SERIES AT EACH LAG. C INTEGER NDOTXY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY. C REAL Y1(N), Y1MEAN, Y1MISS C THE FIRST SERIES, AND ITS MEAN, AND MISSING VALUE CODE. C REAL Y2(N), Y2MEAN, Y2MISS C THE SECOND SERIES, AND ITS MEAN, AND MISSING VALUE CODE. C FPLM = R1MACH(2) C C COMPUTE THE CROSS COVARIANCES C CALL DOTCM (Y1, Y1MEAN, Y1MISS, N, Y2, Y2MEAN, Y2MISS, N, DOTXY, + NDOTXY) C NLPP12(1) = NDOTXY CCOV12(1) = FPLM IF (NDOTXY .GE. 1) CCOV12(1) = DOTXY / NDOTXY C CCOV21(1) = CCOV12(1) NLPP21(1) = NDOTXY C DO 10 LAG = 1, NC C CALL DOTCM (Y1, Y1MEAN, Y1MISS, N, Y2(LAG+1), Y2MEAN, Y2MISS, + N-LAG, DOTXY, NDOTXY) C NLPP12(LAG+1) = NDOTXY CCOV12(LAG+1) = FPLM IF (NDOTXY .GE. 1) + CCOV12(LAG+1) = DOTXY * (N-LAG) / (N*NDOTXY) C CALL DOTCM (Y2, Y2MEAN, Y2MISS, N, Y1(LAG+1), Y1MEAN, Y1MISS, + N-LAG, DOTXY, NDOTXY) C NLPP21(LAG+1) = NDOTXY CCOV21(LAG+1) = FPLM IF (NDOTXY .GE. 1) + CCOV21(LAG+1) = DOTXY * (N-LAG) / (N*NDOTXY) C 10 CONTINUE C RETURN END *CDFCHI REAL FUNCTION CDFCHI(CHISQR, DF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CHI SQUARE CUMULATIVE DISTRIBUTION C FUNCTION FROM THE INCOMPLETE GAMMA FUNCTION RATIO AS DISCUSSED IN C CHAPTER 17 OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS UNIVARIATE C DISTRIBUTIONS - 1, BY JOHNSON AND KOTZ. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + CHISQR,DF C C LOCAL SCALARS REAL + FPLPM C C EXTERNAL FUNCTIONS REAL + GAMI, GAMMA,R1MACH LOGICAL + MVCHK EXTERNAL GAMI, GAMMA,R1MACH,MVCHK C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CHISQR C THE PERCENT POINT FROM THE CHI SQUARED DISTRIBUTION. C REAL DF C THE DEGREES OF FREEDOM. C REAL FPLPM C THE REAL FLOATING POINT LARGEST POSITIVE MAGNITUDE. C C COMMENCE BODY OF ROUTINE C FPLPM = R1MACH(2) C CDFCHI = GAMI(0.5E0*DF, 0.5E0*CHISQR) IF (MVCHK(CDFCHI,FPLPM)) THEN CDFCHI = 1.0E0 ELSE CDFCHI = CDFCHI / GAMMA(0.5E0*DF) IF (CDFCHI.LT.0.0E0) CDFCHI = 0.0E0 IF (CDFCHI.GT.1.0E0) CDFCHI = 1.0E0 END IF C RETURN END *CDFF REAL FUNCTION CDFF(F, DF1, DF2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION FUNCTION FOR C THE F DISTRIBUTION. THE APPROXIMATION USED DEPENDS ON THE C DEGREES OF FREEDOM IN THE NUMERATOR AND DENOMINATOR. C 1. IF BOTH DEGREES OF FREEDOM ARE SMALL (LESS THAN 4000), C THE CDF IS COMPUTED FROM THE INCOMPLETE BETA FUNCTION C USING EQUATION 5.45 OF STATISTICAL COMPUTING, BY KENNEDY AND C GENTLE. C 2. IF ONE OF THE DEGREES OF FREEDOM IS LARGE (GREATER THAN OR C EQUAL TO 4000) AND THE OTHER IS MODERATELY LARGE (GREATER THAN C OR EQUAL TO 100), THE CDF IS APPROXIMATED BY A NORMAL DISTRIB- C BUTION AS SHOWN IN EQUATION 20 ON PAGE 83 OF DISTRIBUTIONS IN C STATISTICS - CONTINUOUS UNIVARIATE DISTRIBUTIONS - 2, BY C JOHNSON AND KOTZ. C 3. IF ONE OF THE DEGREES OF FREEDOM IS SMALL (LESS THAN 100) AND C THE OTHER IS LARGE (EXCEEDING 4000), THE CDF IS APPROXIMATED C BY A CHI SQUARED DISTRIBUTION AS SHOWN IN THE THIRD EQUATION C ON PAGE 84 OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS C UNIVARIATE DISTRIBUTIONS - 2, BY JOHNSON AND KOTZ. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - DECEMBER 7, 1981 C THIS ROUTINE IS MODELED AFTER DATAPAC ROUTINE FCDF. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + DF1,DF2,F C C LOCAL SCALARS REAL + FTRANS C C EXTERNAL FUNCTIONS REAL + BETAI,CDFCHI,CDFNML EXTERNAL BETAI,CDFCHI,CDFNML C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DF1 C THE DEGREES OF FREEDOM IN THE NUMERATOR. C REAL DF2 C THE DEGREES OF FREEDOM IN THE DENOMINATOR. C REAL F C THE PERCENTAGE POINT FROM THE F DISTRIBUTION. C REAL FTRANS C TRANSFORMS OF THE F PERCENTAGE POINT, USED FOR THE VARIOUS C APPROXIMATING DISTRIBUTIONS. C C COMMENCE BODY OF ROUTINE C IF (F.GT.0.0E0) GO TO 5 CDFF = 0.0E0 RETURN C 5 CONTINUE C IF ((DF1.GT.4000.0E0) .OR. (DF2.GT.4000.0E0)) GO TO 10 C C BOTH DEGREES OF FREEDOM ARE LESS THAN OR EQUAL TO 4000. USE C THE INCOMPLETE BETA FUNCTION TO COMPUTE THE F CDF. C FTRANS = DF2 / (DF2 + DF1 * F) C CDFF = 1.0E0 - BETAI(FTRANS, 0.5E0*DF2, 0.5E0*DF1) RETURN C 10 IF ((DF1.LE.100.0E0) .OR. (DF2.LE.100.0E0)) GO TO 20 C C BOTH DEGREES OF FREEDOM EXCEED 4000. USE THE NORMAL APPROXIMATION C TO COMPUTE THE F CDF. C FTRANS = + (((1.0E0-(2.0E0/(9.0E0*DF2)))* + (F**(1.0E0/3.0E0)))-(1.0E0-(2.0E0/(9.0E0*DF1)))) / + SQRT(((F**(2.0E0/3.0E0))/(4.5E0*DF2))+(2.0E0/(9.0E0*DF1))) C CDFF = CDFNML(FTRANS) RETURN C 20 IF (DF1.GT.100.0E0) GO TO 30 C C THE DEGREES OF FREEDOM IN THE DENOMINATOR EXCEEDS 4000 AND THE C DEGREES OF FREEDOM IN NUMERATOR IS LESS THAN OR EQUAL TO 100. C USE THE CHI SQUARE APPROXIMATION TO COMPUTE THE F CDF. C FTRANS = + (DF1 + (DF1/DF2)*(0.5E0*DF1-1.0E0))/ + ((1.0E0/F)+(DF1/DF2)*0.5E0) C CDFF = CDFCHI(FTRANS, DF1) C RETURN C 30 CONTINUE C C THE DEGREES OF FREEDOM IN THE NUMERATOR EXCEEDS 4000 AND THE C DEGREES OF FREEDOM IN DENOMINATOR IS LESS THAN OR EQUAL TO 100. C USE THE CHI SQUARE APPROXIMATION TO COMPUTE THE F CDF. C FTRANS = + (DF2+(DF2/DF1)*(0.5E0*DF2-1.0E0))/(F+(DF2/DF1)*0.5E0) C CDFF = 1.0E0 - CDFCHI(FTRANS, DF2) C RETURN C END *CDFNML REAL FUNCTION CDFNML(X) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE NORMAL CUMULATIVE DISTRIBUTION C FUNCTION FROM THE ERROR FUNCTION AS DESCRIBED IN CHAPTER 13 C OF DISTRIBUTIONS IN STATISTICS - CONTINUOUS UNIVARIATE C DISTRIBUTIONS - 1, BY JOHNSON AND KOTZ. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + X C C EXTERNAL FUNCTIONS REAL + ERF EXTERNAL ERF C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL X C THE PERCENT POINT FROM THE CHI SQUARED DISTRIBUTION. C C COMMENCE BODY OF ROUTINE C CDFNML = 0.5E0 * (1.0E0 + ERF(X/SQRT(2.0E0))) C RETURN END *CDFT REAL FUNCTION CDFT(X, IDF) C C LATEST REVISION - 03/15/90 (JRD) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR STUDENT"S T DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM PARAMETER = IDF. C THIS DISTRIBUTION IS DEFINED FOR ALL X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C INPUT ARGUMENTS--X = THE VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --IDF = THE INTEGER NUMBER OF DEGREES C OF FREEDOM. C IDF SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE STUDENT"S T DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = IDF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--IDF SHOULD BE A POSITIVE INTEGER VARIABLE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDFC LANGUAGE--ANSI FOR C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS C SERIES 55, 1964, PAGE 948, FORMULAE 26.7.3 AND 26.7.4. C --JOHNSON AND KOTZ, CONTIIDFOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 94-129. C --FEDERIGHI, EXTENDED TABLES OF THE C PERCENTAGE POINTS OF STUDENT"S C T-DISTRIBUTION, JOURNAL OF THE C AMERICAN STATISTICAL ASSOCIATION, C 1959, PAGES 683-688. C --OWEN, HANDBOOK OF STATISTICAL TABLES, C 1962, PAGES 27-30. C --PEARSON AND HARTLEY, BIOMETRIKA TABLES C FOR STATISTICIANS, VOLUME 1, 1954, C PAGES 132-134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C ORIGINAL VERSION--JUNE 1972. C UPDATED --MAY 1974. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1976. C C--------------------------------------------------------------------- C C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + X INTEGER + IDF C C LOCAL SCALARS REAL + B11,B21,B22,B23,B24,B25,B31,B32,B33,B34,B35,B36,B37,C,CSQ,D1, + D11,D3,D5,D7,D9,DCONST,DF,FPSPM,PI,SD,SUM,TERM,TERM1,TERM2, + TERM3,Z INTEGER + I,IDFCUT,IEVODD,IMAX,IMIN,IPRT C C EXTERNAL FUNCTIONS REAL + CDFNML,R1MACH EXTERNAL CDFNML,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL GETPI,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC ABS,ATAN,EXP,LOG,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL B11, B21, B22, B23, B24, B25 C CONSTANTS USED IN THE COMPUTATIONS. C REAL B31, B32, B33, B34, B35, B36, B37 C CONSTANTS USED IN THE COMPUTATIONS. C REAL C C ... C REAL CSQ C ... C REAL DCONST C ... C REAL DF C THE DEGREES OF FREEDOM. C REAL D1, D11, D3, D5, D7, D9 C CONSTANTS USED IN THE COMPUTATIONS. C REAL FPSPM C THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE. C INTEGER I C AN INDEX. C INTEGER IDF C THE DEGREES OF FREEDOM. C INTEGER IDFCUT C ... C INTEGER IEVODD C ... C INTEGER IMAX C ... C INTEGER IMIN C ... C INTEGER IPRT C THE PRINT UNIT. C REAL PI C PI. C REAL SD C ... C REAL SUM C ... C REAL TERM, TERM1, TERM2, TERM3 C ... C REAL X C THE T STATISTIC. C REAL Z C ... C DATA IDFCUT /1000/ DATA DCONST /0.3989422804E0/ DATA B11 /0.25E0/ DATA B21 /96.0E0/ C DATA B21 /0.01041666666667E0/ DATA B22, B23, B24, B25 /3.0E0,-7.0E0,-5.0E0,-3.0E0/ DATA B31 /0.00260416666667E0/ DATA B32, B33, B34, B35, B36, B37 + /1.0E0,-11.0E0,14.0E0,6.0E0,-3.0E0,-15.0E0/ C C CALL GETPI(PI) CALL IPRINT(IPRT) FPSPM = R1MACH(1) C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF (IDF.LE.0) GO TO 10 GO TO 20 10 WRITE (IPRT, 1000) WRITE (IPRT, 1010) IDF CDFT = 0.0E0 RETURN 20 CONTINUE C C-----START POINT----------------------------------------------------- C DF = IDF C C IF IDF IS 3 THROUGH 9 AND X IS MORE THAN 3000 C STANDARD DEVIATIONS BELOW THE MEAN, C SET CDFT = 0.0E0 AND RETURN. C IF IDF IS 10 OR LARGER AND X IS MORE THAN 150 C STANDARD DEVIATIONS BELOW THE MEAN, C SET CDFT = 0.0E0 AND RETURN. C IF IDF IS 3 THROUGH 9 AND X IS MORE THAN 3000 C STANDARD DEVIATIONS ABOVE THE MEAN, C SET CDFT = 1.0E0 AND RETURN. C IF IDF IS 10 OR LARGER AND X IS MORE THAN 150 C STANDARD DEVIATIONS ABOVE THE MEAN, C SET CDFT = 1.0E0 AND RETURN. C IF (IDF.LE.2) GO TO 50 SD = SQRT(DF/(DF-2.0E0)) Z = X/SD IF (IDF.LT.10 .AND. Z.LT.(-3000.0E0)) GO TO 30 IF (IDF.GE.10 .AND. Z.LT.(-150.0E0)) GO TO 30 IF (IDF.LT.10 .AND. Z.GT.3000.0E0) GO TO 40 IF (IDF.GE.10 .AND. Z.GT.150.0E0) GO TO 40 GO TO 50 30 CDFT = 0.0E0 RETURN 40 CDFT = 1.0E0 RETURN 50 CONTINUE C C DISTINGUISH BETWEEN THE SMALL AND MODERATE C DEGREES OF FREEDOM CASE VERSUS THE C LARGE DEGREES OF FREEDOM CASE C IF (IDF.LT.IDFCUT) GO TO 60 GO TO 120 C C TREAT THE SMALL AND MODERATE DEGREES OF FREEDOM CASE C METHOD UTILIZED--EXACT FINITE SUM C (SEE AMS 55, PAGE 948, FORMULAE 26.7.3 AND 26.7.4). C 60 CONTINUE CSQ = DF/(X*X+DF) C = SQRT(CSQ) IMAX = IDF - 2 IEVODD = IDF - 2*(IDF/2) IF (IEVODD.NE.0) THEN IF (IDF.EQ.1) THEN SUM = 0.0E0 ELSE SUM = C END IF TERM = C IMIN = 3 ELSE SUM = 1.0E0 TERM = 1.0E0 IMIN = 2 END IF C DO 90 I=IMIN,IMAX,2 IF (TERM.NE.0.0E0) THEN IF (LOG(TERM)+LOG((I-1.0E0)/I)+LOG(CSQ).GE.LOG(FPSPM)) THEN TERM = TERM*((I-1.0E0)/I)*CSQ SUM = SUM + TERM ELSE TERM = 0.0E0 END IF END IF 90 CONTINUE C IF (SUM.EQ.0.0E0 .OR. X.EQ.0.0E0) THEN SUM = 0.0E0 ELSE IF (LOG(SUM)+LOG(ABS(X))-0.5*LOG(X*X+DF) .LT. LOG(FPSPM)) THEN SUM = 0.0E0 ELSE SUM = SUM*X/SQRT(X*X+DF) END IF END IF IF (IEVODD.EQ.0) GO TO 110 SUM = (2.0E0/PI)*(ATAN(X/SQRT(DF))+SUM) 110 CDFT = 0.5E0 + SUM/2.0E0 RETURN C C TREAT THE LARGE DEGREES OF FREEDOM CASE. C METHOD UTILIZED--TRUNCATED ASYMPTOTIC EXPANSION C (SEE JOHNSON AND KOTZ, VOLUME 2, PAGE 102, FORMULA 10? C SEE FEDERIGHI, PAGE 687). C 120 CONTINUE D1 = X D3 = X**3 D5 = X**5 D7 = X**7 D9 = X**9 D11 = X**11 TERM1 = B11*(D3+D1)/DF C TERM2 = B21*(B22*D7+B23*D5+B24*D3+B25*D1)/(DF**2) TERM2 = (B22*D7+B23*D5+B24*D3+B25*D1)/(DF**2) / B21 TERM3 = B31*(B32*D11+B33*D9+B34*D7+B35*D5+B36*D3+B37*D1)/(DF**3) CDFT = TERM1 + TERM2 + TERM3 CDFT = CDFNML(X) - (DCONST*(EXP(-X*X/2.0E0)))*CDFT RETURN C C FORMAT STATEMENTS C 1000 FORMAT (' ', 49H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO T, + 42HHE CDFT SUBROUTINE IS NON-POSITIVE *****) 1010 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , I8, 6H *****) END *CENTER SUBROUTINE CENTER (Y, N, YC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER ROUTINE FOR CENTERING THE OBSERVED SERIES Y, C RETURNING THE CENTERED SERIES IN YC. C C WRITTEN BY - JANET R. DONALDSON 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 + N C C ARRAY ARGUMENTS REAL + Y(*),YC(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL CNTR,EISGE,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED. C INTEGER IPRT C THE LOGICAL UNIT NUMBER USED FOR OUTPUT. C CHARACTER*1 LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YC(N) C THE VECTOR IN WHICH THE CENTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'E', 'N', 'T', 'E', 'R'/ 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, 2, 1, HEAD, ERR01, LN) IF (.NOT. ERR01) GO TO 5 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 5 CONTINUE C CALL CNTR (Y, N, YC) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 29H CALL CENTER (Y, N, YC)) END *CHIRHO SUBROUTINE CHIRHO (RHO, N, NC, CHI, CHIP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE CHI SQUARED STATISTIC AND ITS C PROBABILITY BASED IN A VECTOR OF AUTOCORRELATIONS. 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 REAL + CHI,CHIP INTEGER + N,NC C C ARRAY ARGUMENTS REAL + RHO(*) C C LOCAL SCALARS INTEGER + LAG C C EXTERNAL FUNCTIONS REAL + CDFCHI EXTERNAL CDFCHI C C INTRINSIC FUNCTIONS INTRINSIC REAL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CHI, CHIP C THE VARIABLES IN WHICH THE CHI SQUARE STATISTIC AND C CHI SQUARE STATISTIC PROBABILITY ARE STORED. C INTEGER LAG C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCORRELATION BEING EXAMINED. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NC C THE NUMBER OF AUTOCORRELATIONS COMPUTED. C REAL RHO(NC) C THE ARRAY IN WHICH THE AUTOCORRELATIONS ARE STORED C CHI = 0.0E0 DO 10 LAG = 1, NC CHI = CHI + RHO(LAG) * RHO(LAG) 10 CONTINUE CHI = CHI * N CHIP = 1.0E0 - CDFCHI(CHI, REAL(NC)) RETURN 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 REAL + STP INTEGER + N C C ARRAY ARGUMENTS REAL + FD(*),PV(*),PVSTP(*) C C LOCAL SCALARS REAL + FPLRS INTEGER + I C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C REAL FD(N) C THE FINITE-DIFFERENCE DERIVATIVE. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C REAL PV(N) C THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE. C REAL PVSTP(N) C THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE PLUS STP. C REAL STP C THE STEP. C FPLRS = R1MACH(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.0E0 END IF 10 CONTINUE RETURN END *CNTR SUBROUTINE CNTR (Y, N, YC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CENTERS THE INPUT SERIES Y ABOUT ITS MEAN, C RETURNING THE CENTERED SERIES IN YC. C C WRITTEN BY - JANET R. DONALDSON 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 + N C C ARRAY ARGUMENTS REAL + Y(*),YC(*) C C LOCAL SCALARS REAL + YMEAN INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL AMEAN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE INPUT SERIES. C REAL Y(N) C THE INPUT ARRAY OF OBSERVATIONS TO BE CENTERED. C REAL YC(N) C THE OUTPUT ARRAY OF CENTERED OBSERVATIONS. C REAL YMEAN C THE MEAN OF THE INPUT SERIES. C CALL AMEAN (Y, N, YMEAN) C DO 10 I = 1, N YC(I) = Y(I) - YMEAN 10 CONTINUE C RETURN C END *CORRER SUBROUTINE CORRER(NMSUB, M, N, IYM, IVCV, LDSTAK, ICOR, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS FOR ERRORS IN THE INPUT C PARAMETERS. IF ANY ARE FOUND A FLAG IS SET AND C COMPUTATION STOPS C C WRITTEN BY - C LINDA L. MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ICOR,IVCV,IYM,LDSTAK,M,N,NPRT C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IP,IPRT,IS,LDSMIN LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD C C LOCAL ARRAYS CHARACTER + LIVCV(8)*1,LIYM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1, + LTHREE(8)*1,LTWO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,IPRINT,LDSCMP C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05 C VALUE(S) INDICATING WHETHER OR ERROR WAS DETECTED C (TRUE) OR NOT (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SHOULD BE C PRINTED (TRUE) OR NOT (FALSE). IF A HEADING IS C PRINTED, THE VALUE OF HEAD WILL BE CHANGED TO FALSE. C INTEGER ICOR C DETERMINES WHICH SUBROUTINE CALLED CORRER C IF =1, THEN CALLED BY CORR C =2, THEN CALLED BY CORRS C INTEGER IERR C A FLAG, THAT WHEN RETURNED BY THIS ROUTINE DESIGNATES C WHETHER 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 IP C A TEMPORARY VARIABLE USED FOR COMPUTING LDSMIN. C INTEGER IPRT C THE LOGICAL OUTPUT UNIT C INTEGER IS C A TEMPORARY VARIABLE USED FOR COMPUTING LDSMIN. C INTEGER IVCV C THE DIMENSION OF SC C INTEGER IYM C ACTUAL ROW DIMENSION OF YM C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK C CHARACTER*1 LIVCV(8), LIYM(8), LLDS(8), LM(8), LN(8), LTHREE(8), C * LTWO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE C VARIABLE(S) CHECKED FOR ERRORS. C INTEGER M C NUMBER OF VARIABLES C INTEGER N C THE NUMBER OFOBSERVATIONS C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLLING THE PRINTED OUTPUT. C IF NPRT=0, OUTPUT IS SUPPRESSED, OTHERWISE IT IS NOT C 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 LIYM(1), LIYM(2), LIYM(3), LIYM(4), LIYM(5), LIYM(6), + LIYM(7), LIYM(8) / 'I', 'Y', 'M', ' ', ' ', ' ', ' ', ' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), + LM(7), LM(8) / 'M', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8) / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LTHREE(1),LTHREE(2),LTHREE(3),LTHREE(4),LTHREE(5),LTHREE(6), + LTHREE(7),LTHREE(8) / 'T', 'H', 'R', 'E', 'E', ' ', ' ', ' '/ DATA LTWO(1), LTWO(2), LTWO(3), LTWO(4), LTWO(5), LTWO(6), + LTWO(7), LTWO(8) / 'T', 'W', 'O', ' ', ' ', ' ', ' ', ' '/ C CALL IPRINT(IPRT) C HEAD = .TRUE. C IERR = 0 C C BEGIN ERROR CHECKING. THE COMMENTS STATE WHAT CONSTITUTES AN C ERROR. COMMENTS ENCLOSED BY STARS(**) INDICATE THE ERROR CONDITION C C **NUMBER OF VARIABLES LESS THAN 2** C CALL EISGE(NMSUB, LM, M, 2, 2, HEAD, ERR01, LTWO) C C **NUMBER OF OBSERVATIONS LESS THAN 3** C CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, ERR02, LTHREE) C C **OBSERVATION MATRIX DIMENSIONED LESS THAN N** C ERR03 = .FALSE. IF (.NOT.ERR02) CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR03, + LN) C C **SC MATRIX DIMENSIONED LESS THAN M** C ERR04 = .FALSE. IF ((ICOR.EQ.2) .AND. (.NOT.ERR01)) CALL EISGE(NMSUB, LIVCV, + IVCV, M, 3, HEAD, ERR04, LM) C IF (ERR01 .OR. ERR02) GO TO 40 IS = 0 IF (ICOR.EQ.1) IS = 1 C IP = 1 IF (NPRT.EQ.0) IP = 0 C C C CHECK FOR ENOUGH COMMON FOR THIS PROBLEM C CALL LDSCMP(12, 0, IP*MAX(N,M), 0, 0, 0, 'S', + IS*M*M + IP*(MAX(N,M)+M+N*(M+3)+6*M*M), LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS) C IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 40 RETURN C C SET IERR TO INDICATE AN ERROR C 40 CONTINUE IERR = 1 RETURN END *CORR SUBROUTINE CORR(YM, N, M, IYM, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR THE CORRELATION FAMILY. C IT IS THE SHORT CALL FORM. C THIS PROCEDURE CALLS CORER TO CHECK FOR ERRORS IN THE PARAMETER C LIST. IF NO PROBLEMS IT THEN ALLOCATES SPACE IN CSTAK FOR THE C VECTORS NEEDED AND CALLS THE MAIN ROUTINE , CORRMN, TO C DO THE CORRELATION ANALYSIS. C C WRITTEN BY - C LINDA L. MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IYM,LDSTAK,M,N C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + AVG,CILO,CIUP,ICOR,IFP,IPRT,IWRK,LIWRK,LWRK,NALL0,NPRT,PC, + QF,QUAD,RANK,SC,SCINV,SD,SLPC,SLSC,SRCC,T,VCV,WRK C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CORRER,CORRMN,IPRINT,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER AVG C THE STARTING LOCATION IN THE WORK AREA FOR THE C AVERAGES OF YM C INTEGER CILO C OCCUPIES THE SAME SPACE AS SLPC AND IS THE LOWER C CONFIDENCE INTERVAL C INTEGER CIUP C OCCUPIES THE SAME SPACE AS SLSC AND IS THE UPPER C CONFIDENCE INTERVAL C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF C THE /CSTAK/ WORK AREA. C INTEGER ICOR C DETERMINES WHICH SUBROUTINE CALLED CORRMN C IF =1, THEN CALLED BY CORR C =2, THEN CALLED BY CORRS C INTEGER IERR C A FLAG RETURNED TO THE USER INDICATING C WHETHER 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 C INDICATES SINGLE PRECISION AND IFP=4 INDICATES C DOUBLE PRECISION. C INTEGER IPRT C LOGICAL OUTPUT UNIT C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IWRK C THE STARTING LOCATION IN THE WORK AREA FOR THE C INTEGER WORK VECTOR. C INTEGER IYM C THE ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRA C INTEGER LDSTAK C SIZE OF WORK AREA ALLOCATED IN THE USERS PROGRAM C INTEGER LIWRK C THE LENGTH OF THE INTEGER WORK VECTOR. C INTEGER LWRK C THE LENGTH OF THE REAL WORK VECTOR. C INTEGER M C THE NUMBER OF VARIABLES C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE C TIME THAT THIS ROUTINE WAS CALLED. C CHARACTER*1 NMSUB(6) C THE SUBROUTINE NAME C INTEGER NPRT C THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT C NPRT = 0, PRINTOUT IS SUPPRESSED C OTHERWISE THE PRINTOUT IS PROVIDED. C INTEGER PC C THE STARTING LOCATION IN THE WORK AREA C OF THE PARTIAL CORRELATION COEFFICIENTS MATRIX C INTEGER QF C THE STARTING LOCATION IN THE WORK AREA FOR THE C QUADRATIC FIT C INTEGER QUAD C THE STARTING LOCATION IN THE WORK AREA FOR THE C REAL VERSION OF THE QUADRATIC FIT C INTEGER RANK C THE STARTING LOCATION IN THE WORK AREA FOR THE C MATRIX CONTAINING THE RANKS OF YM C REAL RSTAK(12) C THE REAL VERSION OF THE C /CSTAK/ WORK AREA. C INTEGER SC C THE STARTING LOCATION IN THE WORK AREA C OF THE SIMPLE CORRELATION COEFFICIENTS MATRIX C INTEGER SCINV C THE STARTING LOCATION IN THE WORK AREA FOR THE C INVERSE MATRIX OF SC C INTEGER SD C THE STARTING LOCATION IN THE WORK AREA OF THE C STANDARD DEVIATIONS OF YM C INTEGER SLPC C THE STARTING LOCATION IN THE WORK AREA OF THE C SIGNIFICANCE LEVELS OF PC C INTEGER SLSC C THE STARTING LOCATION IN THE WORK AREA OF THE C SIGNIFICANCE LEVELS OF SC C INTEGER SRCC C THE STARTING LOCATION IN THE WORK AREA OF THE C SPEARMAN RANK COEFFICIENTS C INTEGER T C STARTING LOCATION IN THE WORK AREA C FOR THE ARRAY T. C INTEGER VCV C THE STARTING LOCATION IN THE WORK AREA OF THE C VARIANCE COVARIANCE MATRIX. C INTEGER WRK C THE STARTING LOCATION IN THE WORK AREA FOR C WORK SPACE C REAL YM(IYM,M) C THE MATRIX IN WHICH THE OBSERVATIONS ARE PASSED C C C SET UP NAME ARRAY C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'O', 'R', 'R', ' ', ' '/ C C SET UP FRAMEWORK VARIABLES FOR NUMBER TYPE C IFP = 3 C C SET CALLER FLAG, THIS IS CORR C ICOR = 1 C C PRINTOUT IS AUTOMATICALY PROVIDED C NPRT = 1 C C CHECK FOR ERRORS IN PARAMETERS C CALL CORRER(NMSUB, M, N, IYM, M, LDSTAK, ICOR, NPRT) C C IF THERE IS AN ERROR RETURN TO THE CALLERS ROUTINE C IF (IERR.EQ.0) GO TO 10 C C PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C INITIALIZE THE STACK C 10 CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C C ALLOCATE SPACE IN CSTAK FOR MATRICES. C LIWRK = MAX(N,M) LWRK = LIWRK C VCV = STKGET(M*M,IFP) IWRK = STKGET(LIWRK,2) WRK = STKGET(LWRK,IFP) C T = STKGET(M,IFP) RANK = STKGET(N*M,IFP) SCINV = STKGET(M*M,IFP) SLSC = STKGET(M*M,IFP) SLPC = STKGET(M*M,IFP) SC = STKGET(M*M,IFP) PC = STKGET(M*M,IFP) QUAD = STKGET(3*N,IFP) QF = STKGET(M*M,IFP) C C THE FOLLOWING VARIABLES HAVE BEEN INDIRECTLY EQUIVALENCED- C CIUP = SLSC CILO = SLPC AVG = WRK SD = WRK SRCC = SCINV C C CALL THE ROUTINE TO DO THE COMPUTATIONS C CALL CORRMN(YM, N, M, IYM, RSTAK(AVG), RSTAK(SD), RSTAK(T), + RSTAK(RANK), RSTAK(SC), RSTAK(PC), RSTAK(SCINV), ISTAK(IWRK), + RSTAK(WRK), RSTAK(SLSC), RSTAK(SLPC), RSTAK(SRCC), + RSTAK(QUAD), RSTAK(CIUP), RSTAK(CILO), RSTAK(QF), + NPRT, RSTAK(VCV), M, LIWRK, LWRK) C C RETURN AREA TO THE WORK ARRAY C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENT C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CORR (YM, N, M, IYM, LDSTAK)') END *CORRHD SUBROUTINE CORRHD(IPRT, M, N) C C LATEST REVISION - 03/15/90 (JRD) C C A SUBROUTINE TO PRINT OUT THE HEADING FOR THE CORRELATION FAMILY. C C AUTHOR - C JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IPRT,M,N C C EXTERNAL SUBROUTINES EXTERNAL VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE OUTPUT LOGICAL UNIT NUMBER C INTEGER M C THE NUMBER OF VARIABLES C INTEGER N C THE NUMBER OF OBSERVATIONS FOR EACH VARIABLE C CALL VERSP(.TRUE.) WRITE (IPRT,1000) M, N RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/25H CORRELATION ANALYSIS FOR, I3, 15H VARIABLES WITH, + I5, 13H OBSERVATIONS/) END *CORRMN SUBROUTINE CORRMN(YM, N, M, IYM, AVG, SD, T, RANK, SC, PC, SCINV, + IWRK, WRK, SLSC, SLPC, SRCC, QUAD, CIUP, CILO, QF, NPRT, + VCV, IVCV, LIWRK, LWRK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN ROUTINE FOR THE CORRELATION FAMILY, IT WAS C ADAPTED FROM THE OMNITAB ROUTINE CORREL. IT DOES A CORRELATION C ANALYSIS OF A MULTIVARIATE RANDOM SAMPLE. C THE FOLLOWING TABLES ARE PRODUCED C SIMPLE CORRELATION COEFFICIENTS, C PARTIAL CORRELATION COEFFICIENTS, C AND THEIR SIGINIFICANCE LEVELS, C SPEARMAN RANK COEFFICIENTS, C QUADRATIC RELATIONSHIP, C 95 AND 99 PERCENT CONFIDENCE INTERVALS. C C THIS ROUTINE WAS ADAPTED FROM AN OMNITAB ROUTINE. C C ADAPTED BY - C JANET R. DONALDSON AND LINDA L. MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVCV,IYM,LIWRK,LWRK,M,N,NPRT C C ARRAY ARGUMENTS REAL + AVG(M),CILO(M,M),CIUP(M,M),PC(M,M),QF(M,M),QUAD(N,3), + RANK(N,M),SC(M,M),SCINV(M,M),SD(M),SLPC(M,M),SLSC(M,M), + SRCC(M,M),T(M),VCV(IVCV,M),WRK(LWRK),YM(IYM,M) INTEGER + IWRK(LIWRK) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + B,F,FN3,FPLM,HL1,HL2,SQSUM,SUM,Z,ZZ INTEGER + I,IER,IPRT,J,K,K1,K2,NSUM C C LOCAL ARRAYS REAL + C(3),D(3),RR(3,3),XX(3) INTEGER + INERT(3) C C EXTERNAL FUNCTIONS REAL + CDFF,R1MACH EXTERNAL CDFF,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,CORRHD,DOTC,IPRINT,MATPRT,MGS,RANKO,SSIDI,SSIFA, + VCVOUT C C INTRINSIC FUNCTIONS INTRINSIC ABS,INT,LOG,MAX,MIN,REAL,SIGN,SQRT,TANH C C COMMON BLOCKS COMMON /ERRCHK/IERR C C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AVG(M) C CONTAINS THE COLUMN AVERAGES OF YM C REAL B C = (N-1) * N * (N+1) / 6 C REAL C(3) C * C REAL CILO(M,M) C LOWER CONFIDENCE INTERVAL FOR SC C REAL CIUP(M,M) C UPPER CONFIDENCE INTERVAL FOR SC C REAL D(3) C A DUMMY ARRAY. C REAL F C SQUARE ROOT OF FN3 C REAL FN3 C REAL REPRESENTATION OF (N-3). C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE C REAL HL1 C * C REAL HL2 C * C INTEGER I C AN INDEX VARIABLE C INTEGER IER C ERROR FLAG FOR SUBROUTINES CALLED FROM THIS ROUTINE C INTEGER IERR C WHEN RETURNED BY THIS ROUTINE, DESGINATES WHETHER ANY C ERRORS WERE DETECTED DURING COMPUTATIONS C IF IERR .EQ. 0, NO ERRORS C .EQ. 1, ERRORS WERE DETECTED C INTEGER INERT(3) C THE INERTIA OF THE SIMPLE CORRELATION MATRIX. C INTEGER IPRT C THE LOGICAL OUTPUT NUMBER C INTEGER IVCV C THE ROW DIMENSION OF VCV SPECIFIED IN THE USERS PROGR C INTEGER IWRK(LIWRK) C A WORK VECTOR FOR THE INVERSION ROUTINE C INTEGER IYM C THE ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRA C INTEGER J C AN INDEX VARIABLE C INTEGER K C AN INDEX VARIABLE C INTEGER K1 C * C INTEGER K2 C * C INTEGER LIWRK C THE LENGTH OF THE INTEGER WORK VECTOR. C INTEGER LWRK C THE LENGTH OF THE REAL WORK VECTOR. C INTEGER M C THE NUMBER OF VARIABLES (THE COLUMN DIMENSION OF YM) C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NPRT C THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT C NPRT =0, PRINTOUT IS SUPPRESSED C OTHERWISE PRINTOUT IS PROVIDED C INTEGER NSUM C THE NUMBER OF OBSERVATIONS IN THE DOT PRODUCT C REAL PC(M,M) C PARTIAL CORRELATION COEFFICIENTS MATRIX C REAL QF(M,M) C QUADRATIC FIX MATRIX C REAL QUAD(N,3) C DOUBLE VERSION OF QF MATRIX C REAL RANK(N,M) C THE MATRIX CONTAING THE RANKS OF YM C REAL RR(3,3) C * C REAL SC(M,M) C SIMPLE CORRELATION COEFFICIENTS MATRIX C REAL SCINV(M,M) C THE INVERSE MATRIX OF SC C REAL SD(M) C STANDARD DEVIATION OF THE COMLUMNS OF YM C REAL SLPC(M,M) C SIGNIFICANCE LEVELS OF PC C REAL SLSC(M,M) C SIGNIFICANCE LEVELS OF SC C REAL SQSUM C THE SUM OF SQUARES OF THE ITH COLUMN OF YM C REAL SRCC(M,M) C SPEARMAN RANK CORRELATION COEFFICIENTS C REAL SUM C USED IN CALCULATING THE STATISTICS OF YM C REAL T(M) C USED IN DETERMINING SRCC C REAL VCV(IVCV,M) C THE VARIANCE COVARIANCE MATRIX. C REAL WRK(LWRK) C WORK STORAGE C REAL XX(3) C * C REAL YM(IYM,M) C THE MATRIX WHOSE COLUMNS EACH CONTAIN ONE OF M SETS C OF N OBSERVATIONS. EACH COLUMN REPRESENTS A DIFFERENT C VARIABLE C REAL Z C USED IN COMPUTING CONFIDENCE INTERVALS C REAL ZZ C USED IN DETERMINING CORRELATION COEFFICIENTS C IERR = 0 C FPLM = R1MACH(2) CALL IPRINT(IPRT) C DO 10 J=1,M CALL AMEAN(YM(1,J), N, AVG(J)) 10 CONTINUE C C COMPUTE VARIANCE-COVARIANCE MATRIX C DO 30 J=1,M DO 20 I=J,M CALL DOTC(YM(1,J), AVG(J), N, YM(1,I), AVG(I), N, SUM, NSUM) VCV(J,I) = SUM/(NSUM-1) VCV(I,J) = VCV(J,I) 20 CONTINUE 30 CONTINUE C IF (NPRT.EQ.0) RETURN C C PRINT VARIANCE-COVARIANCE MATRIX AND SIMPLE CORRELATION C COEFFICIENTS C CALL CORRHD(IPRT, M, N) CALL VCVOUT(M, VCV, IVCV, .FALSE.) C C COMPUTE STANDARD DEVIATIONS C DO 40 I=1,M IF (VCV(I,I).LE.0.0E0) GO TO 90 SD(I) = SQRT(VCV(I,I)) 40 CONTINUE C C COMPUTE SIMPLE CORRELATION COEFFICIENTS C DO 60 J=1,M DO 50 I=J,M SC(I,J) = 1.0E0 SCINV(J,I) = 1.0E0 IF (I.EQ.J) GO TO 50 SC(I,J) = VCV(I,J)/SD(I)/SD(J) SC(J,I) = SC(I,J) SCINV(J,I) = SC(I,J) 50 CONTINUE 60 CONTINUE C IF ((M.LE.2) .OR. (N.LE.M)) GO TO 190 C C CALCULATE PARTIAL CORRELATION COEFFICIENTS. C CALL SSIFA(SCINV, M, M, IWRK, IER) IF (IER.EQ.0) GO TO 100 90 WRITE (IPRT,1000) IERR = 1 RETURN 100 CONTINUE CALL SSIDI(SCINV, M, M, IWRK, D, INERT, WRK, 1) DO 130 J=1,M DO 120 I=J,M PC(I,J) = 1.0E0 IF (I.EQ.J) GO TO 120 ZZ = SCINV(I,I)*SCINV(J,J) PC(I,J) = FPLM IF (ZZ.LE.0.0E0) GO TO 110 PC(I,J) = -SCINV(J,I)/SQRT(ZZ) IF (ABS(PC(I,J)).GT.1.0E0) PC(I,J) = SIGN(1.0E0,PC(I,J)) 110 PC(J,I) = PC(I,J) 120 CONTINUE C 130 CONTINUE C C COMPUTE SIGNIFICANCE LEVELS OF PARTIAL CORRELATION COEFFICIENTS. C NOTE, LOWER TRIANGULAR MATRIX STORED IN SQUARE MATRIX. C DO 180 I=1,M DO 170 J=1,I IF (PC(I,J).NE.0.0E0) GO TO 140 SLPC(I,J) = 1.0E0 GO TO 170 140 IF (ABS(PC(I,J)).LT.1.0E0) GO TO 150 SLPC(I,J) = 0.0E0 GO TO 170 150 F = PC(I,J)*PC(I,J) IF (1.0E0-F.NE.0.0E0) GO TO 160 SLPC(I,J) = FPLM GO TO 170 160 F = (N-M)*F/(1.0E0-F) SLPC(I,J) = 1.0E0 - CDFF(F,1.0E0,REAL(N-M)) 170 CONTINUE 180 CONTINUE C C COMPUTE SIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFFICIENTS C NOTE, ONLY LOWER TRIANGULAR STORED IN SQUARE MATRIX. C 190 DO 250 I=1,M DO 240 J=1,I IF (I.NE.J) GO TO 200 SLSC(I,J) = 0.0E0 GO TO 240 200 IF (SC(I,J).NE.0.0E0) GO TO 210 SLSC(I,J) = 1.0E0 GO TO 240 210 IF (ABS(SC(I,J)).LT.1.0E0) GO TO 220 SLSC(I,J) = 0.0E0 GO TO 240 220 F = SC(I,J)*SC(I,J) IF (F.NE.1.0E0) GO TO 230 SLSC(I,J) = FPLM GO TO 240 230 F = (N-2)*F/(1.0E0-F) SLSC(I,J) = 1.0E0 - CDFF(F,1.0E0,REAL(N-2)) 240 CONTINUE 250 CONTINUE C C PRINT SIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFFICIENTS, C PARTIAL CORRELATION COEFFICIENTS AND SIGNIFICANCE LEVELS C WRITE (IPRT,1020) CALL MATPRT(SLSC, SLSC, M, IPRT, 0, 1, M) IF ((M.GT.2) .AND. (N.GT.M)) GO TO 260 WRITE (IPRT,1010) GO TO 270 260 I = M - 2 WRITE (IPRT,1030) I CALL MATPRT(PC, PC, M, IPRT, 0, 1, M) WRITE (IPRT,1040) CALL MATPRT(SLPC, SLPC, M, IPRT, 0, 1, M) 270 CONTINUE C C DETERMINE THE RANKS OF THE OBSERVATIONS. C DO 280 I=1,M CALL RANKO(N, YM(1,I), IWRK, RANK(1,I), T(I)) T(I) = T(I) / 12.0E0 280 CONTINUE C C COMPUTE SPEARMAN RANK CORRELATION COEFFICIENTS. C NOTE, LOWER TRIANGULAR MATRIX, STORED IN SQUARE MATRIX. C B = (N-1)*N*(N+1)/6 DO 330 I=1,M DO 320 J=1,I SRCC(I,J) = 1.0E0 IF (I.EQ.J) GO TO 320 K1 = 2.0E0*T(I) + 0.4E0 K2 = 2.0E0*T(J) + 0.4E0 SRCC(I,J) = FPLM IF ((INT(B)-K1.LE.0) .OR. (INT(B)-K2.LE.0)) GO TO 320 SUM = 0.0E0 DO 310 K=1,N ZZ = RANK(K,I) - RANK(K,J) SUM = SUM + ZZ*ZZ 310 CONTINUE ZZ = (B - 2.0E0*T(I))*(B - 2.0E0*T(J)) IF (ZZ.GT.0.0E0) SRCC(I,J) = (B-SUM-T(I)-T(J))/SQRT(ZZ) 320 CONTINUE 330 CONTINUE C C PRINT SPEARMAN RANK CORRELATIONS COEFFICIENTS C WRITE (IPRT,1050) CALL MATPRT(SRCC, SRCC, M, IPRT, 0, 1, M) C IF (N.GT.3) GO TO 340 WRITE (IPRT,1060) RETURN C C COMPUTE THE SIGNIFICANCE LEVELS OF THE QUADRATIC FIT OVER THE C LINEAR FIT. C C THESE CALCULATIONS MAY PRODUCE VARIABLE RESULTS IN VARYING C MACHINE/COMPILATION ENVIRONMENTS, IN CASES IN WHICH THE C YM MATRIX IS NEAR SINGULAR (ESSENTIALLY SINGULAR BUT THE C SINGULARITY IS UNDETECTED BY THE CODE). THE OBSERVED SYMPTOMS C ARE ALTERNATION BETWEEN QF VALUES OF 0.0E0 (FIRST F = LINE C PRODUCES ZERO) AND 1.0E0 (FIRST F = LINE PRODUCES APPROX. C ZERO, AND NUMERATOR IN SECOND F = LINE IS NONZERO). C 340 FN3 = N-3 DO 410 J=1,M DO 400 I=1,M IF (I.NE.J) GO TO 350 QF(I,J) = 1.0E0 GO TO 400 350 SQSUM = 0.0E0 DO 360 K=1,N QUAD(K,1) = 1.0E0 QUAD(K,2) = YM(K,J) QUAD(K,3) = YM(K,J)*YM(K,J) SQSUM = SQSUM + YM(K,I)*YM(K,I) WRK(K) = YM(K,I) 360 CONTINUE CALL MGS(QUAD, WRK, N, 3, XX, C, D, RR, 3, N, IER) IF (IER.EQ.0) GO TO 370 WRITE (IPRT,1090) GO TO 420 370 DO 380 K=1,3 C(K) = C(K)*SQRT(D(K)) 380 CONTINUE F = (SQSUM-C(1)*C(1)-C(2)*C(2)-C(3)*C(3)) QF(I,J) = 0.0E0 IF (F.EQ.0.0E0) GO TO 400 F = (C(3)*C(3)*FN3)/F QF(I,J) = 1.0E0 IF (F.GT.0.0E0) QF(I,J) = 1.0E0 - CDFF(F,1.0E0,FN3) 400 CONTINUE 410 CONTINUE C C PRINT THE QUADRATIC FIT MATRIX C J = 2 K = 1 I = N - 3 WRITE (IPRT,1070) I, QF(J,K), J, K CALL MATPRT(QF, QF, M, IPRT, 1, 1, M) C C COMPUTE CONFIDENCE LIMITS FOR SIMPLE CORRELATION COEFFICIENTS C 420 F = SQRT(FN3) HL1 = 2.5758293E0/F HL2 = 1.9599640E0/F DO 520 J=1,M DO 510 I=1,M IF (I.NE.J) GO TO 430 CIUP(I,J) = 99.0E0 CILO(I,J) = 95.0E0 GO TO 510 430 IF (I.LT.J) GO TO 470 C C COMPUTE 95 PERCENT INTERVALS. C IF (SC(I,J).GE.1.0E0) GO TO 440 IF (SC(I,J).GT.-1.0E0) GO TO 450 Z = -1.0E0 GO TO 460 440 Z = 1.0E0 GO TO 460 450 Z = 0.5E0*LOG((1.0E0+SC(I,J))/(1.0E0-SC(I,J))) 460 CIUP(I,J) = MIN(TANH(Z+HL2),1.0E0) CILO(I,J) = MAX(TANH(Z-HL2),-1.0E0) GO TO 510 C C COMPUTE 99 PERCENT INTERVALS. C 470 IF (SC(J,I).GE.1.0E0) GO TO 480 IF (SC(J,I).GT.-1.0E0) GO TO 490 Z = -1.0E0 GO TO 500 480 Z = 1.0E0 GO TO 500 490 Z = 0.5E0*LOG((1.0E0+SC(J,I))/(1.0E0-SC(J,I))) 500 CIUP(I,J) = MIN(TANH(Z+HL1),1.0E0) CILO(I,J) = MAX(TANH(Z-HL1),-1.0E0) 510 CONTINUE 520 CONTINUE C C PRINT CONFIDENCE LIMITS C WRITE (IPRT,1080) CALL MATPRT(CIUP, CILO, M, IPRT, 1, 2, M) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ 46H COMPUTATION STOPPED DUE TO SINGULAR OR ILL-CO, + 28HNDITIONED COVARIANCE MATRIX.) 1010 FORMAT (//42H THE PARTIAL CORRELATION COEFFICIENTS (AND, 6H SIGNI, + 50HFICANCE LEVELS) ARE NOT PRINTED OR DEFINED BECAUSE/6H EITHE, + 52HR THE NUMBER OF VECTORS BEING COMPARED IS TWO OR THE, + 59H NUMBER OF MEASUREMENTS IS LESS THAN OR EQUAL TO THE NUMBER/ + 27H OF VECTORS BEING COMPARED.) 1020 FORMAT (// 44H SIGNIFICANCE LEVELS OF SIMPLE CORRELATION C, + 32HOEFFICIENTS (ASSUMING NORMALITY)) 1030 FORMAT (// 38H PARTIAL CORRELATION COEFFICIENTS WITH, I3, + 26H REMAINING VARIABLES FIXED) 1040 FORMAT (// 44H SIGNIFICANCE LEVELS OF PARTIAL CORRELATION , + 33HCOEFFICIENTS (ASSUMING NORMALITY)) 1050 FORMAT (// 44H SPEARMAN RANK CORRELATION COEFFICIENTS (ADJ, + 15HUSTED FOR TIES)) 1060 FORMAT (// 44H NONLINEARITY TEST AND APPROXIMATION OF CONF, + 39HIDENCE INTERVALS NOT DEFINED FOR N = 3.) 1070 FORMAT (// 45H SIGNIFICANCE LEVEL OF QUADRATIC FIT OVER LIN, + 35HEAR FIT BASED ON F RATIO WITH 1 AND, I5, 15H DEGREES OF FRE, + 4HEDOM/14H (FOR EXAMPLE,, F7.4, 19H IS THE SIGNIFICANC, + 41HE LEVEL OF THE QUADRATIC TERM WHEN COLUMN, I3, 9H IS FITTE, + 11HD TO COLUMN, I3, ')') 1080 FORMAT (// 44H CONFIDENCE INTERVALS FOR SIMPLE CORRELATION, + 43H COEFFICIENTS (USING FISHER TRANSFORMATION)/' 95 PER C', + 59HENT LIMITS BELOW DIAGONAL, 99 PER CENT LIMITS ABOVE DIAGONA, + 'L') 1090 FORMAT (/ 46H SIGNIFICANCE LEVELS OF QUADRATIC FIT OVER LIN, + 30HEAR FIT HAVE NOT BEEN COMPUTED/' DUE TO SINGULARITY IN', + 32H DESIGN MATRIX. CHECK YOUR DATA.) END *CORRS SUBROUTINE CORRS(YM, N, M, IYM, LDSTAK, NPRT, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR THE CORRELATION FAMILY. C IT IS THE LONG CALL FORM. C THIS ROUTINE CALLS CORRER TO CHECK FOR ERRORS IN THE PARAMETERS. C IF THERE ARE NO PROBLEMS IT THEN ALLOCATES SPACE IN CSTAK C FOR THE VECTORS NEEDED AND CALLS THE MAIN ROUTINE, CORRMN, TO DO C THE CORRELATION ANALYSIS. C C WRITTEN BY - C LINDA L. MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVCV,IYM,LDSTAK,M,N,NPRT C C ARRAY ARGUMENTS REAL + VCV(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + AVG,CILO,CIUP,ICOR,IFP,IPRT,IWRK,LIWRK,LWRK,NALL0,PC,QF, + QUAD,RANK,SC,SCINV,SD,SLPC,SLSC,SRCC,T,WRK C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CORRER,CORRMN,IPRINT,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER AVG C THE STARTING LOCATION IN THE WORK AREA OF THE C AVERAGES OF YM C INTEGER CILO C OCCUPIES THE SAME SPACE AS SLPC AND IS THE LOWER C CONFIDENCE INTERVAL C INTEGER CIUP C OCCUPIES THE SAME SPACE AS SLSC AND IS THE UPPER C CONFIDENCE INTERVAL C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF C THE /CSTAK/ WORK AREA. C INTEGER ICOR C DETERMINES WHICH SUBROUTINE CALLED CORRMN C IF =1, THEN CALLED BY CORR C =2, THEN CALLED BY CORRS C INTEGER IERR C A FLAG RETURNED TO THE USER INDICATING C WHETHER 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 C INDICATES SINGLE PRECISION AND IFP=4 INDICATES C DOUBLE PRECISION. C INTEGER IPRT C LOGICAL OUTPUT UNIT C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IVCV C THE DIMENSION OF VCV ASSIGNED IN THE USERS PROGRAM. C INTEGER IWRK C THE STARTING LOCATION IN THE WORK AREA FOR THE C INTEGER WORK VECTOR. C INTEGER IYM C ROW DIMENSION OF YM SPECIFIED IN THE USERS PROGRAM. C INTEGER LDSTAK C SIZE OF WORK AREA ALLOCATED IN THE USERS PROGRAM C INTEGER LIWRK C THE LENGTH OF THE INTEGER WORK VECTOR. C INTEGER LWRK C THE LENGTH OF THE REAL WORK VECTOR. C INTEGER M C THE NUMBER OF VARIABLES C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE C TIME THAT THIS ROUTINE WAS CALLED. C CHARACTER*1 NMSUB(6) C THE SUBROUTINE NAME C INTEGER NPRT C THE VARIABLE CONTROLLING THE AUTOMATIC PRINTOUT C NPRT = 0 PRINTOUT IS SUPRESSED C OTHERWISE THE PRINTOUT IS PROVIDED. C INTEGER PC C THE STARTING LOCATION IN THE WORK AREA FOR THE C THE PARTIAL CORRELATION COEFFICIENTS MATRIX C INTEGER QF C THE STARTING LOCATION IN THE WORK AREA FOR THE C QUADRATIC FIT MATRIX C INTEGER QUAD C THE STARTING LOCATION IN THE WORK AREA FOR THE C REAL QUAD FIT C INTEGER RANK C THE STARTING LOCATION IN THE WORK AREA FOR THE C MATRIX CONTAINING THE RANKS OF YM C REAL RSTAK(12) C THE REAL VERSION OF C THE /CSTAK/ WORK AREA. C INTEGER SC C THE STARTING LOCATION IN THE WORK AREA FOR THE C THE SIMPLE CORRELATION COEFFICIENTS MATRIX C INTEGER SCINV C THE STARTING LOCATION IN THE WORK AREA OF THE C INVERSE MATRIX OF VCV C INTEGER SD C THE STARTING LOCATION IN THE WORK AREA OF THE C STANDARD DEVIATIONS VECTOR C INTEGER SLPC C THE STARTING LOCATION IN THE WORK AREA OF THE C SIGNIFICANCE LEVELS FOR PC C INTEGER SLSC C THE STARTING LOCATION IN THE WORK AREA OF THE C SIGNIFICANCE LEVELS FOR SC C INTEGER SRCC C STARTING LOCATION IN THE WORK AREA FOR THE SPEAR- C MAN RANK COEFFICIENTS C INTEGER T C STARTING LOCATION IN THE WORK AREA C FOR THE WORK VECTOR T C REAL VCV(IVCV,M) C THE VARIANCE COVARIANCE MATRIX C INTEGER WRK C THE STARTING LOCATION IN THE WORK AREA FOR C WORK SPACE C REAL YM(IYM,M) C THE OBSERVATION MATRIX C C C SET UP NAME ARRAY C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'C', 'O', 'R', 'R', 'S', ' '/ C C SET UP FRAMEWORK VARIABLES FOR NUMBER TYPES C IFP = 3 C C SET THE CALLER FLAG, THIS IS CORRS C ICOR = 2 C C CHECK FOR ERRORS IN PARAMETERS C CALL CORRER(NMSUB, M, N, IYM, IVCV, LDSTAK, ICOR, NPRT) C C IF THERE IS AN ERROR RETURN TO THE CALLERS ROUTINE C IF (IERR.EQ.0) GO TO 10 C C PRINT CORRECT FORM OF CALL STATEMENT AND RETURN TO CALLER C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C INITIALIZE THE STACK C 10 CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C C ALLOCATE SPACE IN DSTAK FOR MATRICES C LIWRK = MAX(N,M) LWRK = LIWRK C WRK = STKGET(LWRK,IFP) C IF (NPRT.EQ.0) THEN IWRK = WRK T = WRK RANK = WRK SC = WRK SCINV = WRK SLSC = WRK PC = WRK SLPC = WRK QUAD = WRK QF = WRK ELSE IWRK = STKGET(LIWRK,2) T = STKGET(M,IFP) RANK = STKGET(N*M,IFP) SC = STKGET(M*M,IFP) SCINV = STKGET(M*M,IFP) SLSC = STKGET(M*M,IFP) PC = STKGET(M*M,IFP) SLPC = STKGET(M*M,IFP) QUAD = STKGET(3*N,IFP) QF = STKGET(M*M,IFP) END IF C C THE FOLLOWING VARIABLES HAVE BEEN INDIRECTLY EQUIVALENCED- C CIUP = SLSC CILO = SLPC AVG = WRK SD = WRK SRCC = SCINV C CALL CORRMN(YM, N, M, IYM, RSTAK(AVG), RSTAK(SD), RSTAK(T), + RSTAK(RANK), RSTAK(SC), RSTAK(PC), RSTAK(SCINV), ISTAK(IWRK), + RSTAK(WRK), RSTAK(SLSC), RSTAK(SLPC), RSTAK(SRCC), + RSTAK(QUAD), RSTAK(CIUP), RSTAK(CILO), RSTAK(QF), + NPRT, VCV, IVCV, LIWRK, LWRK) C C RETURN AREA TO WORK C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL CORRS (YM, N, M, IYM, LDSTAK, NPRT, VCV, IVCV)') END *CORRXP SUBROUTINE CORRXP(M, VCV, IVCV, IPRT) C C LATEST REVISION - 03/15/90 (JRD) C C PRINT STORED OUTPUT RETURNED FROM CORRS C C WRITTEN BY - C LINDA MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IPRT,IVCV,M C C ARRAY ARGUMENTS REAL + VCV(*) C C EXTERNAL SUBROUTINES EXTERNAL MATPRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE LOGICAL OUTPUT NUMBER C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV C INTEGER M C THE NUMBER OF VARIABLES IN THE ANALYSIS C REAL VCV(IVCV,M) C ARRAYS TO BE PRINTED C IF (IVCV.GE.M) THEN WRITE (IPRT,1000) WRITE (IPRT,1010) CALL MATPRT(VCV, VCV, M, IPRT, 1, 1, IVCV) END IF C C FORMAT STATEMENTS C RETURN 1000 FORMAT (/ 20H STORAGE FROM CORRS.) 1010 FORMAT (40H STORAGE FROM VARIANCE-COVARIANCE MATRIX) 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 REAL + D(P),J(NN,P),R(N),V(1),X(P) INTEGER + IV(1) C C LOCAL SCALARS REAL + 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,LSQRT,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 REAL 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 REAL DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO C C/ C *** EXTERNAL SUBROUTINES *** C C EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRT, 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 LSQRT.... 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 DATA HALF/0.5E0/, NEGPT5/-0.5E0/, ONE/1.0E0/, TWO/2.0E0/, + ZERO/0.0E0/ 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 LSQRT(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 *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 REAL + 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 REAL X(LX) C THE MATRIX TO BE COPIED FROM. C REAL Y(IY,M) C THE MATRIX TO BE COPIED TO. 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 *CPYMSS SUBROUTINE CPYMSS (N, M, X, IX, Y, IY) C C LATEST REVISION - 03/15/90 (JRD C C THIS ROUTINE COPIES THE N BY M ELEMENTS OF MATRIX X TO C MATRIX Y. 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 + IX,IY,M,N C C ARRAY ARGUMENTS REAL + X(IX,*),Y(IY,*) C C LOCAL SCALARS INTEGER + I,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VALUE. C INTEGER IX C THE FIRST DIMENSION OF THE MATRIX X. C INTEGER IY C THE FIRST DIMENSION OF THE MATRIX Y. C INTEGER J C AN INDEX VALUE. C INTEGER M C THE NUMBER OF COLUMNS OF DATA TO BE COPIED FROM MATRIX X. C INTEGER N C THE NUMBER OF ROWS OF DATA TO BE COPIED FROM MATRIX X. C REAL X(IX,M) C THE MATRIX TO BE COPIED FROM. C REAL Y(IY,M) C THE MATRIX TO BE COPIED TO. C C DO 20 J = 1, M DO 10 I = 1, N Y(I,J) = X(I,J) 10 CONTINUE 20 CONTINUE C RETURN C 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 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 *CSEVL REAL FUNCTION CSEVL (X, CS, N) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE THE N-TERM CHEBYSHEV SERIES CS AT X. ADAPTED FROM C R. BROUCKE, ALGORITHM 446, C.A.C.M., 16, 254 (1973). ALSO SEE FOX C AND PARKER, CHEBYSHEV POLYS IN NUMERICAL ANALYSIS, OXFORD PRESS, P.56. C C INPUT ARGUMENTS -- C X VALUE AT WHICH THE SERIES IS TO BE EVALUATED. C CS ARRAY OF N TERMS OF A CHEBYSHEV SERIES. IN EVAL- C UATING CS, ONLY HALF THE FIRST COEF IS SUMMED. C N NUMBER OF TERMS IN ARRAY CS. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X INTEGER N C C ARRAY ARGUMENTS REAL CS(N) C C LOCAL SCALARS REAL B0,B1,B2,TWOX INTEGER I,NI C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C IF (N.LT.1) CALL XERROR ('CSEVL NUMBER OF TERMS LE 0', 28, 2,2) IF (N.GT.1000) CALL XERROR ('CSEVL NUMBER OF TERMS GT 1000', 1 31, 3, 2) IF (X.LT.(-1.0) .OR. X.GT.1.0) CALL XERROR ( 1 'CSEVL X OUTSIDE (-1,+1)', 25, 1, 1) C B0 = 0.0 B1 = 0.0 B2 = 0.0 TWOX = 2.0*X DO 10 I=1,N B2 = B1 B1 = B0 NI = N + 1 - I B0 = TWOX*B1 - B2 + CS(NI) 10 CONTINUE C CSEVL = 0.5 * (B0-B2) C RETURN END DOUBLE PRECISION FUNCTION D9GMIT(A,X,ALGAP1,SGNGAM,ALX) C***BEGIN PROLOGUE D9GMIT C***DATE WRITTEN 770701 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C7E C***KEYWORDS COMPLEMENTARY,COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, C DOUBLE PRECISION,GAMMA,GAMMA FUNCTION,SPECIAL FUNCTON, C TRICOMI C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE COMPUTES D.P. TRICOMI-S INCOMPLETE GAMMA FUNCTION FOR C SMALL X. C***DESCRIPTION C C COMPUTE TRICOMI'S INCOMPLETE GAMMA FUNCTION FOR SMALL X. C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH,DLNGAM,XERROR C***END PROLOGUE D9GMIT C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,ALGAP1,ALX,SGNGAM,X C C LOCAL SCALARS DOUBLE PRECISION AE,AEPS,ALG2,ALGS,BOT,EPS,FK,S,SGNG2,T,TE INTEGER K,M,MA C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DLNGAM EXTERNAL D1MACH,DLNGAM C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DBLE,DSIGN,EXP,FLOAT,LOG C DATA EPS, BOT / 2*0.D0 / C***FIRST EXECUTABLE STATEMENT D9GMIT IF (EPS.NE.0.D0) GO TO 10 EPS = 0.5D0*D1MACH(3) BOT = LOG (D1MACH(1)) C 10 IF (X.LE.0.D0) CALL XERROR ( 'D9GMIT X SHOULD BE GT 0', 24, 1, 2) C MA = A + 0.5D0 IF (A.LT.0.D0) MA = A - 0.5D0 AEPS = A - DBLE(FLOAT(MA)) C AE = A IF (A.LT.(-0.5D0)) AE = AEPS C T = 1.D0 TE = AE S = T DO 20 K=1,200 FK = K TE = -X*TE/FK T = TE/(AE+FK) S = S + T IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 20 CONTINUE CALL XERROR ( 'D9GMIT NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SER 1IES', 54, 2, 2) C 30 IF (A.GE.(-0.5D0)) THEN ALGS = -ALGAP1 + LOG(S) ELSE ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) S = 1.0D0 M = -MA - 1 IF (M.EQ.0) GO TO 50 T = 1.0D0 DO 40 K=1,M T = X*T/(AEPS-DBLE(FLOAT(M+1-K))) S = S + T IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 40 CONTINUE C 50 D9GMIT = 0.0D0 ALGS = -DBLE(FLOAT(MA))*LOG(X) + ALGS IF (S.NE.0.0D0 .AND. AEPS.NE.0.0D0) THEN SGNG2 = SGNGAM * DSIGN (1.0D0, S) ALG2 = -X - ALGAP1 + LOG(ABS(S)) C IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2) IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS) RETURN END IF END IF C D9GMIT = EXP (ALGS) RETURN C END *D9LGIC DOUBLE PRECISION FUNCTION D9LGIC(A,X,ALX) C***BEGIN PROLOGUE D9LGIC C***DATE WRITTEN 770701 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C7E C***KEYWORDS DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION, C LOGARITHM INCOMPLETE GAMMA FUNCTION,SPECIAL FUNCTION C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE COMPUTES THE D.P. LOG INCOMPLETE GAMMA FUNCTION FOR LARGE X C AND FOR A .LE. X. C***DESCRIPTION C C COMPUTE THE LOG COMPLEMENTARY INCOMPLETE GAMMA FUNCTION FOR LARGE X C AND FOR A .LE. X. C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH,XERROR C***END PROLOGUE D9LGIC C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,ALX,X C C LOCAL SCALARS DOUBLE PRECISION EPS,FK,P,R,S,T,XMA,XPA INTEGER K C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG C DATA EPS / 0.D0 / C***FIRST EXECUTABLE STATEMENT D9LGIC IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) C XPA = X + 1.0D0 - A XMA = X - 1.D0 - A C R = 0.D0 P = 1.D0 S = P DO 10 K=1,300 FK = K T = FK*(A-FK)*(1.D0+R) R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) P = R*P S = S + P IF (ABS(P).LT.EPS*S) GO TO 20 10 CONTINUE CALL XERROR ( 'D9LGIC NO CONVERGENCE IN 300 TERMS OF CONTINUED FR 1ACTION', 57, 1, 2) C 20 D9LGIC = A*ALX - X + LOG(S/XPA) C RETURN END *D9LGIT DOUBLE PRECISION FUNCTION D9LGIT(A,X,ALGAP1) C***BEGIN PROLOGUE D9LGIT C***DATE WRITTEN 770701 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. C7E C***KEYWORDS DOUBLE PRECISION,GAMMA,INCOMPLETE GAMMA FUNCTION, C LOGARITHM,SPECIAL FUNCTION,TRICOMI C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE COMPUTES THE LOG OF TRICOMI'S INCOMPLETE GAMMA FUNCTION C WITH PERRON'S CONTINUED FRACTION FOR LARGE X AND A .GE. X. C***DESCRIPTION C C COMPUTE THE LOG OF TRICOMI'S INCOMPLETE GAMMA FUNCTION WITH PERRON'S C CONTINUED FRACTION FOR LARGE X AND FOR A .GE. X. C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH,XERROR C***END PROLOGUE D9LGIT C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,ALGAP1,X C C LOCAL SCALARS DOUBLE PRECISION A1X,AX,EPS,FK,HSTAR,P,R,S,SQEPS,T INTEGER K C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSQRT,LOG C DATA EPS, SQEPS / 2*0.D0 / C***FIRST EXECUTABLE STATEMENT D9LGIT IF (EPS.NE.0.D0) GO TO 10 EPS = 0.5D0*D1MACH(3) SQEPS = DSQRT (D1MACH(4)) C 10 IF (X.LE.0.D0 .OR. A.LT.X) CALL XERROR ( 'D9LGIT X SHOULD BE GT 0 1.0 AND LE A', 35, 2, 2) C AX = A + X A1X = AX + 1.0D0 R = 0.D0 P = 1.D0 S = P DO 20 K=1,200 FK = K T = (A+FK)*X*(1.D0+R) R = T/((AX+FK)*(A1X+FK)-T) P = R*P S = S + P IF (ABS(P).LT.EPS*S) GO TO 30 20 CONTINUE CALL XERROR ( 'D9LGIT NO CONVERGENCE IN 200 TERMS OF CONTINUED FR 1ACTION', 57, 3, 2) C 30 HSTAR = 1.0D0 - X*S/A1X IF (HSTAR.LT.SQEPS) CALL XERROR ( 'D9LGIT RESULT LESS THAN HALF P 1RECISION', 39, 1, 1) C D9LGIT = -X - ALGAP1 - LOG(HSTAR) RETURN C END *D9LGMC DOUBLE PRECISION FUNCTION D9LGMC (X) C AUGUST 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C COMPUTE THE LOG GAMMA CORRECTION FACTOR FOR X .GE. 10. SO THAT C LOG (DGAMMA(X)) = LOG(DSQRT(2*PI)) + (X-.5)*LOG(X) - X + D9LGMC(X) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION XBIG,XMAX INTEGER NALGM C C LOCAL ARRAYS DOUBLE PRECISION ALGMCS(15) C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DCSEVL INTEGER INITDS EXTERNAL D1MACH,DCSEVL,INITDS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC DSQRT,EXP,LOG,MIN,SNGL C C C SERIES FOR ALGM ON THE INTERVAL 0. TO 1.00000E-02 C WITH WEIGHTED ERROR 1.28E-31 C LOG WEIGHTED ERROR 30.89 C SIGNIFICANT FIGURES REQUIRED 29.81 C DECIMAL PLACES REQUIRED 31.48 C DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / C DATA NALGM, XBIG, XMAX / 0, 2*0.D0 / C IF (NALGM.NE.0) GO TO 10 NALGM = INITDS (ALGMCS, 15, SNGL(D1MACH(3)) ) XBIG = 1.0D0/DSQRT(D1MACH(3)) XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) C 10 IF (X.LT.10.D0) CALL XERROR ('D9LGMC X MUST BE GE 10', 23, 1, 2) IF (X.GE.XMAX) GO TO 20 C D9LGMC = 1.D0/(12.D0*X) IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, 1 NALGM) / X RETURN C 20 D9LGMC = 0.D0 CALL XERROR ('D9LGMC X SO BIG D9LGMC UNDERFLOWS', 34, 2, 1) RETURN C END *DBETAI DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C BASED ON BOSTEN AND BATTISTE, REMARK ON ALGORITHM 179, COMM. ACM, C V 17, P 156, (1974). C C INPUT ARGUMENTS -- C X UPPER LIMIT OF INTEGRATION. X MUST BE IN (0,1) INCLUSIVE. C P FIRST BETA DISTRIBUTION PARAMETER. P MUST BE GT 0.0. C Q SECOND BETA DISTRIBUTION PARAMETER. Q MUST BE GT 0.0. C BETAI THE INCOMPLETE BETA FUNCTION RATIO IS THE PROBABILITY THAT A C RANDOM VARIABLE FROM A BETA DISTRIBUTION HAVING PARAMETERS C P AND Q WILL BE LESS THAN OR EQUAL TO X. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION PIN,QIN,X C C LOCAL SCALARS DOUBLE PRECISION ALNEPS,ALNSML,C,EPS,FAC1,FAC2,FINSUM,P,PS,Q,SML, + TERM,XB,Y REAL P1 INTEGER I,IB,N C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DLBETA EXTERNAL D1MACH,DLBETA C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DBLE,EXP,FLOAT,INT,LOG,MAX,MIN,SNGL C DATA EPS, ALNEPS, SML, ALNSML / 4*0.0D0 / C IF (EPS.NE.0.0D0) GO TO 10 EPS = D1MACH(3) ALNEPS = LOG (EPS) SML = D1MACH(1) ALNSML = LOG (SML) C 10 IF (X.LT.0.D0 .OR. X.GT.1.D0) CALL XERROR ( 1 'DBETAI X IS NOT IN THE RANGE (0,1)', 35, 1, 2) IF (PIN.LE.0.D0 .OR. QIN.LE.0.D0) CALL XERROR ( 1 'DBETAI P AND/OR Q IS LE ZERO', 29, 2, 2) C Y = X P = PIN Q = QIN IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20 IF (X.LT.0.2D0) GO TO 20 Y = 1.0D0 - Y P = QIN Q = PIN C 20 IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80 C C EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . C PS = Q - INT(Q) IF (PS.EQ.0.D0) PS = 1.0D0 XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) DBETAI = 0.0D0 IF (XB.GE.ALNSML) THEN DBETAI = EXP(XB) FAC2 = 1.0 IF (PS.NE.1.0D0) THEN FAC1 = 1.0 N = MAX(ALNEPS/LOG(Y), 4.0D0) DO 30 I=1,N IF ((I-PS.EQ.0.0D0) .OR. (FAC1.EQ.0.0D0)) THEN FAC1 = 0.0D0 ELSE IF (LOG(ABS(FAC1)) + LOG(ABS(I-PS)) + LOG(Y) - + LOG(DBLE(I)) .LT. ALNSML) THEN FAC1 = 0.0D0 ELSE FAC1 = FAC1 * (I-PS)*Y/I END IF END IF FAC2 = FAC2 + FAC1*P/(P+I) 30 CONTINUE END IF DBETAI = DBETAI*FAC2 END IF C C NOW EVALUATE THE FINITE SUM, MAYBE. C IF (Q.LE.1.0D0) GO TO 70 C XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) IB = MAX(SNGL(XB/ALNSML), 0.0) TERM = EXP (XB - DBLE(FLOAT(IB))*ALNSML ) C = 1.0D0/(1.D0-Y) P1 = Q*C/(P+Q-1.D0) C FINSUM = 0.0D0 N = Q IF (Q.EQ.DBLE(FLOAT(N))) N = N - 1 DO 50 I=1,N IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 IF (Q-I+1.0D0 .EQ. 0.0D0) THEN TERM = 0.0D0 ELSE IF (LOG(ABS(Q-I+1.0D0)) + LOG(ABS(C)) + LOG(ABS(TERM)) - + LOG(ABS(P+Q-I)) .LT. ALNSML) THEN TERM = 0.0D0 ELSE TERM = (Q-I+1.0D0)*C*TERM/(P+Q-I) END IF END IF C IF (TERM.GT.1.0D0) IB = IB - 1 IF (TERM.GT.1.0D0) TERM = TERM*SML C IF (IB.EQ.0) FINSUM = FINSUM + TERM 50 CONTINUE C 60 DBETAI = DBETAI + FINSUM 70 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) RETURN C 80 DBETAI = 0.0D0 XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB) IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI C RETURN END *DCKCNT SUBROUTINE DCKCNT(XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA, NTAU, + SCALE, LSCALE, NROW, NPRT, HDR, PAGE, WIDE, ISUBHD, HLFRPT, + PRTFXD, IFIXED, LIFIXD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CONTROLS THE DERIVATIVE CHECKING 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 INTEGER + ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,NROW,NTAU LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),SCALE(LSCALE),XM(IXM,M) INTEGER + IFIXED(LIFIXD) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,HDR,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + D,ETA,FPLRS,PV,SCL,TAU INTEGER + DTEMP,IFIXD,IFP,INDXD,INDXPV,J,LMSG,MSG,NALL0,NDD,NDGT1, + NDGT2,NROWU,PARTMP,PVTEMP C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + STKGET,STKST EXTERNAL R1MACH,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYVII,DCKMN,DCKOUT,ETAMDL,SETIV,SETROW,STKCLR C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL D C THE SCALAR IN WHICH ROW NROWU OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER DTEMP C THE STARTING LOCATION IN THE WORK AREA IN WHICH C THE ARRAY IN WHICH THE ANALYTIC DERIVATIVES WITH C RESPECT TO EACH UNKNOWN PARAMETER ARE STORED. C REAL ETA C THE RELATIVE NOISE IN THE MODEL. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C EXTERNAL HDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING 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 .EQ. 1, ERRORS HAVE BEEN 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 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 C IFIXED(I).EQ.0, 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 INDXD, INDXPV C THE INDEX IN THE WORK AREA OF C THE LOCATION OF THE VALUE OF THE C DERIVATIVE WITH RESPECT TO THE JTH PARAMETER AT ROW NROWU C AND OF THE LOCATION OF THE PREDICTED VALUE FROM THE MODEL FOR R C ROW NROWU . 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 BY C ROUTINE HDR. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C AN INDEX VARIABLE. C INTEGER LIFIXD C THE LENGTH OF THE VECTOR IFIXED. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER LSCALE C THE LENGTH 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 MSG C THE STARTING LOCATION IN THE WORK AREA OF C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NDD C THE NUMBER OF DECIMAL DIGITS CARRIED FOR A SINGLE C PRECISION REAL 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 NDGT2 C THE ACTUAL NUMBER OF DIGITS OF AGREEMENT USED, EITHER C SET TO THE USER SUPPLIED VALUE OF NTAU, OR COMPUTED C FROM NDGT1. C INTEGER NETA C THE USER SUPPLIED NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. 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 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 INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. 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 REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C INTEGER PVTEMP C THE STARTING LOCATION IN THE WORK AREA OF C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C REAL SCL C THE ACTUAL TYPICAL SIZE USED. C REAL TAU C THE AGREEMENT TOLERANCE. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C FULL WIDTH (TRUE) OR NOT (FALSE). C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C NALL0 = STKST(1) C FPLRS = R1MACH(4) C C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C CALL SETROW(NROW, XM, N, M, IXM, NROWU) C C SUBDIVIDE WORK AREA C IFP = 3 C LMSG = NPAR + 1 C IFIXD = STKGET(NPAR,2) MSG = STKGET(LMSG,2) DTEMP = STKGET(N*NPAR,IFP) PARTMP = STKGET(NPAR,IFP) PVTEMP = STKGET(N,IFP) C IF (IERR.EQ.1) RETURN 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 = -LOG10(FPLRS) C IF ((NETA.LT.2) .OR. (NETA.GT.NDD)) THEN CALL ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NDGT1, + RSTAK(PARTMP), RSTAK(PVTEMP), NROWU) ELSE ETA = 10.0E0**(-NETA) NDGT1 = NETA END IF C IF ((NTAU.LT.1) .OR. (NTAU.GT.(NDGT1-1)/2)) THEN NDGT2 = (NDGT1+3)/4 ELSE NDGT2 = NTAU END IF C TAU = 10.0E0**(-NDGT2) C INDXPV = PVTEMP + NROWU - 1 C C COMPUTE PREDICTED VALUE OF MODEL USING CURRENT PARAMETER C ESTIMATES, AND COMPUTE USER-SUPPLIED DERIVATIVE VALUES C CALL MDL(PAR, NPAR, XM, N, M, IXM, RSTAK(PVTEMP)) PV = RSTAK(INDXPV) CALL DRV(PAR, NPAR, XM, N, M, IXM, RSTAK(DTEMP)) C ISTAK(MSG) = 0 C DO 30 J=1,NPAR C IF (SCALE(1).GT.0.0E0) THEN SCL = SCALE(J) ELSE SCL = PAR(J) END IF IF (SCL.EQ.0.0E0) SCL = 1.0E0 C C CALL ROUTINE TO CHECK USER SUPPLIED NUMERICAL DERIVATIVES C WITH RESPECT TO THE JTH PARAMETER. C INDXD = DTEMP - 1 + N*(J-1) + NROWU C D = RSTAK(INDXD) CALL DCKMN(J, D, PAR, SCL, NPAR, ETA, TAU, MDL, XM, N, NROWU, + M, IXM, PV, RSTAK(PVTEMP), ISTAK(MSG), LMSG) C 30 CONTINUE C IF (ISTAK(MSG).GE.1) IERR = ISTAK(MSG) + 1 C C PRINT RESULTS IF THEY ARE DESIRED C HLFRPT = .FALSE. C IF ((NPRT.NE.0) .OR. (IERR.NE.0)) THEN HLFRPT = .TRUE. CALL DCKOUT(XM,IXM,N,M,NROWU,NDGT1,NDGT2,NPAR,ISTAK(MSG), + LMSG,PAR,SCALE,LSCALE,HDR,PAGE,WIDE,ISUBHD,PRTFXD, + ISTAK(IFIXD)) END IF C CALL STKCLR(NALL0) C RETURN C END *DCKCRV SUBROUTINE DCKCRV(J, D, PAR, NPAR, ETA, TAU, MDL, XM, N, + NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP, STP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER HIGH CURVATURE COULD BE THE CAUSE C OF THE DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC 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 REAL + D,ETA,FD,PARMX,PV,PVPSTP,STP,TAU INTEGER + IXM,J,LMSG,M,N,NPAR,NROW C C ARRAY ARGUMENTS REAL + PAR(NPAR),PVTEMP(N),XM(IXM,M) INTEGER + MSG(LMSG) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS REAL + CURVE,FPLRS,PVMCRV,PVPCRV,STPCRV,TEMP,THIRD C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL DCKFPA C C INTRINSIC FUNCTIONS INTRINSIC ABS,SIGN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL ETA C THE RELATIVE NOISE IN THE MODEL. C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. 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 MSG(LMSG) C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE. C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVMCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)-STPCRV. C REAL PVPCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCRV. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL STPCRV C THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. C REAL TAU C THE AGREEMENT TOLERANCE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL THIRD C THE VALUE ONE THIRD. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C FPLRS = R1MACH(4) C THIRD = 1.0E0/3.0E0 C STPCRV = (ETA**THIRD*PARMX*SIGN(1.0E0,PAR(J))+PAR(J)) - PAR(J) C TEMP = PAR(J) PAR(J) = TEMP + STPCRV CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) C PVPCRV = PVTEMP(NROW) C PAR(J) = TEMP - STPCRV CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) PAR(J) = TEMP C PVMCRV = PVTEMP(NROW) C C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL WITH RESPECT TO C PAR(J) C CURVE = ((PVPCRV+PVMCRV)-2*PV) / (STPCRV*STPCRV) CURVE = CURVE + (ETA ** THIRD) * (ABS(PVPCRV) + + ABS(PVMCRV) + 2.0E0 * ABS(PV)) / (PARMX * PARMX) C C COMPARE NUMERICAL AND ANALYTICAL DERIVATIVES USING A FUDGE C FACTOR OF 10.0E0. C IF (ABS(CURVE*STP)*5.0E0.LT.ABS(FD-D)) THEN C C CURVATURE CANNOT ACCOUNT FOR DISCREPANCY. C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. C CALL DCKFPA(J,D,PAR,NPAR,ETA,TAU,MDL,XM,N,NROW, + M,IXM,PV,PVTEMP,MSG,LMSG,FD,PARMX,STP,PVPSTP,CURVE) C ELSE C C HIGH CURVATURE COULD BE THE PROBLEM. TRY A SMALLER STEP SIZE. C COMPUTE SMALLER STEPSIZE C STP = (2.0E0*TAU*ABS(D)*SIGN(1.0E0,PAR(J))/ABS(CURVE)+PAR(J)) + - PAR(J) C IF (ABS(STP).LE.FPLRS*ABS(PAR(J))) THEN C C NEW STEP SIZE IS TOO SMALL TO USE. C IF (MSG(1).EQ.0) MSG(1) = 1 MSG(J+1) = 1 ELSE C C TRY NEW STEP SIZE C TEMP = PAR(J) PAR(J) = TEMP + STP CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) PAR(J) = TEMP PVPSTP = PVTEMP(NROW) C C COMPUTE THE NEW NUMERICAL DERIVATIVE C FD = (PVPSTP-PV)/STP C C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS NOT OK C IF (ABS(FD-D).GT.2.0E0*TAU*ABS(D)) THEN C C NUMERICAL DERIVATIVE COMPUTED USING NEW STEP SIZE DOES C NOT AGREE WITH ANALYTIC DERIVATIVE. C C CHECK IF THE PROBLEM COULD BE THE FORWARD DIFFERENCE QUOTIENT C DERIVATIVE. C (FUDGE FACTOR IS 2) C IF (ABS(STP*(FD-D)).GE.2.0E0*ETA*ABS(PV+PVPSTP)) THEN C C FINITE PRECISION COULD NOT BE THE CULPRIT C MSG(1) = 2 MSG(J+1) = 2 ELSE C C FINITE PRECISION MAY BE THE CULPRIT C IF (MSG(1).EQ.0) MSG(1) = 1 MSG(J+1) = 1 END IF END IF END IF END IF RETURN C END *DCKDRV SUBROUTINE DCKDRV (NMSUB, LDSTAK, XM, N, M, IXM, MDL, + DRV, PAR, NPAR, NETA, NTAU, SCALE, LSCALE, NROW, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE IS THE DRIVER FOR THE DERIVATIVE CHECKING 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 INTEGER + IXM,LDSTAK,LSCALE,M,N,NETA,NPAR,NPRT,NROW,NTAU C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),XM(*) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + ISUBHD,LIFIXD LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C LOCAL ARRAYS INTEGER + IFIXED(1) C C EXTERNAL SUBROUTINES EXTERNAL DCKCNT,DCKER,DCKHDR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL DCKHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C ANALYTIC DERIVATIVES (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 .EQ. 1, ERRORS HAVE BEEN 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. IF C IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED. IF C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LIFIXD C THE LENGTH OF THE VECTOR IFIXED. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. 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 INTEGER NROW C THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT C VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE ARRAY C C C CHECK FOR ERRORS IN INPUT PARAMETERS C CALL DCKER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE) C IF (IERR.NE.0) RETURN C PAGE = .FALSE. WIDE = .TRUE. ISUBHD = 0 C PRTFXD = .FALSE. IFIXED(1) = -1 LIFIXD = 1 C CALL STKSET(LDSTAK, 4) C C PASS CONTROL OF DERIVATIVE CHECKING TO DCKCNT C CALL DCKCNT (XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA, + NTAU, SCALE, LSCALE, NROW, NPRT, DCKHDR, PAGE, WIDE, ISUBHD, + HLFRPT, PRTFXD, IFIXED, LIFIXD) C RETURN C END *DCKER SUBROUTINE DCKER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR DERIVATIVE CHECKING C 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 + IXM,LDSTAK,LSCALE,M,N,NPAR C C ARRAY ARGUMENTS REAL + SCALE(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,LDSMIN,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(10) CHARACTER + LIXM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1,LNPAR(8)*1, + LSCL(8)*1,LZERO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISLE,ERVGT,LDSCMP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(10) 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 VALUE. 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 WERE DETECTED. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. 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 LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8), LSCL(8), C * LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LSCALE C THE LENGTH OF VECTOR SCALE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND BY THE SCALE CHECKING ROUTINE. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C C SET UP NAME ARRAYS C DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6), + LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/ DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M', + ' ',' ',' ',' ',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ', + ' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5), + LNPAR(6), LNPAR(7), LNPAR(8) /'N','P',' ',' ',' ',' ',' ', + ' '/ DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5), + LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ', + ' '/ 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,10 ERROR(I) = .FALSE. 10 CONTINUE C IERR = 0 HEAD = .TRUE. C CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERROR(1), LN) C CALL EISGE(NMSUB, LM, M, 1, 1, HEAD, ERROR(2), LM) C CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(3), LN) C CALL EISLE(NMSUB, LNPAR, NPAR, N, 2, HEAD, ERROR(4), LN) C CALL LDSCMP(5, 0, 2*NPAR+1, 0, 0, 0, 'S', + N*NPAR + NPAR + N, LDSMIN) C IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(4))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(5), + LLDS) C CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV, + ERROR(9), LZERO) C DO 20 I=1,10 IF (ERROR(I)) GO TO 30 20 CONTINUE RETURN C 30 CONTINUE IERR = 1 RETURN C END *DCKFPA SUBROUTINE DCKFPA(J, D, PAR, NPAR, ETA, TAU, MDL, XM, N, + NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, STP, PVPSTP, + CURVE) C C LATEST REVISION - 03/15/90 (JRD) C C CHECK WHETHER FINITE PRECISION ARITHMETIC COULD POSSIBLY BE THE C PROBLEM 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 REAL + CURVE,D,ETA,FD,PARMX,PV,PVPSTP,STP,TAU INTEGER + IXM,J,LMSG,M,N,NPAR,NROW C C ARRAY ARGUMENTS REAL + PAR(NPAR),PVTEMP(N),XM(IXM,M) INTEGER + MSG(LMSG) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS REAL + TEMP LOGICAL + LARGE C C INTRINSIC FUNCTIONS INTRINSIC ABS,SIGN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LOGICAL LARGE C AN INDICATOR VALUE INDICATING WHETHER THE RECOMMENDED C INCREASE IN THE STEP SIZE WOULD BE GREATER THAN PARMX. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. 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 MSG(LMSG) C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL TAU C THE AGREEMENT TOLERANCE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C CHECK WHETHER FINITE PRECISION COULD BE THE PROBLEM C IF (ABS(STP*(FD-D)) .GE. + 10.0E0*ETA*(ABS(PV)+ABS(PVPSTP))) THEN C C DISCREPANCY BETWEEN NUMERICAL AND ANALYTICAL DERIVATIVES CANNOT C BE ACCOUNTED FOR BY FINITE PRECISION ARITHMETIC C MSG(1) = 2 MSG(J+1) = 2 RETURN C END IF C C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. C C TRY A LARGER STEP SIZE C STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(1.0E0,PAR(J))/ + (TAU*ABS(D))+PAR(J)) - PAR(J) C LARGE = .FALSE. C IF (ABS(STP).GT.PARMX) THEN STP = PARMX*SIGN(1.0E0,PAR(J)) LARGE = .TRUE. END IF C C CALCULATE NUMERICAL DERIVATIVE USNG NEW, LARGER, STEPSIZE C TEMP = PAR(J) PAR(J) = PAR(J) + STP CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) PAR(J) = TEMP C PVPSTP = PVTEMP(NROW) C FD = (PVPSTP-PV)/STP C C CHECK FOR AGREEMENT C IF ((ABS(FD-D)).LE.2.0E0*TAU*ABS(D)) THEN C C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE FOR C THIS STEP SIZE C RETURN END IF C C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES STILL C DISAGREE C C CHECK IF CURVATURE IS THE PROBLEM C IF (ABS(CURVE*STP) .LT. ABS(FD-D) .AND. (.NOT. LARGE)) THEN C C CURVATURE COULDNT BE THE CULPRIT C MSG(1) = 2 MSG(J+1) = 2 RETURN ELSE C C CURVATURE MAY BE THE CULPRIT C IF (MSG(1).EQ.0) MSG(1) = 1 IF (LARGE) MSG(J+1) = 6 IF (.NOT. LARGE) MSG(J+1) = 1 RETURN END IF C END *DCKHDR SUBROUTINE DCKHDR(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE C DERIVATIVE CHECKING 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 + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 FULL WIDTH (TRUE) OR NOT (FALSE). C CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (21H+DERIVATIVE CHECKING,, + 10H CONTINUED) 1010 FORMAT ('+', 23(1H*)/ 24H * DERIVATIVE CHECKING */ 1X, 23(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) END *DCKLS1 SUBROUTINE DCKLS1(N, M, IXM, PAR, NPAR, NETA, NTAU, NROW, SCALE, + NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE C ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY. 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,NETA,NPAR,NPRT,NROW,NTAU C C ARRAY ARGUMENTS REAL + PAR(10),SCALE(10) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. C REAL PAR(10) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL SCALE(10) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C C PAR(1) = 1.0E0 PAR(2) = 3.125E0 PAR(3) = 1.0E0 PAR(4) = 2.0E0 C N = 101 M = 1 IXM = 200 NPAR = 4 DO 10 I=1,10 SCALE(I) = 1.0E0 10 CONTINUE SCALE(2) = 0.01E0 NETA = 0 NTAU = 0 NROW = 1 NPRT = 1 C RETURN C END *DCKLSC SUBROUTINE DCKLSC(XM, N, M, IXM, MDL, DRV, PAR, NPAR, LDSTAK, + NETA, NTAU, SCALE, NROW, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR CHECKING USER SUPPLIED C ANALYTIC DERIVATIVES AGAINST NUMERICAL DERIVATIVES C FOR THE NONLINEAR LEAST SQUARES ROUTINES (SHORT CALL). 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,LDSTAK,M,N,NETA,NPAR,NPRT,NROW,NTAU C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),XM(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LSCALE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL DCKDRV,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL. 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 WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. 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 INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C REAL SCALE(NPAR) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'D','C','K','L','S','C'/ C LSCALE = NPAR C C PASS CONTROL OF DERIVATIVE CHECKING TO DCKDRV C CALL DCKDRV(NMSUB, LDSTAK, XM, N, M, IXM, MDL, DRV, PAR, NPAR, + NETA, NTAU, SCALE, LSCALE, NROW, NPRT) C IF (IERR.NE.1) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DCKLSC (XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, LDSTAK,'/ + ' + NETA, NTAU, SCALE, NROW, NPRT)') END *DCKLS SUBROUTINE DCKLS(XM, N, M, IXM, MDL, DRV, PAR, NPAR, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR CHECKING USER SUPPLIED C ANALYTIC DERIVATIVES AGAINST NUMERICAL DERIVATIVES C FOR THE NONLINEAR LEAST SQUARES ROUTINES (SHORT CALL). 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,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),XM(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LSCALE,NETA,NPRT,NROW,NTAU C C LOCAL ARRAYS REAL + SCALE(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL DCKDRV,IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C EXTERNAL DRV C THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE C ANALYTIC DERIVATIVES (JACOBIAN MATRIX) OF THE MODEL. 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 WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. 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 INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C REAL SCALE(1) C A DUMMY ARRAY, INDICATING USE OF DEFAULT VALUES FOR C THE TYPICAL SIZE OF THE PARAMETERS. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE MATRIX. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'D','C','K','L','S',' '/ C C SET DEFAULT VALUES C NETA = 0 NTAU = 0 SCALE(1) = 0.0E0 LSCALE = 1 NPRT = 1 NROW = 0 C C PASS CONTROL OF DERIVATIVE CHECKING TO DCKDRV C CALL DCKDRV(NMSUB, LDSTAK, XM, N, M, IXM, MDL, DRV, PAR, NPAR, + NETA, NTAU, SCALE, LSCALE, NROW, NPRT) C IF (IERR.NE.1) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DCKLS (XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, LDSTAK)') END *DCKMN SUBROUTINE DCKMN(J, D, PAR, SCALE, NPAR, ETA, TAU, MDL, XM, + N, NROW, M, IXM, PV, PVTEMP, MSG, LMSG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR CHECKING USER SUPPLIED C ANALYTIC DERIVATIVES 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 REAL + D,ETA,PV,SCALE,TAU INTEGER + IXM,J,LMSG,M,N,NPAR,NROW C C ARRAY ARGUMENTS REAL + PAR(NPAR),PVTEMP(N),XM(IXM,M) INTEGER + MSG(LMSG) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS REAL + FD,PARMX,PVPSTP,STP,TEMP C C EXTERNAL SUBROUTINES EXTERNAL DCKCRV,DCKZRO C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. 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 MSG(LMSG) C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUE FROM THE MODEL. C REAL SCALE C THE TYPICAL SIZE OF THE JTH PARAMETER. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL TAU C THE AGREEMENT TOLERANCE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES C MSG(J+1) = 0 C PARMX = MAX(ABS(PAR(J)),ABS(SCALE)) IF (PARMX .EQ. 0.0E0) PARMX = 1.0E0 C C COMPUTE INITIAL STEP SIZE C STP = (SQRT(ETA)*PARMX*SIGN(1.0E0,PAR(J))+PAR(J)) - PAR(J) C C COMPUTE PREDICTED VALUES C TEMP = PAR(J) PAR(J) = PAR(J) + STP CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) PAR(J) = TEMP C PVPSTP = PVTEMP(NROW) C FD = (PVPSTP-PV)/STP C C CHECK FOR DISAGREEMENT C IF (ABS(FD-D) .GT. TAU*ABS(D)) GO TO 10 C C NUMERICAL AND ANALYTIC DERIVATIVES AGREE C C CHECK IF ANALYTIC DERIVATIVE IS IDENTICALLY ZERO, INDICATING C THE POSSIBILITY THAT THE DERIVATIVE SHOULD BE RECHECKED AT C ANOTHER POINT. C IF (D.NE.0.0E0) RETURN C C JTH ANALYTIC AND NUMERICAL DERIVATIVES BOTH ARE ZERO. C IF (MSG(1).EQ.0) MSG(1) = 1 MSG(J+1) = 3 RETURN C 10 CONTINUE C C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE C C CHECK WHY C IF (D.EQ.0.0E0) THEN CALL DCKZRO(J, PAR, NPAR, MDL, XM, N, + NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP, + STP) ELSE CALL DCKCRV(J, D, PAR, NPAR, ETA, TAU, MDL, XM, + N, NROW, M, IXM, PV, PVTEMP, MSG, LMSG, FD, PARMX, + PVPSTP, STP) END IF C RETURN END *DCKOUT SUBROUTINE DCKOUT(XM, IXM, N, M, NROW, NETA, NTAU, NPAR, MSG, + LMSG, PAR, SCALE, LSCALE, HDR, PAGE, WIDE, ISUBHD, PRTFXD, + IFIXD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE RESULTS OF THE DERIVATIVE CHECKING C SUBROUTINE 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 + ISUBHD,IXM,LMSG,LSCALE,M,N,NETA,NPAR,NROW,NTAU LOGICAL + PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),SCALE(LSCALE),XM(IXM,M) INTEGER + IFIXD(NPAR),MSG(LMSG) C C SUBROUTINE ARGUMENTS EXTERNAL HDR C C LOCAL SCALARS INTEGER + I,IMAX,IMIN,INDEX,IPRT,J,K,NPERL CHARACTER + BLANK*1 C C LOCAL ARRAYS LOGICAL + FTNOTE(6) CHARACTER + FIXED(3)*1 C C EXTERNAL SUBROUTINES EXTERNAL FIXPRT,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 BLANK C THE CHARACTER BLANK. C CHARACTER*1 FIXED(3) C THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT. C LOGICAL FTNOTE(6) C THE ARRAY WHICH CONTROLS PRINTING OF FOOTNOTES. C EXTERNAL HDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING C INTEGER I C AN INDEX VARIABLE 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 IMAX, IMIN C THE LARGEST AND SMALLEST INDEX VALUE TO BE PRINTED ON EACH C LINE. C INTEGER INDEX C THE INDEX VALUE TO BE PRINTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED BY C ROUTINE HDR. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C AN INDEX VARIABLE. C INTEGER K C AN INDEX VARIABLE. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER LSCALE C THE LENGTH OF VECTOR SCALE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MSG(LMSG) C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPERL C THE NUMBER OF VALUES TO BE PRINTED PER LINE. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C APPROXIMATED DERIVATIVES AND THE USER-SUPPLIED DERIVATIVES. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C FULL WIDTH (TRUE) OR NOT (FALSE). C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C DATA BLANK /' '/ C CALL IPRINT(IPRT) C C INITIALIZE ARRAY FIXED C DO 10 K=1,3 FIXED(K) = BLANK 10 CONTINUE C CALL HDR(PAGE, WIDE, ISUBHD) C C SET UP FOR FOOTNOTES C DO 20 I=1,6 FTNOTE(I) = .FALSE. 20 CONTINUE C IF (MSG(1).LE.0) GO TO 40 C DO 30 I=1,NPAR IF ((MSG(I+1).EQ.0) .OR. (MSG(I+1).EQ.2)) GO TO 30 K = MSG(I+1) - 2 IF (K.EQ.-1) K = 5 FTNOTE(1) = .TRUE. FTNOTE(K+1) = .TRUE. 30 CONTINUE C C PRINT REPORT C 40 CONTINUE C WRITE (IPRT,1000) IF (FTNOTE(1)) WRITE (IPRT,1040) IF (PRTFXD) WRITE (IPRT,1160) IF (.NOT.PRTFXD) WRITE (IPRT,1170) C IF (SCALE(1).LE.0.0E0) GO TO 60 C DO 50 I=1,NPAR IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED) K = MSG(I+1) - 2 IF (K.EQ.-1) K = 5 IF (K.EQ.-2) WRITE (IPRT,1010) I, (FIXED(J),J=1,3), PAR(I), + SCALE(I) IF (K.EQ.0) WRITE (IPRT,1020) I, (FIXED(J),J=1,3), PAR(I), + SCALE(I) IF (K.GE.1) WRITE (IPRT,1030) I, (FIXED(J),J=1,3), PAR(I), + SCALE(I), K 50 CONTINUE GO TO 80 C 60 CONTINUE C DO 70 I=1,NPAR IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED) K = MSG(I+1) - 2 IF (K.EQ.-1) K = 5 IF (K.EQ.-2) WRITE (IPRT,1180) I, (FIXED(J),J=1,3), PAR(I) IF (K.EQ.0) WRITE (IPRT,1190) I, (FIXED(J),J=1,3), PAR(I) IF (K.GE.1) WRITE (IPRT,1200) I, (FIXED(J),J=1,3), PAR(I), K 70 CONTINUE C 80 CONTINUE C C PRINT FOOTNOTES C IF (.NOT.FTNOTE(1)) GO TO 90 C WRITE (IPRT,1060) IF (FTNOTE(2)) WRITE (IPRT,1070) IF (FTNOTE(3)) WRITE (IPRT,1080) IF (FTNOTE(4)) WRITE (IPRT,1090) IF (FTNOTE(5)) WRITE (IPRT,1100) IF (FTNOTE(6)) WRITE (IPRT,1050) C 90 CONTINUE C WRITE (IPRT,1110) NETA WRITE (IPRT,1120) NTAU C C PRINT OUT ROW OF INDEPENDENT VARIABLE WHICH WAS CHECKED. C WRITE (IPRT,1130) NROW NPERL = 7 C DO 100 I=1,M,NPERL IMIN = I IMAX = MIN(I+NPERL-1,M) WRITE (IPRT,1140) (INDEX,INDEX=IMIN,IMAX) WRITE (IPRT,1150) (XM(NROW,INDEX),INDEX=IMIN,IMAX) 100 CONTINUE WRITE (IPRT,1210) N C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//) 1010 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 10X, 2HOK) 1020 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 7X, 9HINCORRECT) 1030 FORMAT (1X, I3, 5X, 3A1, 2G17.8, 5X, 14HQUESTIONABLE (, I1, ')') 1040 FORMAT (62X, 1H*) 1050 FORMAT (/48H (5) USER-SUPPLIED AND APPROXIMATED DERIVATIVES, + 14H DISAGREE, BUT/5X, 37H APPROXIMATED DERIVATIVE IS QUESTIONA, + 11HBLE BECAUSE, 6H RATIO/5X, 30H OF RELATIVE CURVATURE TO RELA, + 17HTIVE SLOPE IS TOO, 6H HIGH.) 1060 FORMAT (/53H * NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTE, + 2HS.) 1070 FORMAT (/48H (1) USER-SUPPLIED AND APPROXIMATED DERIVATIVES, + 11H AGREE, BUT/5X, 40H BOTH ARE ZERO. RECHECK AT ANOTHER ROW.) 1080 FORMAT (/48H (2) USER-SUPPLIED AND APPROXIMATED DERIVATIVES, + 15H MAY AGREE, BUT/5X, 36H USER-SUPPLIED DERIVATIVE IS IDENTIC, + 9HALLY ZERO, 17H AND APPROXIMATED/5X, 21H DERIVATIVE IS ONLY A, + 18HPPROXIMATELY ZERO., 25H RECHECK AT ANOTHER ROW.) 1090 FORMAT (/48H (3) USER-SUPPLIED AND APPROXIMATED DERIVATIVES, + 14H DISAGREE, BUT/5X, 37H USER-SUPPLIED DERIVATIVE IS IDENTICA, + 9HLLY ZERO., 12H RECHECK AT/5X, 13H ANOTHER ROW.) 1100 FORMAT (/48H (4) USER-SUPPLIED AND APPROXIMATED DERIVATIVES, + 14H DISAGREE, BUT/5X, 37H APPROXIMATED DERIVATIVE IS QUESTIONA, + 11HBLE BECAUSE, 13H EITHER RATIO/5X, 22H OF RELATIVE CURVATURE, + 25H TO RELATIVE SLOPE IS TOO, 9H HIGH, OR/5X, 13H SCALE(K) IS , + 6HWRONG.) 1110 FORMAT (/43H NUMBER OF RELIABLE DIGITS IN MODEL RESULTS, 25X, + 6H(NETA), 1X, I5) 1120 FORMAT (/40H NUMBER OF DIGITS IN DERIVATIVE CHECKING, 9H AGREEMEN, + 11HT TOLERANCE, 8X, 6H(NTAU), 1X, I5) 1130 FORMAT (/45H ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED, 23X, + 6H(NROW), 1X, I5/42H -VALUES OF THE INDEPENDENT VARIABLES AT, + 9H THIS ROW) 1140 FORMAT (10X, 5HINDEX, I5, 6I15) 1150 FORMAT (10X, 5HVALUE, 7(1X, G14.7)/) 1160 FORMAT (52X, 10HDERIVATIVE/7X, 24HPARAMETER STARTING VALUE, 6X, + 5HSCALE, 10X, 10HASSESSMENT/1X, 5HINDEX, 2X, 5HFIXED, 6X, + 5H(PAR), 12X, 7H(SCALE)/) 1170 FORMAT (17X, 9HPARAMETER, 26X, 10HDERIVATIVE/15X, 12HSTARTING VAL, + 2HUE, 8X, 5HSCALE, 10X, 10HASSESSMENT/1X, 5HINDEX, 13X, + 5H(PAR), 12X, 7H(SCALE)/) 1180 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 13X, 2HOK) 1190 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 10X, 9HINCORRECT) 1200 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 8X, 11HQUESTIONABL, + 3HE (, I1, ')') 1210 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5) END *DCKZRO SUBROUTINE DCKZRO(J, PAR, NPAR, MDL, XM, N, NROW, M, IXM, PV, + PVTEMP, MSG, LMSG, FD, PARMX, PVPSTP, STP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE RECHECKS THE DERIVATIES IN THE CASE WHERE THE FINITE C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC DERIVATIVE AND T C ANALYTIC DERIVATIVE IS ZERO. 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 REAL + FD,PARMX,PV,PVPSTP,STP INTEGER + IXM,J,LMSG,M,N,NPAR,NROW C C ARRAY ARGUMENTS REAL + PAR(NPAR),PVTEMP(N),XM(IXM,M) INTEGER + MSG(LMSG) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS REAL + CD,FPLRS,PVMSTP,TEMP,THIRD C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CD C THE CENTRAL DIFFERENCE QUOTIENT DERIVATIVE WITH C RESPECT TO THE JTH PARAMETER. C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. 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 MSG(LMSG) C AN ARRAY USED TO STORE MESSAGE PARAMETERS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE TYPICAL C VALUE OF THAT PARAMETER. C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVMSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) - STP. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL THIRD C THE VALUE 1/3. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C FPLRS = R1MACH(4) C C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP C SIZE OF 2*STP C TEMP = PAR(J) PAR(J) = PAR(J) - STP CALL MDL(PAR, NPAR, XM, N, M, IXM, PVTEMP) PAR(J) = TEMP C PVMSTP = PVTEMP(NROW) C CD = (PVPSTP-PVMSTP)/(2.0E0*STP) C C CHECK FOR DISAGREEMENT C IF (CD.NE.0.0E0) GO TO 10 C C NUMERICAL AND ANALYTIC DERIVATIVES NOW AGREE, BUT BOTH EQUAL ZERO, C INDICATING THAT DERIVATIVES SHOULD BE RECHECKED AT ANOTHER POINT. C IF (MSG(1).EQ.0) MSG(1) = 1 MSG(J+1) = 3 RETURN C 10 CONTINUE C C NUMERICAL AND ANALYTIC DERIVATIVE STILL DO NOT AGREE. C C CHECK IF NUMERICAL DERIVATIVE IS CLOSE TO ZERO. C THIRD = 1.0E0/3.0E0 IF (MIN(ABS(CD), ABS(FD))*PARMX .GT. ABS(PV*FPLRS**THIRD)) + GO TO 20 C C NUMERICAL DERIVATIVE IS CLOSE TO ZERO C IF (MSG(1).EQ.0) MSG(1) = 1 MSG(J+1) = 4 RETURN C 20 CONTINUE C C NUMERICAL DERIVATIVE NOT CLOSE TO ZERO C MSG(1) = 2 MSG(J+1) = 5 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 REAL + 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 REAL PARDF(MBO) C THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS. C REAL WORK(MBO,2) C A WORK ARRAY NECESSARY TO EXPAND THE DIFFERENCE FILTER. 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.0E0 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 *DCSEVL DOUBLE PRECISION FUNCTION DCSEVL (X, A, N) C C LATEST REVISION - OCTOBER 3, 1983 (JRD) C C EVALUATE THE N-TERM CHEBYSHEV SERIES A AT X. ADAPTED FROM C R. BROUCKE, ALGORITHM 446, C.A.C.M., 16, 254 (1973). C C INPUT ARGUMENTS -- C X DBLE PREC VALUE AT WHICH THE SERIES IS TO BE EVALUATED. C A DBLE PREC ARRAY OF N TERMS OF A CHEBYSHEV SERIES. IN EVAL- C UATING A, ONLY HALF THE FIRST COEF IS SUMMED. C N NUMBER OF TERMS IN ARRAY A. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X INTEGER N C C ARRAY ARGUMENTS DOUBLE PRECISION A(N) C C LOCAL SCALARS DOUBLE PRECISION B0,B1,B2,TWOX INTEGER I,NI1 C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C IF (N.LT.1) CALL XERROR ('DCSEVL NUMBER OF TERMS LE 0', 28, 2,2) IF (N.GT.1000) CALL XERROR ('DCSEVL NUMBER OF TERMS GT 1000', 1 31, 3, 2) IF (X.LT.(-1.D0) .OR. X.GT.1.D0) CALL XERROR ( 1 'DCSEVL X OUTSIDE (-1,+1)', 25, 1, 1) C TWOX = 2.0D0*X B0 = 0.0D0 B1 = 0.0D0 B2 = 0.0D0 DO 10 I=1,N B2 = B1 B1 = B0 NI1 = N-I+1 B0 = TWOX*B1 - B2 + A(NI1) 10 CONTINUE C DCSEVL = 0.5D0 * (B0-B2) C RETURN END *DEMDRV SUBROUTINE DEMDRV (Y, N, FD, FC, K, HLP, AMPL, PHASE, IPHASE, + NDEM, NPRT, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE DRIVER ROUTINE TO DEMODULATE SERIES C Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF C FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS C OF THE RESULTING FILTERED SERIES . 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 147 C ADAPTED FOR STARPAC BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FC,FD INTEGER + IPHASE,K,N,NDEM,NPRT C C ARRAY ARGUMENTS REAL + AMPL(N),HLP(K),PHASE(IPHASE,2),Y(N) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL DEMODU,DEMORD,DEMOUT,FLTSL,LPFLT,POLAR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AMPL(N) C THE ARRAY IN WHICH THE AMPLITUDES ARE STORED. C REAL FC C THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER. C REAL FD C THE DEMODULATION FREQUENCY. C REAL HLP(K) C THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE C STORED. C INTEGER K C THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW C PASS FILTER. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEM C THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN C THE AMPLITUDE AND PHASE ARRAYS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF NPRT C IS ZERO, NO OUTPUT IS GIVEN, OTHERWISE OUTPUT IS PROVIDED. C REAL PHASE(IPHASE,2) C THE ARRAY CONTIANING THE PRIMARY AND SECONDARY PHASE ESTIMATES. C REAL Y(N) C THE INPUT ARRAY CONTAINING THE OBSERVED SERIES. C C CALL DEMODU (Y, N, FD, AMPL, PHASE) CALL LPFLT (FC, K, HLP) CALL FLTSL (AMPL, N, K, HLP, AMPL, NDEM) CALL FLTSL (PHASE, N, K, HLP, PHASE, NDEM) C CALL POLAR (AMPL, PHASE, NDEM) C IF (NPRT .EQ. 0) RETURN C CALL DEMORD (PHASE, PHASE(1,2), NDEM, N) CALL DEMOUT (FD, FC, K, AMPL, PHASE, IPHASE, NDEM, NMSUB) C RETURN C END *DEMOD SUBROUTINE DEMOD (Y, N, FD, FC, K, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE TO DEMODULATE SERIES C Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF C FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS C OF THE RESULTING FILTERED SERIES (SHORT CALL). 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 147 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 REAL + FC,FD INTEGER + K,LDSTAK,N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + TEMP INTEGER + AMPL,HLP,IFP,IPRT,LDSMIN,NALL0,NDEM,PHASE LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LFC(8)*1,LFD(8)*1,LK(8)*1,LKIN(8)*1,LLDS(8)*1,LN(8)*1, + LNM1(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL DEMDRV,EISGE,EISII,ERIODD,ERSII,ERSLFS,IPRINT,LDSCMP, + STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER AMPL C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE ARRAY IN WHICH THE AMPLITUDES ARE STORED. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07 C VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FC C THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER. C REAL FD C THE DEMODULATION 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 HLP C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE C STORED. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER K C THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW C PASS FILTER. 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 LFC(8), LFD(8), LK(8), LKIN(8), LLDS(8), LN(8), C * LNM1(8), LONE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C INTEGER NDEM C THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN C THE AMPLITUDE AND PHASE ARRAYS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER PHASE C THE STARTING LOCATIONS IN RSTAK/DSTAK OF C THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE ESTIMATES. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL TEMP C A TEMPORARY VARIABLE USED FOR TYPE CONVERSION. C REAL Y(N) C THE INPUT ARRAY CONTAINING THE OBSERVED SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'E', 'M', 'O', 'D', ' '/ DATA + LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8) + / 'F', 'C', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LFD(1), LFD(2), LFD(3), LFD(4), LFD(5), LFD(6), LFD(7), LFD(8) + / 'F', 'D', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LKIN(1), LKIN(2), LKIN(3), LKIN(4), LKIN(5), LKIN(6), LKIN(7), + LKIN(8) / '(', '1', '/', 'K', ')', ' ', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7), + LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), LNM1(7), + LNM1(8) / '(', 'N', '-', '1', ')', ' ', ' ', ' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7), + LONE(8) / 'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ C C PERFORM ERROR CHECKING ON INPUT DATA. C IERR = 0 HEAD = .TRUE. C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN) C CALL ERSII(NMSUB, LFD, FD, + 0.0E0, 0.5E0, 2, HEAD, ERR02, LFD, LFD) C ERR03 = .TRUE. IF (.NOT. ERR01) + CALL EISII(NMSUB, LK, K, 1, N-1, 1, HEAD, ERR03, LONE, LNM1) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04) C ERR05 = .TRUE. IF ((.NOT. ERR02) .AND. (.NOT. ERR03) .AND. (.NOT. ERR04)) THEN TEMP = K CALL ERSII(NMSUB, LFC, FC, 1.0E0/TEMP, FD, 1, HEAD, ERR05, + LKIN, LFD) END IF C ERR06 = .TRUE. IF ((.NOT. ERR03) .AND. (.NOT. ERR04) .AND. (.NOT. ERR05)) + CALL ERSLFS(NMSUB, FC, K, HEAD, ERR06) C IF (ERR01 .OR. ERR06) GO TO 10 C CALL LDSCMP(3, 0, 0, 0, 0, 0, 'S', K + 3*N, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR07, LLDS) C C IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05 .OR. ERR07) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C AMPL = STKGET(N, IFP) PHASE = STKGET(2*N, IFP) HLP = STKGET(K, IFP) C IF (IERR .EQ. 1) GO TO 10 C CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), RSTAK(AMPL), + RSTAK(PHASE), N, NDEM, 1, NMSUB) C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 10 C RETURN C C FORMAT STATEMENT C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DEMOD (Y, N, FD, FC, K, LDSTAK)') C END *DEMODS SUBROUTINE DEMODS (Y, N, FD, FC, K, AMPL, PHAS, NDEM, NPRT, + LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE TO DEMODULATE SERIES C Y AT FREQUENCY FD, TO APPLY A LOW PASS FILTER WITH CUTOFF C FREQUENCY FC, AND TO EXTRACT THE AMPLITUDE AND PHASE COMPONENTS C OF THE RESULTING FILTERED SERIES (LONG CALL). 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 147 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 REAL + FC,FD INTEGER + K,LDSTAK,N,NDEM,NPRT C C ARRAY ARGUMENTS REAL + AMPL(*),PHAS(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + TEMP INTEGER + HLP,IO,IPRT,LDSMIN,NALL0,PHASE LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LFC(8)*1,LFD(8)*1,LK(8)*1,LKIN(8)*1,LLDS(8)*1,LN(8)*1, + LNM1(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL DEMDRV,EISGE,EISII,ERIODD,ERSII,ERSLFS,IPRINT,LDSCMP, + SCOPY,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AMPL(N) C THE ARRAY IN WHICH THE AMPLITUDES ARE STORED. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FC C THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER. C REAL FD C THE DEMODULATION 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 HLP C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE ARRAY IN WHICH THE LOW PASS FILTER COEFFICIENTS ARE C STORED. 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 IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER K C THE USER SUPPLIED NUMBER OF TERMS TO BE USED FOR THE LOW C PASS FILTER. 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 LFC(8), LFD(8), LK(8), LKIN(8), LLDS(8), LN(8), C * LNM1(8), LONE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C INTEGER NDEM C THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN C THE AMPLITUDE AND PHASE ARRAYS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT C PRINTED OUTPUT IS TO BE GIVEN, WHERE IF THE VALUE OF NPRT C IS ZERO, NO OUTPUT IS GIVEN, OTHERWISE OUTPUT IS PROVIDED. C REAL PHAS(N) C THE ARRAY IN WHICH THE PRIMARY PHASE ESTIMATES ARE RETURNED. C INTEGER PHASE C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE ESTIMATES. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL TEMP C A TEMPORARY VARIABLE USED FOR TYPE CONVERSION. C REAL Y(N) C THE INPUT ARRAY CONTAINING THE OBSERVED SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'E', 'M', 'O', 'D', 'S'/ DATA + LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8) + / 'F', 'C', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LFD(1), LFD(2), LFD(3), LFD(4), LFD(5), LFD(6), LFD(7), LFD(8) + / 'F', 'D', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LKIN(1), LKIN(2), LKIN(3), LKIN(4), LKIN(5), LKIN(6), LKIN(7), + LKIN(8) / '(', '1', '/', 'K', ')', ' ', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7), + LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), LNM1(7), + LNM1(8) / '(', 'N', '-', '1', ')', ' ', ' ', ' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7), + LONE(8) / 'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ C C PERFORM ERROR CHECKING ON INPUT DATA. C IERR = 0 HEAD = .TRUE. C IF (NPRT.EQ.0) THEN IO = 0 ELSE IO = 1 END IF C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN) C CALL ERSII(NMSUB, LFD, FD, + 0.0E0, 0.5E0, 2, HEAD, ERR02, LFD, LFD) C ERR03 = .TRUE. IF (.NOT. ERR01) + CALL EISII(NMSUB, LK, K, 1, N-1, 1, HEAD, ERR03, LONE, LNM1) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04) C ERR05 = .TRUE. IF ((.NOT. ERR02) .AND. (.NOT. ERR03) .AND. (.NOT. ERR04)) THEN TEMP = K CALL ERSII(NMSUB, LFC, FC, 1.0E0/TEMP, FD, 1, HEAD, ERR05, + LKIN, LFD) END IF C ERR06 = .TRUE. IF ((.NOT. ERR03) .AND. (.NOT. ERR04) .AND. (.NOT. ERR05)) + CALL ERSLFS(NMSUB, FC, K, HEAD, ERR06) C IF (ERR01 .OR. ERR06) GO TO 10 C CALL LDSCMP(2, 0, 0, 0, 0, 0, 'S', K + IO*2*N, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR07, LLDS) C C IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05 .OR. ERR07) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C HLP = STKGET(K, 3) IF (NPRT.EQ.0) THEN PHASE = 1 ELSE PHASE = STKGET(2*N, 3) END IF C IF (IERR .EQ. 1) GO TO 10 C IF (NPRT .NE. 0) THEN C CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), AMPL, + RSTAK(PHASE), N, NDEM, NPRT, NMSUB) CALL SCOPY(NDEM, RSTAK(PHASE), 1, PHAS, 1) ELSE CALL DEMDRV(Y, N, FD, FC, K, RSTAK(HLP), AMPL, + PHAS, N, NDEM, NPRT, NMSUB) END IF C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 10 C RETURN C C FORMAT STATEMENT C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DEMODS (Y, N, FD, FC, K,'/ + ' + AMPL, PHAS, NDEM, NPRT, LDSTAK)') C END *DEMODU SUBROUTINE DEMODU (Y, N, FD, AMPL, PHAS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE DEMODULATES THE SERIES Y AT FREQUENCY C FD. THE REAL AND IMAGINARY PARTS OF THE DEMODULATED C SERIES ARE RETURNED IN AMPL AND PHAS, RESPECTIVELY. 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 148 C ADAPTED FOR STARPAC BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DEVISION C NATIONAL BUREAU OF STANDARDS C BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FD INTEGER + N C C ARRAY ARGUMENTS REAL + AMPL(N),PHAS(N),Y(N) C C LOCAL SCALARS REAL + ARG,PI INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AMPL(N) C THE ARRAY IN WHICH THE AMPLITUDES ARE STORED. C REAL ARG C A VALUE USED IN COMPUTING THE DEMODULATED SERIES. C REAL FD C THE DEMODULATION FREQUENCY. C INTEGER I C AN INDEXING VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES BEING DEMODULATED. C REAL PHAS(N) C THE ARRAYS CONTAINING THE PRIMARY PHASE ESTIMATES. C REAL PI C THE VALUE OF PI. C REAL Y(N) C THE INPUT ARRAY ARRAY CONTAINING THE OBSERVED SERIES. C CALL GETPI(PI) C DO 10 I = 1, N IF (FD.EQ.0.25E0) THEN AMPL(I) = 0.0E0 PHAS(I) = -2.0E0*Y(I) ELSE IF (FD.EQ.0.5E0) THEN AMPL(I) = -2.0E0*Y(I) PHAS(I) = 0.0E0 ELSE ARG = (I-1) * FD * 2.0E0 * PI AMPL(I) = Y(I)*COS(ARG)*2.0E0 PHAS(I) = -Y(I)*SIN(ARG)*2.0E0 END IF 10 CONTINUE RETURN END *DEMORD SUBROUTINE DEMORD (PHAS1, PHAS2, NDEM, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE SETS UP THE DATA FOR THE PHASE PLOTS. 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 + N,NDEM C C ARRAY ARGUMENTS REAL + PHAS1(N),PHAS2(N) C C LOCAL SCALARS REAL + PI INTEGER + I C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEXING VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES BEING DEMODULATED. C INTEGER NDEM C THE NUMBER OF VALUES IN THE DEMODULATED SERIES, I.E., IN C THE AMPLITUDE AND PHASE ARRAYS. C REAL PHAS1(N), PHAS2(N) C THE ARRAYS CONTAINING THE PRIMARY AND SECONDARY PHASE C ESTIMATES, RESPECTIVELY. C REAL PI C THE VALUE OF PI. C CALL GETPI(PI) C DO 10 I = 1, NDEM PHAS2(I) = 0.0E0 IF (PHAS1(I) .GT. 0.0E0) PHAS2(I) = PHAS1(I) - 2.0E0*PI IF (PHAS1(I) .LT. 0.0E0) PHAS2(I) = PHAS1(I) + 2.0E0*PI 10 CONTINUE C RETURN END *DEMOUT SUBROUTINE DEMOUT(FD, FC, K, AMPL, PHASE, IPHASE, NDEM, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRODUCES THE OUTPUT FOR THE TIME SERIES C DEMODULATION ROUTINE. 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 REAL + FC,FD INTEGER + IPHASE,K,NDEM C C ARRAY ARGUMENTS REAL + AMPL(NDEM),PHASE(IPHASE,2) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + PI,YMN,YMX INTEGER + IPRT LOGICAL + ERROR C C LOCAL ARRAYS INTEGER + ISYM(1) C C EXTERNAL SUBROUTINES EXTERNAL GETPI,IPRINT,VERSP,VPLMT,VPMN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AMPL(NDEM) C THE ARRAY IN WHICH THE AMPLITUDES OF THE DEMODULATED SERIES C ARE STORED. C LOGICAL ERROR C AN ERROR FLAG C REAL FC, FD C THE CUTOFF FREQUENCY AND THE DEMODULATION FREQUENCY. C INTEGER IERR C THE ERROR FLAG C INTEGER IPHASE C C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISYM(1) C A DUMMY ARRAY. C INTEGER K C THE NUMBER OF TERMS IN THE LOW PASS FILTER USED TO SMOOTH C THE DEMODULATED SERIES. C INTEGER NDEM C THE NUMBER OF VALUES IN THE DEMODULATED SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE C REAL PHASE(IPHASE,2) C THE ARRAY CONTAINING THE PRIMARY AND SECONDARY PHASE VALUES. C REAL PI C THE VALUE OF PI. C REAL YMN, YMX C C CALL IPRINT(IPRT) C CALL VERSP(.TRUE.) C CALL GETPI(PI) C WRITE (IPRT, 1000) FD, FC, K C WRITE (IPRT, 1001) CALL VPLMT(AMPL, AMPL, NDEM, 1, NDEM, 0.0E0, 0.0E0, + YMN, YMX, ERROR, NMSUB, .FALSE., 1) C IF (ERROR) THEN IERR = 1 RETURN ELSE CALL VPMN(AMPL, AMPL, NDEM, 1, NDEM, 1, 0, ISYM, 1, 0, + YMN, YMX, 1.0E0, 1.0E0, .FALSE., 0, 1, 0) END IF C WRITE (IPRT, 1002) CALL VERSP(.TRUE.) WRITE (IPRT, 1003) CALL VPMN(PHASE, PHASE, NDEM, 2, IPHASE, 1, 2, ISYM, 1, 0, + -2.0E0*PI, 2.0E0*PI, 1.0E0, 1.0E0, .FALSE., 0, 0, 0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/25H TIME SERIES DEMODULATION// + 26H DEMODULATION FREQUENCY IS, F10.8/ + 26H CUTOFF FREQUENCY IS , F10.8/ + 38H THE NUMBER OF TERMS IN THE FILTER IS , I5///) 1001 FORMAT (49H PLOT OF AMPLITUDE OF SMOOTHED DEMODULATED SERIES) 1002 FORMAT ('1') 1003 FORMAT (45H PLOT OF PHASE OF SMOOTHED DEMODULATED SERIES) END *DERFC DOUBLE PRECISION FUNCTION DERFC (X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION SQEPS,SQRTPI,XMAX,XSML,Y REAL ETA INTEGER NTERC2,NTERF,NTERFC C C LOCAL ARRAYS DOUBLE PRECISION ERC2CS(49),ERFCCS(59),ERFCS(21) C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DCSEVL INTEGER INITDS EXTERNAL D1MACH,DCSEVL,INITDS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSQRT,EXP,LOG,SNGL C C C SERIES FOR ERF ON THE INTERVAL 0. TO 1.00000E+00 C WITH WEIGHTED ERROR 1.28E-32 C LOG WEIGHTED ERROR 31.89 C SIGNIFICANT FIGURES REQUIRED 31.05 C DECIMAL PLACES REQUIRED 32.55 C DATA ERF CS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / DATA ERF CS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / DATA ERF CS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / DATA ERF CS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / DATA ERF CS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / DATA ERF CS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / DATA ERF CS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / DATA ERF CS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / DATA ERF CS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / DATA ERF CS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / DATA ERF CS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / DATA ERF CS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / DATA ERF CS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / DATA ERF CS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / DATA ERF CS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / DATA ERF CS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / DATA ERF CS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / DATA ERF CS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / DATA ERF CS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / DATA ERF CS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / DATA ERF CS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / C C SERIES FOR ERC2 ON THE INTERVAL 2.50000E-01 TO 1.00000E+00 C WITH WEIGHTED ERROR 2.67E-32 C LOG WEIGHTED ERROR 31.57 C SIGNIFICANT FIGURES REQUIRED 30.31 C DECIMAL PLACES REQUIRED 32.42 C DATA ERC2CS( 1) / -.6960134660 2309501127 3915082619 7 D-1 / DATA ERC2CS( 2) / -.4110133936 2620893489 8221208466 6 D-1 / DATA ERC2CS( 3) / +.3914495866 6896268815 6114370524 4 D-2 / DATA ERC2CS( 4) / -.4906395650 5489791612 8093545077 4 D-3 / DATA ERC2CS( 5) / +.7157479001 3770363807 6089414182 5 D-4 / DATA ERC2CS( 6) / -.1153071634 1312328338 0823284791 2 D-4 / DATA ERC2CS( 7) / +.1994670590 2019976350 5231486770 9 D-5 / DATA ERC2CS( 8) / -.3642666471 5992228739 3611843071 1 D-6 / DATA ERC2CS( 9) / +.6944372610 0050125899 3127721463 3 D-7 / DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7 / DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8 / DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9 / DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9 / DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10 / DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11 / DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11 / DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12 / DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13 / DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13 / DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14 / DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15 / DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15 / DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16 / DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16 / DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17 / DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18 / DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18 / DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19 / DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19 / DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20 / DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21 / DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21 / DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22 / DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22 / DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23 / DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24 / DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24 / DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25 / DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25 / DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26 / DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26 / DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27 / DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28 / DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28 / DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29 / DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29 / DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30 / DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31 / DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31 / C C SERIES FOR ERFC ON THE INTERVAL 0. TO 2.50000E-01 C WITH WEIGHTED ERROR 1.53E-31 C LOG WEIGHTED ERROR 30.82 C SIGNIFICANT FIGURES REQUIRED 29.47 C DECIMAL PLACES REQUIRED 31.70 C DATA ERFCCS( 1) / +.7151793102 0292477450 3697709496 D-1 / DATA ERFCCS( 2) / -.2653243433 7606715755 8893386681 D-1 / DATA ERFCCS( 3) / +.1711153977 9208558833 2699194606 D-2 / DATA ERFCCS( 4) / -.1637516634 5851788416 3746404749 D-3 / DATA ERFCCS( 5) / +.1987129350 0552036499 5974806758 D-4 / DATA ERFCCS( 6) / -.2843712412 7665550875 0175183152 D-5 / DATA ERFCCS( 7) / +.4606161308 9631303696 9379968464 D-6 / DATA ERFCCS( 8) / -.8227753025 8792084205 7766536366 D-7 / DATA ERFCCS( 9) / +.1592141872 7709011298 9358340826 D-7 / DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8 / DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9 / DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9 / DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10 / DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10 / DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11 / DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12 / DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12 / DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13 / DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13 / DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14 / DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14 / DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15 / DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15 / DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16 / DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16 / DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17 / DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17 / DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18 / DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18 / DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19 / DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19 / DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20 / DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20 / DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20 / DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21 / DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21 / DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22 / DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22 / DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23 / DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23 / DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23 / DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24 / DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24 / DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25 / DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25 / DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25 / DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26 / DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26 / DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27 / DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27 / DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27 / DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28 / DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28 / DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28 / DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29 / DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29 / DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29 / DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30 / DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30 / C DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / DATA NTERF, NTERFC, NTERC2, XSML, XMAX, SQEPS / 3*0, 3*0.D0 / C IF (NTERF.NE.0) GO TO 10 ETA = 0.1*SNGL(D1MACH(3)) NTERF = INITDS (ERFCS, 21, ETA) NTERFC = INITDS (ERFCCS, 59, ETA) NTERC2 = INITDS (ERC2CS, 49, ETA) C XSML = -DSQRT (-LOG(SQRTPI*D1MACH(3))) XMAX = DSQRT (-LOG(SQRTPI*D1MACH(1)) ) XMAX = XMAX - 0.5D0*LOG(XMAX)/XMAX - 0.01D0 SQEPS = DSQRT (2.0D0*D1MACH(3)) C 10 IF (X.GT.XSML) GO TO 20 C C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML C DERFC = 2.0D0 RETURN C 20 IF (X.GT.XMAX) GO TO 40 Y = ABS(X) IF (Y.GT.1.0D0) GO TO 30 C C ERFC(X) = 1.0 - ERF(X) FOR ABS(X) .LE. 1.0 C IF (Y.LT.SQEPS) THEN DERFC = 1.0D0 - 2.0D0*X/SQRTPI ELSE DERFC = 1.0D0 - X*(1.0D0+DCSEVL(2.0D0*X*X-1.0D0,ERFCS,NTERF)) END IF C RETURN C C ERFC(X) = 1.0 - ERF(X) FOR 1.0 .LT. ABS(X) .LE. XMAX C 30 Y = Y*Y IF (Y.LE.4.0D0) THEN DERFC = EXP(-Y)/ABS(X) * + (0.5D0 + DCSEVL((8.0D0/Y-5.0D0)/3.0D0,ERC2CS,NTERC2)) ELSE DERFC = EXP(-Y)/ABS(X) * + (0.5D0 + DCSEVL(8.0D0/Y-1.0D0,ERFCCS,NTERFC)) END IF IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC RETURN C 40 CALL XERROR ('DERFC X SO BIG ERFC UNDERFLOWS', 32, 1, 1) DERFC = 0.D0 RETURN C END *DERF DOUBLE PRECISION FUNCTION DERF (X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION SQEPS,SQRTPI,XBIG,Y INTEGER NTERF C C LOCAL ARRAYS DOUBLE PRECISION ERFCS(21) C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DCSEVL,DERFC INTEGER INITDS EXTERNAL D1MACH,DCSEVL,DERFC,INITDS C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSIGN,DSQRT,LOG,SNGL C C C SERIES FOR ERF ON THE INTERVAL 0. TO 1.00000E+00 C WITH WEIGHTED ERROR 1.28E-32 C LOG WEIGHTED ERROR 31.89 C SIGNIFICANT FIGURES REQUIRED 31.05 C DECIMAL PLACES REQUIRED 32.55 C DATA ERF CS( 1) / -.4904612123 4691808039 9845440333 76 D-1 / DATA ERF CS( 2) / -.1422612051 0371364237 8247418996 31 D+0 / DATA ERF CS( 3) / +.1003558218 7599795575 7546767129 33 D-1 / DATA ERF CS( 4) / -.5768764699 7674847650 8270255091 67 D-3 / DATA ERF CS( 5) / +.2741993125 2196061034 4221607914 71 D-4 / DATA ERF CS( 6) / -.1104317550 7344507604 1353812959 05 D-5 / DATA ERF CS( 7) / +.3848875542 0345036949 9613114981 74 D-7 / DATA ERF CS( 8) / -.1180858253 3875466969 6317518015 81 D-8 / DATA ERF CS( 9) / +.3233421582 6050909646 4029309533 54 D-10 / DATA ERF CS( 10) / -.7991015947 0045487581 6073747085 95 D-12 / DATA ERF CS( 11) / +.1799072511 3961455611 9672454866 34 D-13 / DATA ERF CS( 12) / -.3718635487 8186926382 3168282094 93 D-15 / DATA ERF CS( 13) / +.7103599003 7142529711 6899083946 66 D-17 / DATA ERF CS( 14) / -.1261245511 9155225832 4954248533 33 D-18 / DATA ERF CS( 15) / +.2091640694 1769294369 1705002666 66 D-20 / DATA ERF CS( 16) / -.3253973102 9314072982 3641600000 00 D-22 / DATA ERF CS( 17) / +.4766867209 7976748332 3733333333 33 D-24 / DATA ERF CS( 18) / -.6598012078 2851343155 1999999999 99 D-26 / DATA ERF CS( 19) / +.8655011469 9637626197 3333333333 33 D-28 / DATA ERF CS( 20) / -.1078892517 7498064213 3333333333 33 D-29 / DATA ERF CS( 21) / +.1281188399 3017002666 6666666666 66 D-31 / C DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 / DATA NTERF, XBIG, SQEPS / 0, 2*0.D0 / C IF (NTERF.NE.0) GO TO 10 NTERF = INITDS (ERFCS, 21, 0.1*SNGL(D1MACH(3))) XBIG = DSQRT (-LOG(SQRTPI*D1MACH(3))) SQEPS = DSQRT (2.0D0*D1MACH(3)) C 10 Y = ABS(X) IF (Y.GT.1.D0) GO TO 20 C C ERF(X) = 1.0 - ERFC(X) FOR -1.0 .LE. X .LE. 1.0 C IF (Y.LE.SQEPS) THEN DERF = 2.0D0*X*X/SQRTPI ELSE DERF = X*(1.0D0+DCSEVL(2.D0*X*X-1.D0,ERFCS,NTERF)) END IF C RETURN C C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0 C 20 IF (Y.LE.XBIG) THEN DERF = DSIGN (1.0D0-DERFC(Y), X) ELSE DERF = DSIGN (1.0D0, X) END IF C RETURN END *DFAULT SUBROUTINE DFAULT(IV, V) C C LATEST REVISION - 03/15/90 (JRD) C C C C VARIABLE DECLARATIONS C C ARRAY ARGUMENTS REAL + V(45) INTEGER + IV(25) C C LOCAL SCALARS REAL + 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 REAL + 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 REAL V(45) C/+ C REAL MAX C/ C EXTERNAL IMDCON, RMDCON C INTEGER IMDCON C REAL RMDCON C C REAL 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 DATA ONE/1.0E0/, THREE/3.0E0/ 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.0E-20 IF (MACHEP .GT. 1.0E-10) V(AFCTOL) = MACHEP**2 V(COSMIN) = MAX(1.0E-6, 1.0E2 * MACHEP) V(DECFAC) = 0.5E0 SQTEPS = RMDCON(4) V(DELTA0) = SQTEPS V(DFAC) = 0.6E0 V(DINIT) = 0.0E0 MEPCRT = MACHEP ** (ONE/THREE) V(DLTFDC) = MEPCRT V(DLTFDJ) = SQTEPS V(D0INIT) = 1.0E0 V(EPSLON) = 0.1E0 V(FUZZ) = 1.5E0 V(INCFAC) = 2.0E0 V(JTINIT) = 1.0E-6 V(LMAX0) = 100.0E0 V(PHMNFC) = -0.1E0 V(PHMXFC) = 0.1E0 V(RDFCMN) = 0.1E0 V(RDFCMX) = 4.0E0 V(RFCTOL) = MAX(1.0E-10, MEPCRT**2) V(RLIMIT) = RMDCON(5) V(TUNER1) = 0.1E0 V(TUNER2) = 1.0E-4 V(TUNER3) = 0.75E0 V(TUNER4) = 0.5E0 V(TUNER5) = 0.75E0 V(XCTOL) = SQTEPS V(XFTOL) = 1.0E2 * MACHEP C RETURN C *** LAST CARD OF DFAULT FOLLOWS *** END *DFBW SUBROUTINE DFBW (N, LAG, W, LW, DF, BW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES AND STORES THE ASSOCIATED DEGREES OF C FREEDOM AND BANDWIDTH FOR A GIVEN LAG WINDOW. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + BW,DF INTEGER + LAG,LW,N C C ARRAY ARGUMENTS REAL + W(LW) C C LOCAL SCALARS INTEGER + K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL BW C THE BANDWIDTH. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C INTEGER K C AN INDEX VARIABLE C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C REAL W(LW) C THE VECTOR OF LAG WINDOWS. C BW = 0.0E0 DO 10 K = 1, LAG BW = BW + W(K+1) * W(K+1) * (N-K) 10 CONTINUE C BW = 1.0E0 / (W(1)*W(1) + 2.0E0*BW/N) DF = 2.0E0 * BW * N RETURN END *DFBWM SUBROUTINE DFBWM (N, LAG, W, LW, NLPPA1, NLPPA2, LNLPPA, DF, BW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES AND STORES THE ASSOCIATED DEGREES OF C FREEDOM AND BANDWIDTH FOR A GIVEN LAG WINDOW WHEN MISSING DATA 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 - DECEMBER 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + BW,DF INTEGER + LAG,LNLPPA,LW,N C C ARRAY ARGUMENTS REAL + W(LW) INTEGER + NLPPA1(LNLPPA),NLPPA2(LNLPPA) C C LOCAL SCALARS INTEGER + K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL BW C THE BANDWIDTH. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C INTEGER K C AN INDEX VARIABLE C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NLPPA1(LNLPPA), NLPPA2(LNLPPA) C THE NUMBER OF LAGGED PRODUCT PAIRS USED FOR EACH ACVF C ESTIMATE. C REAL W(LW) C THE VECTOR OF LAG WINDOWS. C BW = (W(1)*N)**2/NLPPA1(1) DO 10 K = 1, LAG BW = BW + (W(K+1)*(N-K))**2 * + (1.0E0/NLPPA1(K+1) + 1.0E0/NLPPA2(K+1)) 10 CONTINUE C C BW = N / BW DF = 2.0E0 * BW * N RETURN END *DGAMI DOUBLE PRECISION FUNCTION DGAMI (A, X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE THE INCOMPLETE GAMMA FUNCTION DEFINED BY C C GAMI = INTEGRAL FROM T = 0 TO X OF EXP(-T) * T**(A-1.0) . C C GAMI IS EVALUATED FOR POSITIVE VALUES OF A AND NON-NEGATIVE VALUES C OF X. A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR C WHEN GAMI IS VERY LARGE OR VERY SMALL, BECAUSE LOGARITHMIC VARIABLES C ARE USED. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,X C C LOCAL SCALARS DOUBLE PRECISION FACTOR C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DGAMIT,DLNGAM EXTERNAL D1MACH,DGAMIT,DLNGAM C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC EXP,LOG C C IF (A.LE.0.D0) CALL XERROR ('DGAMI A MUST BE GT ZERO', 25, 1,2) IF (X.LT.0.D0) CALL XERROR ('DGAMI X MUST BE GE ZERO', 25, 2,2) C DGAMI = 0.D0 IF (X.EQ.0.0D0) RETURN C C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. C FACTOR = DLNGAM(A) + A*LOG(X) IF (FACTOR.GT.LOG(D1MACH(2))) THEN DGAMI = D1MACH(2) ELSE DGAMI = EXP(FACTOR) * DGAMIT(A,X) END IF C RETURN END *DGAMIT DOUBLE PRECISION FUNCTION DGAMIT (A, X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE TRICOMI-S INCOMPLETE GAMMA FUNCTION DEFINED BY C C GAMIT = X**(-A)/GAMMA(A) * INTEGRAL T = 0 TO X OF EXP(-T) * T**(A-1.) C C AND ANALYTIC CONTINUATION FOR A .LE. 0.0. GAMMA(X) IS THE COMPLETE C GAMMA FUNCTION OF X. GAMIT IS EVALUATED FOR ARBITRARY REAL VALUES OF C A AND FOR NON-NEGATIVE VALUES OF X (EVEN THOUGH GAMIT IS DEFINED FOR C X .LT. 0.0), EXCEPT THAT FOR X = 0 AND A .LE. 0.0, GAMIT IS INFINITE, C A FATAL ERROR. C C A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR WHEN C GAMIT IS VERY LARGE OR VERY SMALL IN ABSOLUTE VALUE, BECAUSE LOG- C ARITHMIC VARIABLES ARE USED. ALSO, IF THE PARAMETER A IS VERY CLOSE C TO A NEGATIVE INTEGER (BUT NOT A NEGATIVE INTEGER), THERE IS A LOSS C OF ACCURACY, WHICH IS REPORTED IF THE RESULT IS LESS THAN HALF C MACHINE PRECISION. C C REF. -- W. GAUTSCHI, AN EVALUATION PROCEDURE FOR INCOMPLETE GAMMA C FUNCTIONS, ACM TRANS. MATH. SOFTWARE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,X C C LOCAL SCALARS DOUBLE PRECISION AEPS,AINTA,ALGAP1,ALNEPS,ALNG,ALX,BOT,H,SGA, + SGNGAM,SQEPS,T C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,D9GMIT,D9LGIC,D9LGIT,DGAMR,DLNGAM EXTERNAL D1MACH,D9GMIT,D9LGIC,D9LGIT,DGAMR,DLNGAM C C EXTERNAL SUBROUTINES EXTERNAL DLGAMS,XERCLR,XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSIGN,DSQRT,EXP,INT,LOG C C DATA ALNEPS, SQEPS, BOT / 3*0.D0 / C IF (ALNEPS.NE.0.D0) GO TO 10 ALNEPS = -LOG (D1MACH(3)) SQEPS = DSQRT (D1MACH(4)) BOT = LOG (D1MACH(1)) C 10 IF (X.LT.0.D0) CALL XERROR ('DGAMIT X IS NEGATIVE', 21, 2, 2) C IF (X.NE.0.D0) ALX = LOG (X) SGA = 1.0D0 IF (A.NE.0.D0) SGA = DSIGN (1.0D0, A) AINTA = INT (A + 0.5D0*SGA) AEPS = A - AINTA C IF (X.GT.0.D0) GO TO 20 DGAMIT = 0.0D0 IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) RETURN C 20 IF (X.GT.1.D0) GO TO 30 IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, 1 SGNGAM) DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) RETURN C 30 IF (A.LT.X) GO TO 40 T = D9LGIT (A, X, DLNGAM(A+1.0D0)) IF (T.LT.BOT) CALL XERCLR DGAMIT = EXP (T) RETURN C 40 ALNG = D9LGIC (A, X, ALX) C C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) C H = 1.0D0 IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 C CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) T = LOG (ABS(A)) + ALNG - ALGAP1 IF (T.GT.ALNEPS) GO TO 60 C IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) IF (ABS(H).GT.SQEPS) GO TO 50 C CALL XERCLR CALL XERROR ('DGAMIT RESULT LT HALF PRECISION', 32, 1, 1) C 50 T = -A*ALX + LOG(ABS(H)) IF (T.LT.BOT) CALL XERCLR DGAMIT = DSIGN (EXP(T), H) RETURN C 60 T = T - A*ALX IF (T.LT.BOT) CALL XERCLR DGAMIT = -SGA * SGNGAM * EXP(T) RETURN C END *DGAMLM SUBROUTINE DGAMLM (XMIN, XMAX) C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C CALCULATE THE MINIMUM AND MAXIMUM LEGAL BOUNDS FOR X IN GAMMA(X). C XMIN AND XMAX ARE NOT THE ONLY BOUNDS, BUT THEY ARE THE ONLY NON- C TRIVIAL ONES TO CALCULATE. C C OUTPUT ARGUMENTS -- C XMIN DBLE PREC MINIMUM LEGAL VALUE OF X IN GAMMA(X). ANY SMALLER C VALUE OF X MIGHT RESULT IN UNDERFLOW. C XMAX DBLE PREC MAXIMUM LEGAL VALUE OF X IN GAMMA(X). ANY LARGER C VALUE OF X MIGHT CAUSE OVERFLOW. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION XMAX,XMIN C C LOCAL SCALARS DOUBLE PRECISION ALNBIG,ALNSML,XLN,XOLD INTEGER I C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH EXTERNAL D1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,MAX C C ALNSML = LOG(D1MACH(1)) XMIN = -ALNSML DO 10 I=1,10 XOLD = XMIN XLN = LOG(XMIN) XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) 1 / (XMIN*XLN+0.5D0) IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 10 CONTINUE CALL XERROR ('DGAMLM UNABLE TO FIND XMIN', 27, 1, 2) C 20 XMIN = -XMIN + 0.01D0 C ALNBIG = LOG (D1MACH(2)) XMAX = ALNBIG DO 30 I=1,10 XOLD = XMAX XLN = LOG(XMAX) XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) 1 / (XMAX*XLN-0.5D0) IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 30 CONTINUE CALL XERROR ('DGAMLM UNABLE TO FIND XMAX', 27, 2, 2) C 40 XMAX = XMAX - 0.01D0 XMIN = MAX (XMIN, -XMAX+1.D0) C RETURN END *DGAMMA DOUBLE PRECISION FUNCTION DGAMMA (X) C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION DXREL,PI,SINPIY,SQ2PIL,XMAX,XMIN,Y INTEGER I,N,NGAM C C LOCAL ARRAYS DOUBLE PRECISION GAMCS(42) C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,D9LGMC,DCSEVL INTEGER INITDS EXTERNAL D1MACH,D9LGMC,DCSEVL,INITDS C C EXTERNAL SUBROUTINES EXTERNAL DGAMLM,XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DBLE,DSQRT,EXP,FLOAT,INT,LOG,SIN,SNGL C C C SERIES FOR GAM ON THE INTERVAL 0. TO 1.00000E+00 C WITH WEIGHTED ERROR 5.79E-32 C LOG WEIGHTED ERROR 31.24 C SIGNIFICANT FIGURES REQUIRED 30.00 C DECIMAL PLACES REQUIRED 32.05 C DATA GAM CS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / DATA GAM CS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / DATA GAM CS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / DATA GAM CS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / DATA GAM CS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / DATA GAM CS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / DATA GAM CS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / DATA GAM CS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / DATA GAM CS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / DATA GAM CS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / DATA GAM CS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / DATA GAM CS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / DATA GAM CS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / DATA GAM CS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / DATA GAM CS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / DATA GAM CS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / DATA GAM CS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / DATA GAM CS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / DATA GAM CS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / DATA GAM CS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / DATA GAM CS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / DATA GAM CS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / DATA GAM CS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / DATA GAM CS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / DATA GAM CS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / DATA GAM CS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / DATA GAM CS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / DATA GAM CS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / DATA GAM CS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / DATA GAM CS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / DATA GAM CS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / DATA GAM CS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / DATA GAM CS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / DATA GAM CS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / DATA GAM CS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / DATA GAM CS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / DATA GAM CS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / DATA GAM CS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / DATA GAM CS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / DATA GAM CS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / DATA GAM CS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / DATA GAM CS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / C DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / C SQ2PIL IS 0.5*LOG(2*PI) = LOG(SQRT(2*PI)) DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / DATA NGAM, XMIN, XMAX, DXREL / 0, 3*0.D0 / C IF (NGAM.NE.0) GO TO 10 NGAM = INITDS (GAMCS, 42, 0.1*SNGL(D1MACH(3)) ) C CALL DGAMLM (XMIN, XMAX) DXREL = DSQRT (D1MACH(4)) C 10 Y = ABS(X) IF (Y.GT.10.D0) GO TO 50 C C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. C N = X IF (X.LT.0.D0) N = N - 1 Y = X - DBLE(FLOAT(N)) N = N - 1 DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) IF (N.EQ.0) RETURN C IF (N.GT.0) GO TO 30 C C COMPUTE GAMMA(X) FOR X .LT. 1.0 C N = -N IF (X.EQ.0.D0) CALL XERROR ('DGAMMA X IS 0', 14, 4, 2) IF (X.LT.0.0 .AND. X+DBLE(FLOAT(N-2)).EQ.0.D0) CALL XERROR ( 1 'DGAMMA X IS A NEGATIVE INTEGER', 31, 4, 2) IF (X.LT.(-0.5D0) .AND. ABS((X-INT(X-0.5D0))/X).LT.DXREL) CALL 1 XERROR ( 'DGAMMA ANSWER LT HALF PRECISION BECAUSE X TOO NEAR N 2EGATIVE INTEGER', 68, 1, 1) C DO 20 I=1,N DGAMMA = DGAMMA/(X+DBLE(FLOAT(I-1)) ) 20 CONTINUE RETURN C C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 C 30 DO 40 I=1,N DGAMMA = (Y+DBLE(FLOAT(I))) * DGAMMA 40 CONTINUE RETURN C C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). C 50 IF (X.GT.XMAX) CALL XERROR ('DGAMMA X SO BIG GAMMA OVERFLOWS', 1 32, 3, 2) C DGAMMA = 0.D0 IF (X.LT.XMIN) CALL XERROR ('DGAMMA X SO SMALL GAMMA UNDERFLOWS', 1 35, 2, 1) IF (X.LT.XMIN) RETURN C DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) IF (X.GT.0.D0) RETURN C IF (ABS((X-INT(X-0.5D0))/X).LT.DXREL) CALL XERROR ( 1 'DGAMMA ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 2 61, 1, 1) C SINPIY = SIN (PI*Y) IF (SINPIY.EQ.0.D0) CALL XERROR ( 1 'DGAMMA X IS A NEGATIVE INTEGER', 31, 4, 2) C DGAMMA = -PI/(Y*SINPIY*DGAMMA) C RETURN END *DGAMR DOUBLE PRECISION FUNCTION DGAMR (X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C THIS ROUTINE, NOT DGAMMA(X), SHOULD BE THE FUNDAMENTAL ONE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION ALNGX,SGNGX INTEGER IROLD C C EXTERNAL FUNCTIONS DOUBLE PRECISION DGAMMA EXTERNAL DGAMMA C C EXTERNAL SUBROUTINES EXTERNAL DLGAMS,XERCLR,XGETF,XSETF C C INTRINSIC FUNCTIONS INTRINSIC ABS,EXP,INT C C DGAMR = 0.0D0 IF (X.LE.0.0D0 .AND. INT(X).EQ.X) RETURN C CALL XGETF (IROLD) CALL XSETF (1) IF (ABS(X).GT.10.0D0) GO TO 10 DGAMR = 1.0D0/DGAMMA(X) CALL XERCLR CALL XSETF (IROLD) RETURN C 10 CALL DLGAMS (X, ALNGX, SGNGX) CALL XERCLR CALL XSETF (IROLD) DGAMR = SGNGX * EXP(-ALNGX) RETURN C END *DIFC SUBROUTINE DIFC (Y, N, NFAC, ND, IOD, IAR, PHI, LPHI, YF, NYF, + LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NFAC, C IOD AND ND INTO PHI AND PERFORMS THE DIFFERENCE FILTERING C OPERATION DEFINED BY PHI, RETURNING THE FILTERED SERIES C IN YF. 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 + IAR,LDSTAK,LPHI,N,NFAC,NYF C C ARRAY ARGUMENTS REAL + PHI(*),Y(*),YF(*) INTEGER + IOD(*),ND(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,IPRT,LDSMIN,NALL0,WORK LOGICAL + ERR01,ERR02,ERR03,ERR04,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LLDS(8)*1,LLPHI(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL DCOEF,EISGE,ERDF,FLTAR,IPRINT,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES 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 LOGICAL ERR01, ERR02, ERR03, ERR04 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 IOD(NFAC) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. 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 LLDS(8), LLPHI(8), LN(8) C THE ARRAYS CONTAINING THE NAMES OF VARIOUS VARIABLES C INTEGER LPHI C THE LENGTH OF THE ARRAY PHI. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING WORK AREA ALLOCATIONS. C INTEGER ND(NFAC) C THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE C FACTORS ARE TO BE APPLIED. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS. 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 REAL PHI(LPHI) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER WORK C THE STARTING LOCATION FOR THE WORK VECTOR NECESSARY TO C EXPAND THE DIFFERENCE FILTER. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'I', 'F', 'C', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) + / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LLPHI(1), LLPHI(2), LLPHI(3), LLPHI(4), LLPHI(5), LLPHI(6), + LLPHI(7), LLPHI(8) + / 'L', 'P', 'H', 'I', ' ', ' ', ' ', ' '/ 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 ERR01 = .FALSE. ERR02 = .FALSE. ERR03 = .FALSE. ERR04 = .FALSE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB,LN,N,3,1,HEAD,ERR01,LN) C IAR = 0 C IF (NFAC.GE.1) THEN C DO 10 I = 1, NFAC IAR = IAR + ND(I)*IOD(I) 10 CONTINUE C CALL ERDF(NMSUB,NFAC,ND,IOD,N,HEAD,ERR02) C IF (.NOT.ERR02) THEN CALL EISGE(NMSUB,LLPHI,LPHI,IAR,9,HEAD,ERR03,LLPHI) CALL LDSCMP(1,0,0,0,0,0,'S',2*IAR,LDSMIN) CALL EISGE(NMSUB,LLDS,LDSTAK,LDSMIN,9,HEAD,ERR04,LLDS) END IF END IF C C IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 20 GO TO 30 C 20 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 30 CONTINUE C NYF = N DO 50 I = 1, NYF YF(I) = Y(I) 50 CONTINUE C IF (NFAC .LE. 0) RETURN C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C DO 60 I = 1, LPHI PHI(I) = 0.0E0 60 CONTINUE C WORK = STKGET(2*IAR, 3) C IF (IERR .EQ. 1) GO TO 20 C CALL DCOEF (NFAC,ND,IOD,IAR,PHI,LPHI,RSTAK(WORK)) C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 20 C CALL FLTAR (YF,NYF,IAR,PHI,YF,NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DIFC (Y, N,'/ + ' + NFAC, ND, IOD, IAR, PHI, LPHI,'/ + ' + YF, NYF, LDSTAK)') END *DIF SUBROUTINE DIF (Y, N, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PERFORMS A FIRST DIFFERENCE FILTERING OPERATION, C RETURNING THE FILTERED SERIES IN YF. 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 + N,NYF C C ARRAY ARGUMENTS REAL + Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IAR,IPRT LOGICAL + ERR01,HEAD C C LOCAL ARRAYS REAL + PHI(1) CHARACTER + LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,FLTAR,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 CHARACTER*1 LN(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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 REAL PHI(1) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'I', 'F', ' ', ' ', ' '/ 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 C IF (.NOT. ERR01) GO TO 10 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET VARIOUS PROGRAM PARAMETERS C IAR = 1 PHI(1) = 1.0E0 C CALL FLTAR (Y, N, IAR, PHI, YF, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 31H CALL DIF (Y, N, YF, NYF)) END *DIFMC SUBROUTINE DIFMC (Y, YMISS, N, NFAC, ND, IOD, IAR, PHI, LPHI, YF, + YFMISS, NYF, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NFAC, C IOD AND ND INTO PHI AND PERFORMS THE DIFFERENCE FILTERING C OPERATION DEFINED BY PHI ON A SERIES CONTAINING MISSING DATA, C RETURNING THE FILTERED SERIES IN YF. 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 REAL + YFMISS,YMISS INTEGER + IAR,LDSTAK,LPHI,N,NFAC,NYF C C ARRAY ARGUMENTS REAL + PHI(*),Y(*),YF(*) INTEGER + IOD(*),ND(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + I,IPRT,LDSMIN,NALL0,WORK LOGICAL + ERR01,ERR02,ERR03,ERR04,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LLDS(8)*1,LLPHI(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL DCOEF,EISGE,ERDF,FLTARM,IPRINT,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES 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 LOGICAL ERR01, ERR02, ERR03, ERR04 C VALUES 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 IOD(NFAC) C THE ORDER OF EACH OF THE DIFFERENCE FACTORS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. 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 LLDS(8), LLPHI(8), LN(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES LDSTAK, N C AND LPHI, RESPECTIVELY. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C INTEGER ND(NFAC) C THE ARRAY CONTAINING THE NUMBER OF TIMES THE DIFFERENCE C FACTORS ARE TO BE APPLIED. C INTEGER NFAC C THE NUMBER OF DIFFERENCE FACTORS. 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 REAL PHI(LPHI) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER WORK C THE STARTING LOCATION FOR THE WORK VECTOR NECESSARY TO C EXPAND THE DIFFERENCE FILTER. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C REAL YFMISS C THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO C INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA. C REAL YMISS C THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE C AN OBSERVATION IS MISSING. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'I', 'F', 'M', 'C', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) + / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LLPHI(1), LLPHI(2), LLPHI(3), LLPHI(4), LLPHI(5), LLPHI(6), + LLPHI(7), LLPHI(8) + / 'L', 'P', 'H', 'I', ' ', ' ', ' ', ' '/ 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 ERR01 = .FALSE. ERR02 = .FALSE. ERR03 = .FALSE. ERR04 = .FALSE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB,LN,N,3,1,HEAD,ERR01,LN) C IAR = 0 C IF (NFAC.GE.1) THEN C DO 10 I = 1, NFAC IAR = IAR + ND(I)*IOD(I) 10 CONTINUE C CALL ERDF(NMSUB,NFAC,ND,IOD,N,HEAD,ERR02) C IF (.NOT.ERR02) THEN CALL EISGE(NMSUB,LLPHI,LPHI,IAR,9,HEAD,ERR03,LLPHI) CALL LDSCMP(1,0,0,0,0,0,'S',2*IAR,LDSMIN) CALL EISGE(NMSUB,LLDS,LDSTAK,LDSMIN,9,HEAD,ERR04,LLDS) END IF END IF C IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 20 GO TO 30 C 20 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 30 CONTINUE C NYF = N DO 50 I = 1, NYF YF(I) = Y(I) 50 CONTINUE C YFMISS = YMISS C IF (NFAC .LE. 0) RETURN C CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) C DO 60 I = 1, LPHI PHI(I) = 0.0E0 60 CONTINUE C WORK = STKGET(2*IAR,3) C IF (IERR .EQ. 1) GO TO 20 C CALL DCOEF (NFAC,ND,IOD,IAR,PHI,LPHI,RSTAK(WORK)) C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 20 C CALL FLTARM (YF,YMISS,NYF,IAR,PHI,YF,YFMISS,NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL DIFMC (Y, YMISS, N,'/ + ' + NFAC, ND, IOD, IAR, PHI, LPHI,'/ + ' + YF, YFMISS, NYF, LDSTAK)') END *DIFM SUBROUTINE DIFM (Y, YMISS, N, YF, YFMISS, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PERFORMS A FIRST DIFFERENCE FILTERING OPERATION, C RETURNING THE FILTERED SERIES IN YF, FOR AN INPUT SERIES C CONTAINING MISSING VALUES. 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 REAL + YFMISS,YMISS INTEGER + N,NYF C C ARRAY ARGUMENTS REAL + Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IAR,IPRT LOGICAL + ERR01,HEAD C C LOCAL ARRAYS REAL + PHI(1) CHARACTER + LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,FLTARM,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 CHARACTER*1 LN(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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 REAL PHI(1) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C REAL YFMISS C THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO C INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA. C REAL YMISS C THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE C AN OBSERVATION IS MISSING. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'D', 'I', 'F', 'M', ' ', ' '/ 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 IF (.NOT. ERR01) GO TO 10 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET VARIOUS PROGRAM PARAMETERS C IAR = 1 PHI(1) = 1.0E0 C CALL FLTARM (Y, YMISS, N, IAR, PHI, YF, YFMISS, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 47H CALL DIFM (Y, YMISS, N, YF, YFMISS, NYF)) END *DIFSER SUBROUTINE DIFSER (Y, N, NDF, ND, IOD, YDIFF, NDIFF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS THE DIFFERENCING OPPERATION C DEFINED BY ND, IOD AND NDF ON THE SERIES Y, RESULTING IN C THE SERIES YDIFF. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVIAION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - NOVEMBER 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NDF,NDIFF C C ARRAY ARGUMENTS REAL + Y(*),YDIFF(*) INTEGER + IOD(*),ND(*) C C LOCAL SCALARS INTEGER + I,J,K,L,NTIMES C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER IOD(NDF) C THE VECTOR CONTAINING THE ORDERS OF EACH DIFFERENCE FACTOR. C INTEGER J, K, L C INDEX VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER ND(NDF) C THE VECTOR CONTAINING THE NUMBER OF TIMES EACH DIFFERENCING C FACTOR IS APPLIED. C INTEGER NDF C THE NUMBER OF DIFFERENCE FACTORS. C INTEGER NDIFF C THE NUMBER OF OBSERVATIONS REMAINING IN THE DIFFERENCED SERIES. C INTEGER NTIMES C THE NUMBER OF TIMES A GIVEN DIFFERENCE FACTOR IS TO BE APPLIED. C REAL Y(N), YDIFF(N) C THE VECTOR CONTAINING THE SERIES OBSERVATIONS AND THE VECTOR C IN WHICH THE DIFFERENCED SERIES IS RETURNED. C DO 10 I = 1, N YDIFF(I) = Y(I) 10 CONTINUE C NDIFF = N C IF (NDF .EQ. 0) RETURN C DO 40 I = 1, NDF NTIMES = ND(I) DO 30 L = 1, NTIMES NDIFF = NDIFF - IOD(I) DO 20 J = 1, NDIFF K = J + IOD(I) YDIFF(J) = YDIFF(K) - YDIFF(J) 20 CONTINUE 30 CONTINUE 40 CONTINUE RETURN END *DLBETA DOUBLE PRECISION FUNCTION DLBETA (A, B) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION A,B C C LOCAL SCALARS DOUBLE PRECISION CORR,P,Q,SQ2PIL C C EXTERNAL FUNCTIONS DOUBLE PRECISION D9LGMC,DGAMMA,DLNGAM,DLNREL EXTERNAL D9LGMC,DGAMMA,DLNGAM,DLNREL C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC LOG,MAX,MIN C DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / C P = MIN (A, B) Q = MAX (A, B) C IF (P.LE.0.D0) CALL XERROR ( 1 'DLBETA BOTH ARGUMENTS MUST BE GT ZERO', 38, 1, 2) C IF (P.GE.10.D0) GO TO 30 IF (Q.GE.10.D0) GO TO 20 C C P AND Q ARE SMALL. C DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) RETURN C C P IS SMALL, BUT Q IS BIG. C 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) 1 + (Q-0.5D0)*DLNREL(-P/(P+Q)) RETURN C C P AND Q ARE BIG. C 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) 1 + Q*DLNREL(-P/(P+Q)) RETURN C END *DLGAMS SUBROUTINE DLGAMS (X, DLGAM, SGNGAM) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE LOG ABS (GAMMA(X)) AND RETURN THE SIGN OF GAMMA(X) IN SGNGAM. C SGNGAM IS EITHER +1.0 OR -1.0. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION DLGAM,SGNGAM,X C C EXTERNAL FUNCTIONS DOUBLE PRECISION DLNGAM EXTERNAL DLNGAM C C INTRINSIC FUNCTIONS INTRINSIC INT,MOD C C DLGAM = DLNGAM(X) SGNGAM = 1.0D0 IF (X.GT.0.D0) RETURN C C INT = DMOD (-INT(X), 2.0D0) + 0.1D0 IF (INT(MOD(-INT(X),2)+0.1D0).EQ.0) SGNGAM = -1.0D0 C RETURN END *DLNGAM DOUBLE PRECISION FUNCTION DLNGAM (X) C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION DXREL,PI,SINPIY,SQ2PIL,SQPI2L,XMAX,Y C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,D9LGMC,DGAMMA EXTERNAL D1MACH,D9LGMC,DGAMMA C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSQRT,INT,LOG,SIN C C DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / C SQ2PIL = LOG (SQRT(2*PI)), SQPI2L = LOG(SQRT(PI/2)) DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / C DATA XMAX, DXREL / 2*0.D0 / C IF (XMAX.NE.0.D0) GO TO 10 XMAX = D1MACH(2)/LOG(D1MACH(2)) DXREL = DSQRT (D1MACH(4)) C 10 Y = ABS (X) IF (Y.GT.10.D0) GO TO 20 C C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 C DLNGAM = LOG (ABS (DGAMMA(X)) ) RETURN C C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 C 20 IF (Y.GT.XMAX) CALL XERROR ( 1 'DLNGAM ABS(X) SO BIG DLNGAM OVERFLOWS', 39, 2, 2) C IF (X.GT.0.D0) THEN DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) RETURN END IF C SINPIY = ABS (SIN(PI*Y)) IF (SINPIY.EQ.0.D0) CALL XERROR ( 1 'DLNGAM X IS A NEGATIVE INTEGER', 31, 3, 2) C IF (ABS ((X-INT(X-0.5D0))/X).LT.DXREL) CALL XERROR ( 1 'DLNGAM ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE 2INTEGER', 68, 1, 1) C DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) RETURN C END *DLNREL DOUBLE PRECISION FUNCTION DLNREL (X) C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS DOUBLE PRECISION X C C LOCAL SCALARS DOUBLE PRECISION XMIN INTEGER NLNREL C C LOCAL ARRAYS DOUBLE PRECISION ALNRCS(43) C C EXTERNAL FUNCTIONS DOUBLE PRECISION D1MACH,DCSEVL INTEGER INITDS EXTERNAL D1MACH,DCSEVL,INITDS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,DSQRT,LOG,SNGL C C C SERIES FOR ALNR ON THE INTERVAL -3.75000E-01 TO 3.75000E-01 C WITH WEIGHTED ERROR 6.35E-32 C LOG WEIGHTED ERROR 31.20 C SIGNIFICANT FIGURES REQUIRED 30.93 C DECIMAL PLACES REQUIRED 32.01 C DATA ALNRCS( 1) / +.1037869356 2743769800 6862677190 98 D+1 / DATA ALNRCS( 2) / -.1336430150 4908918098 7660415531 33 D+0 / DATA ALNRCS( 3) / +.1940824913 5520563357 9261993747 50 D-1 / DATA ALNRCS( 4) / -.3010755112 7535777690 3765377765 92 D-2 / DATA ALNRCS( 5) / +.4869461479 7154850090 4563665091 37 D-3 / DATA ALNRCS( 6) / -.8105488189 3175356066 8099430086 22 D-4 / DATA ALNRCS( 7) / +.1377884779 9559524782 9382514960 59 D-4 / DATA ALNRCS( 8) / -.2380221089 4358970251 3699929149 35 D-5 / DATA ALNRCS( 9) / +.4164041621 3865183476 3918599019 89 D-6 / DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7 / DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7 / DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8 / DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9 / DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10 / DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10 / DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11 / DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12 / DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13 / DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13 / DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14 / DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15 / DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15 / DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16 / DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17 / DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18 / DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18 / DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19 / DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20 / DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21 / DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21 / DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22 / DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23 / DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23 / DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24 / DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25 / DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26 / DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26 / DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27 / DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28 / DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29 / DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29 / DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30 / DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31 / C DATA NLNREL, XMIN / 0, 0.D0 / C IF (NLNREL.NE.0) GO TO 10 NLNREL = INITDS (ALNRCS, 43, 0.1*SNGL(D1MACH(3))) XMIN = -1.0D0 + DSQRT(D1MACH(4)) C 10 IF (X.LE.(-1.D0)) CALL XERROR ('DLNREL X IS LE -1', 18, 2, 2) IF (X.LT.XMIN) CALL XERROR ( 1 'DLNREL ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 54, 2 1, 1) C IF (ABS(X).LE.0.375D0) THEN DLNREL = X*(1.0D0 - X*DCSEVL (X/0.375D0, ALNRCS, NLNREL)) ELSE DLNREL = LOG (1.0D0+X) END IF C RETURN END *DOTC SUBROUTINE DOTC (Y, YMEAN, NY, X, XMEAN, NX, DOTXY, NDOTXY) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE DOT PRODUCT OF TWO C SERIES, CENTERED ABOUT THEIR RESPECTIVE MEANS. 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 REAL + DOTXY,XMEAN,YMEAN INTEGER + NDOTXY,NX,NY C C ARRAY ARGUMENTS REAL + X(NX),Y(NY) C C LOCAL SCALARS INTEGER + I,M C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DOTXY C THE DOT PRODUCT OF THE SERIES (Y(I) - YMEAN) AND C (X(I) - XMEAN). C INTEGER I C AN INDEX VARIABLE. C INTEGER M C THE SMALLER OF THE NUMBER OF OBSERVATIONS IN X AND Y C INTEGER NDOTXY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY C INTEGER NX, NY C THE NUMBER OF OBSERVATIONS IN SERIES X AND Y, RESPECTIVELY. C REAL X(NX) C THE VECTOR CONTAINING THE SECOND SERIES C REAL XMEAN C THE MEAN OF THE SECOND SERIES. C REAL Y(NY) C THE VECTOR CONTAINING THE FIRST SERIES C REAL YMEAN C THE MEAN OF THE FIRST SERIES. C NDOTXY = 0 DOTXY = 0.0E0 M = MIN(NY, NX) DO 10 I = 1, M DOTXY = DOTXY + (Y(I) - YMEAN) * (X(I) - XMEAN) NDOTXY = NDOTXY + 1 10 CONTINUE RETURN END *DOTCM SUBROUTINE DOTCM (Y, YMEAN, YMISS, NY, X, XMEAN, XMISS, + NX, DOTXY, NDOTXY) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE DOT PRODUCT OF TWO C SERIES WITH MISSING DATA, CENTERED ABOUT THEIR RESPECTIVE MEANS. 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 REAL + DOTXY,XMEAN,XMISS,YMEAN,YMISS INTEGER + NDOTXY,NX,NY C C ARRAY ARGUMENTS REAL + X(NX),Y(NY) C C LOCAL SCALARS INTEGER + I,M C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DOTXY C THE DOT PRODUCT OF THE SERIES (Y(I) - YMEAN) AND C (X(I) - XMEAN). C INTEGER I C AN INDEX VARIABLE. C INTEGER M C THE SMALLER OF THE NUMBER OF OBSERVATIONS IN X AND Y C INTEGER NDOTXY C THE NUMBER OF OBSERVATIONS USED TO COMPUTE DOTXY C INTEGER NX, NY C THE NUMBER OF OBSERVATIONS IN SERIES X AND Y, RESPECTIVELY. C REAL X(NX) C THE VECTOR CONTAINING THE SECOND SERIES C REAL XMEAN C THE MEAN OF THE SECOND SERIES. C REAL XMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF X(I) = XMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C REAL Y(NY) C THE VECTOR CONTAINING THE FIRST SERIES C REAL YMEAN C THE MEAN OF THE FIRST SERIES. C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C NDOTXY = 0 DOTXY = 0.0E0 M = MIN(NY, NX) DO 10 I = 1, M IF (MVCHK(Y(I), YMISS) .OR. MVCHK(X(I), XMISS)) GO TO 10 DOTXY = DOTXY + (Y(I) - YMEAN) * (X(I) - XMEAN) NDOTXY = NDOTXY + 1 10 CONTINUE RETURN END *DOTPRD REAL 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 REAL + X(*),Y(*) C C LOCAL SCALARS REAL + ONE,SQTETA,T,ZERO INTEGER + I C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C INTEGER P C REAL X(*), Y(*) C C INTEGER I C REAL ONE, SQTETA, T, ZERO C/+ C REAL MAX, ABS C/ C EXTERNAL RMDCON C REAL RMDCON 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.0E0/, SQTETA/0.0E0/, ZERO/0.0E0/ 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 *DRV1A SUBROUTINE DRV1A(COEF, NCOEF, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL1 C CODED CORRECTLY. 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,NCOEF C C ARRAY ARGUMENTS REAL + COEF(NCOEF),D(N,NCOEF),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC LOG C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COEF(NCOEF) C MODEL COEFFICIENTS C REAL D(N,NCOEF) C THE FIRST DERIVATIVE WITH RESPECT TO THE ITH COEFFICIENT C INTEGER I C ROW MARKER 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 NCOEF C THE NUMBER OF COEFFICIENTS C REAL XM(IXM,M) C INDEPENDENT VARIABLES C C DO 10 I=1,N D(I,1) = XM(I,1)**COEF(2) D(I,2) = COEF(1)*(XM(I,1)**COEF(2))*LOG(XM(I,1)) 10 CONTINUE C RETURN C END *DRV1B SUBROUTINE DRV1B(PAR, NPAR, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL1 C CODED INCORRECTLY. 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 REAL + D(N,NPAR),PAR(NPAR),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC LOG C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL D(N,NPAR) C THE FIRST DERIVATIVE WITH RESPECT TO THE ITH COEFFICIENT C INTEGER I C ROW MARKER 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 COEFFICIENTS C REAL PAR(NPAR) C MODEL COEFFICIENTS C REAL XM(IXM,M) C INDEPENDENT VARIABLES C C DO 10 I=1,N D(I,1) = XM(I,1)*PAR(2) D(I,2) = PAR(1)*(XM(I,1)**PAR(2))*LOG(XM(I,1)) 10 CONTINUE C RETURN C END *DRV2 SUBROUTINE DRV2(PAR, NPAR, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL2. 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 REAL + D(N,NPAR),PAR(NPAR),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL PAR(NPAR) C MODEL PARAMETERS C REAL D(N,NPAR) C THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER C INTEGER I C ROW MARKER 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 REAL XM(IXM,M) C MODEL INDEPENDENT VARIABLE C C DO 10 I=1,N D(I,1) = XM(I,1) D(I,2) = XM(I,2) D(I,3) = XM(I,3)**3 10 CONTINUE C RETURN C END *DRV3 SUBROUTINE DRV3(PAR, NPAR, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FUNCTION FOR NLS FAMILY EXERCISER SUBROUTINE MDL3 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 REAL + D(N,NPAR),PAR(NPAR),XM(IXM,M) C C LOCAL SCALARS INTEGER + I,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL PAR(NPAR) C MODEL PARAMETERS C REAL D(N,NPAR) C THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER C INTEGER I C ROW MARKER 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 REAL XM(IXM,M) C INDEPENDENT VARIABLE C DO 20 I=1,N DO 10 J=1,NPAR D(I,J) = XM(I,J) 10 CONTINUE 20 CONTINUE C RETURN C END *DRV4A SUBROUTINE DRV4A (COEF, NCOEF, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FOR DERIVATIVE CHECKING ROUTINES (CORRECTLY CODED). 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,NCOEF C C ARRAY ARGUMENTS REAL + COEF(NCOEF),D(N,NCOEF),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC EXP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COEF(NCOEF) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C COEFFICIENTS ARE STORED. C REAL D(N,NCOEF) C THE MATRIX OF FIRST PARTIAL DERIVATIVES (JACOBIAN). C INTEGER I C AN INDEX VARIABLE. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NCOEF C THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C DO 10 I = 1, N D(I,1) = 1.0E0 D(I,2) = (COEF(3)*2.0E0*(XM(I,1)-COEF(2))/COEF(4)) * + EXP(-((XM(I,1)-COEF(2))**2)/COEF(4)) D(I,3) = EXP(-((XM(I,1)-COEF(2))**2)/COEF(4)) D(I,4) = -COEF(3)*(-((XM(I,1)-COEF(2))**2) / + (COEF(4)**2)) * EXP(-((XM(I,1)-COEF(2))**2)/COEF(4)) 10 CONTINUE C RETURN C END *DRV4B SUBROUTINE DRV4B (COEF, NCOEF, XM, N, M, IXM, D) C C LATEST REVISION - 03/15/90 (JRD) C C DERIVATIVE FOR DERIVATIVE CHECKING ROUTINES (INCORRECTLY CODED). 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,NCOEF C C ARRAY ARGUMENTS REAL + COEF(NCOEF),D(N,NCOEF),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC EXP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COEF(NCOEF) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C COEFFICIENTS ARE STORED. C REAL D(N,NCOEF) C THE MATRIX OF FIRST PARTIAL DERIVATIVES (JACOBIAN). C INTEGER I C AN INDEX VARIABLE. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NCOEF C THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C DO 10 I = 1, N D(I,1) = 0.0E0 D(I,2) = (COEF(3)*2.0E0*(XM(I,1)-COEF(2))/COEF(4)) * + EXP(-((XM(I,1)-COEF(2))**2)/COEF(4)) D(I,3) = 0.0E0 D(I,4) = COEF(3)*(-((XM(I,1)-COEF(2))**2) / + (COEF(4)**2)) * EXP(-((XM(I,1)-COEF(2))**2)/COEF(4)) 10 CONTINUE 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 REAL + D(N,NPAR),PAR(NPAR),XM(IXM,M) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C MODEL PARAMETERS C REAL XM(IXM,M) C MODEL INDEPENDENT VARIABLE C 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 REAL + D(P),J(NN,P),V(1) INTEGER + IV(1) C C LOCAL SCALARS REAL + SII,T,VDFAC,ZERO INTEGER + D0,DFAC,DTYPE,I,JTOL0,JTOLI,NITER,S,S1 C C EXTERNAL FUNCTIONS REAL + V2NORM EXTERNAL V2NORM C C INTRINSIC FUNCTIONS INTRINSIC MAX,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER IV(1), N, NN, P C REAL D(P), J(NN,P), V(1) C DIMENSION IV(*), V(*) C C *** LOCAL VARIABLES *** C C INTEGER D0, I, JTOLI, S1 C REAL SII, T, VDFAC C C *** CONSTANTS *** C REAL ZERO C C/ C *** EXTERNAL FUNCTION *** C C EXTERNAL V2NORM C REAL V2NORM 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.0E0/ 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 *E9RINT SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE) C C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . C C CHARACTER*4 MESSG(NW) C LOGICAL SAVE C C MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS C MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST C C 1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD). C C CHARACTER*4 MESSGP(36),FMT(14),CCPLUS C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER NERR,NW LOGICAL SAVE C C ARRAY ARGUMENTS CHARACTER MESSG(NW)*4 C C LOCAL SCALARS INTEGER I,IWUNIT,NERRP,NWP CHARACTER CCPLUS*4 C C LOCAL ARRAYS CHARACTER FMT(14)*4,MESSGP(36)*4 C C EXTERNAL FUNCTIONS INTEGER I1MACH,I8SAVE EXTERNAL I1MACH,I8SAVE C C EXTERNAL SUBROUTINES EXTERNAL S88FMT C C C START WITH NO PREVIOUS MESSAGE. C DATA MESSGP(1)/'1'/, NWP/0/, NERRP/0/ C C SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE. C THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE C NUMBER OF CHARACTERS STORED PER INTEGER WORD. C DATA CCPLUS / '+' / C DATA FMT( 1) / '(' / DATA FMT( 2) / 'A' / DATA FMT( 3) / '1' / DATA FMT( 4) / ',' / DATA FMT( 5) / '1' / DATA FMT( 6) / '4' / DATA FMT( 7) / 'X' / DATA FMT( 8) / ',' / DATA FMT( 9) / '7' / DATA FMT(10) / '2' / DATA FMT(11) / 'A' / DATA FMT(12) / 'X' / DATA FMT(13) / 'X' / DATA FMT(14) / ')' / C IF (.NOT.SAVE) GO TO 20 C C SAVE THE MESSAGE. C NWP=NW NERRP=NERR DO 10 I=1,NW 10 MESSGP(I)=MESSG(I) C GO TO 30 C 20 IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30 C C PRINT THE MESSAGE. C IWUNIT=I1MACH(4) WRITE(IWUNIT,9000) NERRP 9000 FORMAT(' ERROR ',I4,' IN ') C CALL S88FMT(2,I1MACH(6),FMT(12)) WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP) C 30 RETURN C END *ECVF SUBROUTINE ECVF(NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS AN ERROR MESSAGE WHEN THE LAG VALUE OF C THE LAST COVARIANCE COMPUTED BEFORE ONE WAS NOT COMPUTED C DUE TO MISSING DATA DOES NOT EXCEED ZERO. 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 ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + IPRT LOGICAL + HEAD C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C CALL IPRINT(IPRT) C HEAD = .TRUE. C CALL EHDR(NMSUB, HEAD) C WRITE(IPRT, 1010) RETURN C C FORMAT STATEMENTS C 1010 FORMAT (/ + 46H THE COVARIANCES AT LAGS ZERO AND/OR ONE COULD, + 16H NOT BE COMPUTED/ + 49H BECAUSE OF MISSING DATA. NO FURTHER ANALYSIS IS, + 10H POSSIBLE.) 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 IF (.NOT.HEAD) RETURN C CALL IPRINT(IPRT) C CALL VERSP(.FALSE.) WRITE(IPRT,1010) WRITE (IPRT, 1000) (NMSUB(I), I=1,6) HEAD = .FALSE. C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/31H ERROR CHECKING FOR SUBROUTINE , 6A1/ 1X, 37('-')) 1010 FORMAT ('+', 18(1H*)/19H * ERROR MESSAGES */1X, 18(1H*)) C 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 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 *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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.2) + WRITE (IPRT, 1000) (NMVAR(I),I=1,6), YMMN, NV IF (MSGTYP.GE.3) + WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV C GO TO (10, 20, 30, 40), MSGTYP C 10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), YMMN RETURN C 20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), YMMN, NVMX RETURN C 30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C 40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ + 31H THE NUMBER OF VALUES IN ARRAY , 6A1, + ' LESS THAN ', I5, 4H IS , I6, '.') 1005 FORMAT (/ + 31H THE NUMBER OF VALUES IN ARRAY , 6A1, + ' LESS THAN ', 8A1, 4H IS , I6, '.') 1010 FORMAT( + 25H THE VALUES IN THE ARRAY , 6A1, + ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.') 1020 FORMAT( + 35H THE NUMBER OF VALUES IN THE ARRAY , 6A1, + ' LESS THAN ', 8A1/ + 19H MUST BE LESS THAN , I5, '.') 1030 FORMAT( + 25H THE VALUES IN THE ARRAY , 6A1, + ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.') 1040 FORMAT( + 35H THE NUMBER OF VALUES IN THE ARRAY , 6A1, + ' LESS THAN ', 8A1/ + 19H MUST BE LESS THAN , I5, '.') 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 ERROR = .FALSE. C IF (NVAL .EQ. NEQ) RETURN C ERROR = .TRUE. C CALL IPRINT (IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL C C PRINT MESSAGE FOR ARIMA ROUTINES C WRITE (IPRT, 1010) (NMVAR1(I), I=1,6), NEQ RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + ' MUST BE GREATER THAN OR EQUAL TO'/ + 1X, I5, ' = ONE PLUS THE SUM OF MSPEC(1,J)+MSPEC(3,J) FOR', + ' J = 1, ..., NFAC,'/ + 6X, ' = ONE PLUS THE NUMBER OF AUTOREGRESSIVE PARAMETERS PLUS'/ + 9X, ' THE NUMBER OF MOVING AVERAGE PARAMETERS.') C 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 ERROR = .FALSE. C IF (NVAL .GE. NMIN) RETURN C ERROR = .TRUE. C CALL IPRINT (IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL 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 (IPRT, 1010) (NMVAR1(I), I=1,6), NMIN RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL BASED ON OTHER INPUT C ARGUMENTS. C 30 WRITE (IPRT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C FIRST DIMENSION OF A DIMENSIONED ARRAY. C 40 WRITE (IPRT, 1030) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6), + (NMVAR2(I), I=1,8) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C SECOND DIMENSION OF A DIMENSIONED ARRAY. C 50 WRITE (IPRT, 1040) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6), + (NMVAR2(I), I=1,8) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHEN ARGUMENT IS LDSTAK. C 60 WRITE(IPRT, 1050) NMIN 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 (IPRT, 1060) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF A VECTOR. C 80 WRITE (IPRT, 1070) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6), + (NMVAR2(I), I=1,8) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF THE VECTORS ACOV AND NLPPA. C 90 WRITE (IPRT, 1080) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) RETURN C C PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE C DIMENSION OF A VECTOR. C 100 WRITE (IPRT, 1090) (NMVAR1(I), I=2,7), (NMVAR1(I), I=1,6), + NMIN RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , I5, '.') 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') 1030 FORMAT( + 24H THE FIRST DIMENSION OF , 6A1, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') 1040 FORMAT( + 25H THE SECOND DIMENSION OF , 6A1, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') 1050 FORMAT( + 55H THE DIMENSION OF THE DOUBLE PRECISION VECTOR DSTAK, AS, + 13H INDICATED BY/ + 54H THE ARGUMENT LDSTAK, MUST BE GREATER THAN OR EQUAL TO, + I5, '.') 1060 FORMAT( + 24H THE FIRST DIMENSION OF , 6A1, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 34H, MUST BE GREATER THAN OR EQUAL TO, + 34H THE NUMBER OF UNFIXED PARAMETERS.) 1070 FORMAT( + 15H THE LENGTH OF , 6A1, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') 1080 FORMAT( + 29H THE LENGTH OF ACOV AND NLPPA, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') 1090 FORMAT( + 15H THE LENGTH OF , 6A1, + 30H, AS INDICATED BY THE ARGUMENT/ + 1X, 6A1, 35H, MUST BE GREATER THAN OR EQUAL TO , I6, '.') C 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 ERROR = .FALSE. C IF (((IVALMN.LE.IVAL) .AND. (IVAL.LE.IVALMX)) .OR. + (IVALMX.LT.IVALMN)) RETURN C ERROR = .TRUE. CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.2) WRITE (IPRT, 1000) (NMVAR(I),I=1,6), IVAL C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) + WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) + WRITE (IPRT, 1020) (NMVAR(I),I=1,6), IVALMN, IVALMX C C PRINT MESSAGE FOR AOV ROUTINES C IF (MSGTYP .EQ. 3) + WRITE (IPRT, 1030) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I6, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 16H MUST BE BETWEEN, 1X, 8A1, + 5H AND , 8A1, 12H, INCLUSIVE.) 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 16H MUST BE BETWEEN, 1X, I6, + 5H AND , I6, 12H, INCLUSIVE.) 1030 FORMAT(/' THE NUMBER OF DISTINCT GROUPS (NG) MUST BE BETWEEN'/ + ' TWO AND ONE LESS THAN THE NUMBER OF POSITIVE TAG VALUES.') C END *EISLE SUBROUTINE EISLE(NMSUB, NMVAR1, NVAL, NMAX, MSGTYP, HEAD, ERROR, + NMVAR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE VALUE NVAL IS LESS THAN C OR EQUAL TO NMAX 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 - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + MSGTYP,NMAX,NVAL LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER NMAX C THE MAXIMUM ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED. 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 LARGE BASED C ON LIMITS IMPOSED BY STARPAC C MSGTYP = 2 THE INPUT VALUE WAS TOO LARGE BASED ON OTHER INPUT C ARGUMENTS. 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 ERROR = .FALSE. C IF (NVAL .LE. NMAX) RETURN C ERROR = .TRUE. C CALL IPRINT (IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR1(I), I=1,6), NVAL C GO TO (10, 20), MSGTYP C C PRINT MESSAGE FOR VALUE TOO LARGE BASED ON LIMITS IMPOSED C BY STARPAC. C 10 WRITE (IPRT, 1010) (NMVAR1(I), I=1,6), NMAX RETURN C C PRINT MESSAGE FOR VALUE TOO LARGE BASED ON OTHER INPUT C ARGUMENTS. C 20 WRITE (IPRT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , I5, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 31H MUST BE LESS THAN OR EQUAL TO , I5, '.') 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 31H MUST BE LESS THAN OR EQUAL TO , 8A1, '.') C END *EISRNG SUBROUTINE EISRNG (NMSUB, ISEED, ISEEDU, HEAD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE INPUT VARIABLE ISEED IS C WITHIN [0, 2**MDIG], AND, IF NONZERO, IS ODD. C C IF ISEED IS WITHIN [0, 2**MDIG] THEN C ISEEDU = ISEED-MOD(ISEED,2)+1 C ELSE C ISEEDU = MIN[ ABS(ISEED)-MOD(ABS(ISEED),2)+1, 2**(MDIG-1)-1] C AND AN ERROR MESSAGE IS PRINTED. C C WRITTEN BY - JANET R. DONALDSON C CENTER FOR COMPUTING AND APPLIED MATHEMATICS C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, COLORADO C C CREATION DATE - JANUARY 17, 1990 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISEED,ISEEDU LOGICAL + HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + IPRT,MDIG C C EXTERNAL FUNCTIONS INTEGER + I1MACH EXTERNAL I1MACH C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN,MOD 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 IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER ISEED C THE VALUE OF THE SEED BEING TESTED. C INTEGER ISEEDU C THE VALUE OF THE SEED ACTUALLY USED BY NRAND AND NRANDC. C INTEGER MDIG C A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE C FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C MDIG = MIN(I1MACH(8)+1,32) C C CHECK FOR VIOLATIONS C IF ((ISEED.EQ.0) .OR. + ((ISEED.GE.1) .AND. + (ISEED.LE.2**(MDIG-1)-1) .AND. + (MOD(ISEED,2).EQ.1))) THEN C C SUPPLIED SEED WILL BE USED C ISEEDU = ISEED ELSE C C VIOLATIONS FOUND C ISEEDU = MIN( ABS(ISEED)+MOD(ABS(ISEED),2)-1, 2**(MDIG-1)-1) CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1010) MDIG-1,ISEEDU END IF C RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + ' THE VALUE OF ISEED MUST BE BETWEEN 0 AND 2**',I2,' - 1,'/ + ' INCLUSIVE, AND, IF ISEED IS NOT 0, ISEED MUST BE ODD. THE'/ + ' SEED ACTUALLY USED BY THE RANDOM NUMBER GENERATOR HAS BEEN'/ + ' SET TO', I10,'.') C END *EIVEO SUBROUTINE EIVEO (NMSUB, NMVAR, IVEC, N, EVEN, HEAD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER EACH OF THE VALUES IN THE INPUT C VECTOR IVEC ARE EVEN (OR ODD) AND PRINTS A C DIAGNOSTIC IF THEY ARE NOT. C C WRITTEN BY - JANET R. DONALDSON 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 + N LOGICAL + EVEN,HEAD C C ARRAY ARGUMENTS INTEGER + IVEC(*) CHARACTER + NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL EVEN C AN INDICATOR VARIABLE DESIGNATING WHETHER THE VALUES OF IVEC C SHOULD BE EVEN (TRUE) OR NOT (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 IVEC(N) C THE VECTOR BEING TESTED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE PARAMETERS NAME. C C CHECK FOR VIOLATIONS C DO 10 I = 1, N IF ((EVEN .AND. (MOD(IVEC(I), 2) .EQ. 1)) .OR. + ((.NOT.EVEN) .AND. (MOD(IVEC(I), 2) .EQ. 1))) GO TO 20 10 CONTINUE C RETURN C C VIOLATIONS FOUND C 20 CONTINUE C CALL IPRINT(IPRT) C CALL EHDR(NMSUB, HEAD) C IF (EVEN) GO TO 40 C WRITE (IPRT, 1010) (NMVAR(I), I = 1, 6) RETURN C 40 CONTINUE WRITE (IPRT, 1020) (NMVAR(I), I = 1, 6) RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + 26H THE VALUES IN THE VECTOR , 6A1, + 27H MUST ALL BE ODD. THE NEXT/ + 53H LARGER INTEGER WILL BE USED IN PLACE OF EVEN VALUES.) 1020 FORMAT(/ + 26H THE VALUES IN THE VECTOR , 6A1, + 28H MUST ALL BE EVEN. THE NEXT/ + 52H LARGER INTEGER WILL BE USED IN PLACE OF ODD VALUES.) C END *EIVEQ SUBROUTINE EIVEQ (NMSUB, NMVAR1, IVEC, N, IVAL, NEQMN, HEAD, NEQ, + NNE, MSGTYP, ERROR, NMVAR2, NMVAR3) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE NUMBER OF ELEMENTS OF IVEC EQUAL C TO IVAL IS AT LEAST NEQMN. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - AUGUST 3, 1987 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVAL,MSGTYP,N,NEQ,NEQMN,NNE LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS INTEGER + IVEC(*) CHARACTER + NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1,NMVAR3(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 IVEC(N) C THE VECTOR BEING CHECKED. 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 ON LIMITS C IMPOSED BY STARPAC. C INTEGER N C THE NUMBER OF OBSERVATIONS. 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 CHARACTER*1 NMVAR3(8) C THE CHARACTERS OF THE NAME OF THE ARGUMENT THAT THE ELEMENTS C MUST BE EQUAL TO. C INTEGER NEQ C THE NUMBER OF ELEMENTS EQUAL TO IVAL. C INTEGER NEQMN C THE MINIMUM NUMBER OF ELEMENTS EQUAL TO IVAL WHICH IS OK. C INTEGER NNE C THE NUMBER OF ELEMENTS NOT EQUAL TO IVAL. C ERROR = .FALSE. C IF (N.LE.0) RETURN C C CHECK FOR VALUES EQUAL TO IVAL C NEQ = 0 DO 10 I = 1, N IF (IVEC(I) .EQ. IVAL) NEQ = NEQ + 1 10 CONTINUE C NNE = N - NEQ IF (NEQ .GE. NEQMN) RETURN C C INSUFFICIENT NUMBER OF ELEMENTS EQUAL TO IVAL. C ERROR = .TRUE. C CALL IPRINT(IPRT) C CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.EQ.1) WRITE(IPRT, 1000) + (NMVAR1(I),I=1,8), (NMVAR2(I),I=1,8), NEQ, + (NMVAR2(I),I=1,8), (NMVAR3(I),I=1,8) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT( + ' THE NUMBER OF ELEMENTS IN ', 8A1, + ' EQUAL TO ', 8A1, ' IS ', I6, '.'/ + ' THE NUMBER OF ELEMENTS EQUAL TO ', 8A1, + ' MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.') C END *EIVII SUBROUTINE EIVII (NMSUB, NMVAR, IVEC, N, IVECLB, IVECUB, NVMX, + HEAD, MSGTYP, NV, ERROR, NMMIN, NMMAX) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS FOR VALUES IN THE INPUT VECTOR IVEC C WHICH ARE OUTSIDE THE (INCLUSIVE) LIMITS IVECLB TO IVECUB, PRINTS C AN ERROR MESSAGE IF THE NUMBER OF VIOLATIONS EXCEEDS THE LARGEST C NUMBER OF VIOLATIONS ALLOWED, AND RETURNS THE NUMBER OF C VIOLATIONS AND AN ERROR FLAG INDICATING THE RESULTS. 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 + IVECLB,IVECUB,MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS INTEGER + IVEC(*) CHARACTER + NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVEC(N) C THE VECTOR BEING TESTED. C INTEGER IVECLB, IVECUB C THE (INCLUSIVE) RANGE THAT THE VECTOR IS BEING TESTED C AGAINST. C INTEGER MSGTYP C THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE. C IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN AND C NMMAX, OTHERWISE IT WILL USE IVECLB AND IVECUB. 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 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 INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C ERROR = .FALSE. C IF (N.LE.0) RETURN IF (IVECUB.LT.IVECLB) RETURN C C TEST WHETHER TESTING IS NECESSRY C IF ((MOD(MSGTYP,3) .EQ. 0) .AND. + ((IVEC(1) .LT. IVECLB) .OR. (IVEC(1) .GT. IVECUB))) RETURN C C CHECK FOR VIOLATIONS C NV = 0 DO 5 I = 1, N IF ((IVEC(I).LT.IVECLB) .OR. (IVEC(I).GT.IVECUB)) NV = NV + 1 5 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.3) + WRITE (IPRT, 1000) (NMVAR(I),I=1,6), IVECLB, IVECUB, NV IF (MSGTYP.GE.4) + WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8), NV C GO TO (10, 20, 30, 10, 20, 30), MSGTYP C 10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6) RETURN C 20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), NVMX RETURN C 30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ + 32H THE NUMBER OF VALUES IN VECTOR , 6A1, + 19H OUTSIDE THE RANGE , I6, 3H TO/ + 1X, I6, 16H, INCLUSIVE, IS , I6, '.') 1005 FORMAT (/ + 32H THE NUMBER OF VALUES IN VECTOR , 6A1, + 19H OUTSIDE THE RANGE , 8A1, 3H TO/ + 1X, 8A1, 16H, INCLUSIVE, IS , I6, '.') 1010 FORMAT( + 26H THE VALUES IN THE VECTOR , 6A1, + 31H MUST ALL BE WITHIN THIS RANGE.) 1020 FORMAT( + 36H THE NUMBER OF VALUES IN THE VECTOR , 6A1, + 19H OUTSIDE THIS RANGE/ + 19H MUST BE LESS THAN , I5, '.') 1030 FORMAT( + 34H IF THE FIRST VALUE OF THE VECTOR , 6A1, + 21H IS WITHIN THIS RANGE/ + 45H ALL OF THE VALUES MUST BE WITHIN THIS RANGE.) C END *ENFFT SUBROUTINE ENFFT(NMSUB, NFFT, NDIV, N, LYFFT, NFFT2, HEAD, ERROR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER THE VALUE NFFT IS SUCH THAT NFFT-2 IS C DIVISIBLE BY NDIV AND HAS NO PRIME FACTORS GREATER THAN 23, AND C THE PRODUCT OF THE SQUARE FREE PRIME FACTORS OF NFFT - 2 DO NOT C EXCEED 209, I.E., THE VALUE OF NFFT MEETS THE REQUIREMENTS OF C THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE C USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV C IS CHOSEN. C C WRITTEN BY - JANET R. DONALDSON 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 + LYFFT,N,NDIV,NFFT,NFFT2 LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + IPRT,NFFT1 C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT,SETESL C C INTRINSIC FUNCTIONS INTRINSIC MAX 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 IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER LYFFT C THE LENGTH OF THE VECTOR CONTAINING THE SERIES TO BE EXTENDED. C INTEGER N C THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C INTEGER NFFT C THE USER SUPPLIED EXTENDED SERIES LENGTH. C INTEGER NFFT1 C THE MAXIMUM OF NFFT AND N+2. C INTEGER NFFT2 C THE SMALLEST EXTENDED SERIES LENGTH WHICH EQUALS OR C EXCEEDS NFFT AND WHICH MEETS THE REQUIREMENTS OF C SINGLETONS FFT CODE. C ERROR = .FALSE. CALL IPRINT (IPRT) C IF (NFFT .GE. N+2) GO TO 20 C C PRINT WARNING C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1050) N C 20 CONTINUE NFFT1 = MAX(NFFT, N+2) CALL SETESL(NFFT1-2, NDIV, NFFT2) C IF (NFFT .EQ. NFFT2) RETURN C C PRINT WARNING C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1020) NFFT, NFFT2 C IF (NFFT .GT. LYFFT) GO TO 40 C WRITE (IPRT, 1030) NFFT2 RETURN C 40 CONTINUE C ERROR = .TRUE. C WRITE (IPRT, 1040) NFFT2, LYFFT RETURN C C FORMAT STATEMENTS C 1020 FORMAT (/ + 40H THE INPUT VALUE OF THE PARAMETER NFFT (, I5, + 15H) DOES NOT MEET/ + 51H THE REQUIREMENTS OF SINGLETONS FFT CODE. THE NEXT, + 13H LARGER VALUE/ + 15H WHICH DOES IS , I5, '.') 1030 FORMAT (/ + 11H THE VALUE , I5, 37H WILL BE USED FOR THE EXTENDED SERIES, + 8H LENGTH.) 1040 FORMAT (/ + 20H HOWEVER, THE VALUE , I5, 27H EXCEEDS THE LENGTH LYFFT (, + I5, 8H) OF THE/ + 58H VECTOR YFFT, AND THEREFORE CANNOT BE USED AS THE EXTENDED/ + 43H SERIES LENGTH WITHOUT REDIMENSIONING YFFT.) 1050 FORMAT (/ + 56H THE EXTENDED SERIES LENGTH (NFFT) MUST EQUAL OR EXCEED,/ + 45H THE NUMBER OF OBSERVATIONS IN THE SERIES (N=, I5, + 9H) PLUS 2.) C END *EPRINT SUBROUTINE EPRINT C C THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY. C C C VARIABLE DECLARATIONS C C LOCAL ARRAYS CHARACTER MESSG(1)*4 C C EXTERNAL SUBROUTINES EXTERNAL E9RINT C C CALL E9RINT(MESSG,1,1,.FALSE.) RETURN C END *ERAGT SUBROUTINE ERAGT (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 REAL + YMMN INTEGER + IYM,M,MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + YM(*) CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,J C C EXTERNAL SUBROUTINES EXTERNAL ERAGTP 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 REAL YM(IYM,M) C THE ARRAY BEING TESTED. C REAL YMMN C THE MINIMUM ACCEPTABLE VALUE. 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) .LE. YMMN) NV = NV + 1 1 CONTINUE 5 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. C CALL ERAGTP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV, + NMMIN) C RETURN C END *ERAGTM SUBROUTINE ERAGTM (NMSUB, NMVAR, YM, YMMISS, 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 ELEMENTS OF YM(*, I) EQUAL TO YMMISS(I) ARE EXEMPT FROM CHECKING. 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 REAL + YMMN INTEGER + IYM,M,MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,J C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C EXTERNAL SUBROUTINES EXTERNAL ERAGTP 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 REAL YM(IYM,M) C THE ARRAY BEING TESTED. C REAL YMMISS(M) C MISSING VALUE CODES FOR EACH COLUMN OF YM C REAL YMMN C THE MINIMUM ACCEPTABLE VALUE. 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 (MVCHK(YM(I+(J-1)*IYM), YMMISS(J))) GO TO 1 IF (YM(I+(J-1)*IYM) .LE. YMMN) NV = NV + 1 1 CONTINUE 5 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. CALL ERAGTP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV, + NMMIN) C RETURN C END *ERAGTP SUBROUTINE ERAGTP (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 REAL + YMMN INTEGER + MSGTYP,NV,NVMX LOGICAL + HEAD C C ARRAY ARGUMENTS CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 REAL YMMN C THE MINIMUM ACCEPTABLE VALUE. C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.2) + WRITE (IPRT, 1000) (NMVAR(I),I=1,6), YMMN, NV IF (MSGTYP.GE.3) + WRITE (IPRT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV C GO TO (10, 20, 30, 40), MSGTYP C 10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), YMMN RETURN C 20 WRITE(IPRT, 1020) (NMVAR(I),I=1,6), YMMN, NVMX RETURN C 30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C 40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ + 31H THE NUMBER OF VALUES IN ARRAY , 6A1, + 23H LESS THAN OR EQUAL TO , 1PE14.7, 4H IS , I6, '.') 1005 FORMAT (/ + 31H THE NUMBER OF VALUES IN ARRAY , 6A1, + 23H LESS THAN OR EQUAL TO , 8A1, 4H IS , I6, '.') 1010 FORMAT( + 25H THE VALUES IN THE ARRAY , 6A1, + 26H MUST ALL BE GREATER THAN , 1PE14.7, '.') 1020 FORMAT( + 35H THE NUMBER OF VALUES IN THE ARRAY , 6A1, + 23H LESS THAN OR EQUAL TO , 8A1/ + 19H MUST BE LESS THAN , I5, '.') 1030 FORMAT( + 25H THE VALUES IN THE ARRAY , 6A1, + 26H MUST ALL BE GREATER THAN , 1PE14.7, '.') 1040 FORMAT( + 35H THE NUMBER OF VALUES IN THE ARRAY , 6A1, + 23H LESS THAN OR EQUAL TO , 8A1/ + 19H MUST BE LESS THAN , I5, '.') C END *ERDF SUBROUTINE ERDF(NMSUB, NDF, IOD, ND, N, 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 DIFFERENCING ON A 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 21, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NDF LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS INTEGER + IOD(*),ND(*) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + I,IER,IPRT,MBOD C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 IER C AN ERROR INDICATOR. C INTEGER IOD(NDF) C THE VECTOR CONTAINING THE ORDERS OF EACH DIFFERENCE FACTOR. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MBOD C THE MAXIMUM BACKORDER DUE TO DIFFERENCING. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER ND(NDF) C THE VECTOR CONTAINING THE NUMBER OF TIMES EACH DIFFERENCE C FACTOR IS APPLIED. C INTEGER NDF C THE NUMBER OF DIFFERENCE FACTORS TO BE APPLIED TO THE SERIES. C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINE NAME. C ERROR = .FALSE. C IF (NDF .GE. 0) GO TO 10 CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1001) NDF ERROR = .TRUE. RETURN C 10 IF (NDF .EQ. 0) RETURN C IER = 0 MBOD = 0 DO 30 I = 1, NDF IF (IOD(I) .GE. 1 .AND. ND(I) .GE. 1) GO TO 20 IER = 1 GO TO 40 20 MBOD = MBOD + IOD(I) * ND(I) 30 CONTINUE IF (MBOD .LE. N - 1) RETURN C 40 CONTINUE CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) IF (IER .EQ. 1) + WRITE (IPRT, 1002) (I, ND(I), IOD(I), I = 1, NDF) IF (IER .EQ. 0 .AND. MBOD .GE. N) WRITE (IPRT, 1003) MBOD, N ERROR = .TRUE. RETURN C C FORMAT STATEMENTS C 1001 FORMAT(/44H THE NUMBER OF DIFFERENCE FACTORS (NDF) MUST/ + 54H BE GREATER THAN OR EQUAL TO ZERO. THE INPUT VALUE OF/ + 8H NDF IS , I6, '.') 1002 FORMAT (/46H THE ORDER OF EACH DIFFERENCE FACTOR (IOD) AND/ + 56H NUMBER OF TIMES IT IS APPLIED (ND) MUST BE GREATER THAN/ + 52H EQUAL TO ONE. THE INPUT VALUES OF THESE ARRAYS ARE/ + 25H DIF. FACT. ND IOD/ + (1X, I13, I5, I6)) 1003 FORMAT (/50H THE MAXIMUM BACKORDER DUE TO DIFFERENCING (MBOD), + /54H THAT IS, THE SUM OF ND(I)*IOD(I), I = 1, 2, ..., NDF,/ + 59H MUST BE LESS THAN OR EQUAL TO N-1. THE COMPUTED VALUE FOR/ + 9H MBOD IS , I6, 33H, WHILE THE INPUT VALUE FOR N IS , I6, '.') END *ERFC REAL FUNCTION ERFC (X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL ETA,SQEPS,SQRTPI,XMAX,XSML,Y INTEGER NTERC2,NTERF,NTERFC C C LOCAL ARRAYS REAL ERC2CS(23),ERFCCS(24),ERFCS(13) C C EXTERNAL FUNCTIONS REAL CSEVL,R1MACH INTEGER INITS EXTERNAL CSEVL,R1MACH,INITS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,EXP,LOG,SQRT C C C SERIES FOR ERF ON THE INTERVAL 0. TO 1.00000D+00 C WITH WEIGHTED ERROR 7.10E-18 C LOG WEIGHTED ERROR 17.15 C SIGNIFICANT FIGURES REQUIRED 16.31 C DECIMAL PLACES REQUIRED 17.71 C DATA ERF CS( 1) / -.0490461212 34691808E0 / DATA ERF CS( 2) / -.1422612051 0371364E0 / DATA ERF CS( 3) / .0100355821 87599796E0 / DATA ERF CS( 4) / -.0005768764 69976748E0 / DATA ERF CS( 5) / .0000274199 31252196E0 / DATA ERF CS( 6) / -.0000011043 17550734E0 / DATA ERF CS( 7) / .0000000384 88755420E0 / DATA ERF CS( 8) / -.0000000011 80858253E0 / DATA ERF CS( 9) / .0000000000 32334215E0 / DATA ERF CS(10) / -.0000000000 00799101E0 / DATA ERF CS(11) / .0000000000 00017990E0 / DATA ERF CS(12) / -.0000000000 00000371E0 / DATA ERF CS(13) / .0000000000 00000007E0 / C C SERIES FOR ERFC ON THE INTERVAL 0. TO 2.50000D-01 C WITH WEIGHTED ERROR 4.81E-17 C LOG WEIGHTED ERROR 16.32 C APPROX SIGNIFICANT FIGURES REQUIRED 15.0 C SERIES FOR ERC2 ON THE INTERVAL 2.50000D-01 TO 1.00000D+00 C WITH WEIGHTED ERROR 5.22E-17 C LOG WEIGHTED ERROR 16.28 C APPROX SIGNIFICANT FIGURES REQUIRED 15.0 C DECIMAL PLACES REQUIRED 16.96 C DATA ERC2CS( 1) / -.0696013466 02309501E0 / DATA ERC2CS( 2) / -.0411013393 62620893E0 / DATA ERC2CS( 3) / .0039144958 66689626E0 / DATA ERC2CS( 4) / -.0004906395 65054897E0 / DATA ERC2CS( 5) / .0000715747 90013770E0 / DATA ERC2CS( 6) / -.0000115307 16341312E0 / DATA ERC2CS( 7) / .0000019946 70590201E0 / DATA ERC2CS( 8) / -.0000003642 66647159E0 / DATA ERC2CS( 9) / .0000000694 43726100E0 / DATA ERC2CS(10) / -.0000000137 12209021E0 / DATA ERC2CS(11) / .0000000027 88389661E0 / DATA ERC2CS(12) / -.0000000005 81416472E0 / DATA ERC2CS(13) / .0000000001 23892049E0 / DATA ERC2CS(14) / -.0000000000 26906391E0 / DATA ERC2CS(15) / .0000000000 05942614E0 / DATA ERC2CS(16) / -.0000000000 01332386E0 / DATA ERC2CS(17) / .0000000000 00302804E0 / DATA ERC2CS(18) / -.0000000000 00069666E0 / DATA ERC2CS(19) / .0000000000 00016208E0 / DATA ERC2CS(20) / -.0000000000 00003809E0 / DATA ERC2CS(21) / .0000000000 00000904E0 / DATA ERC2CS(22) / -.0000000000 00000216E0 / DATA ERC2CS(23) / .0000000000 00000052E0 / C C DECIMAL PLACES REQUIRED 17.01 C DATA ERFCCS( 1) / 0.0715179310 202925E0 / DATA ERFCCS( 2) / -.0265324343 37606719E0 / DATA ERFCCS( 3) / .0017111539 77920853E0 / DATA ERFCCS( 4) / -.0001637516 63458512E0 / DATA ERFCCS( 5) / .0000198712 93500549E0 / DATA ERFCCS( 6) / -.0000028437 12412769E0 / DATA ERFCCS( 7) / .0000004606 16130901E0 / DATA ERFCCS( 8) / -.0000000822 77530261E0 / DATA ERFCCS( 9) / .0000000159 21418724E0 / DATA ERFCCS(10) / -.0000000032 95071356E0 / DATA ERFCCS(11) / .0000000007 22343973E0 / DATA ERFCCS(12) / -.0000000001 66485584E0 / DATA ERFCCS(13) / .0000000000 40103931E0 / DATA ERFCCS(14) / -.0000000000 10048164E0 / DATA ERFCCS(15) / .0000000000 02608272E0 / DATA ERFCCS(16) / -.0000000000 00699105E0 / DATA ERFCCS(17) / .0000000000 00192946E0 / DATA ERFCCS(18) / -.0000000000 00054704E0 / DATA ERFCCS(19) / .0000000000 00015901E0 / DATA ERFCCS(20) / -.0000000000 00004729E0 / DATA ERFCCS(21) / .0000000000 00001432E0 / DATA ERFCCS(22) / -.0000000000 00000439E0 / DATA ERFCCS(23) / .0000000000 00000138E0 / DATA ERFCCS(24) / -.0000000000 00000048E0 / C DATA SQRTPI /1.772453850 9055160E0/ DATA NTERF, NTERFC, NTERC2, XSML, XMAX, SQEPS /3*0, 3*0./ C IF (NTERF.NE.0) GO TO 10 ETA = 0.1*R1MACH(3) NTERF = INITS (ERFCS, 13, ETA) NTERFC = INITS (ERFCCS, 24, ETA) NTERC2 = INITS (ERC2CS, 23, ETA) C XSML = -SQRT (-LOG(SQRTPI*R1MACH(3))) XMAX = SQRT (-LOG(SQRTPI*R1MACH(1))) XMAX = XMAX - 0.5*LOG(XMAX)/XMAX - 0.01 SQEPS = SQRT (2.0*R1MACH(3)) C 10 IF (X.GT.XSML) GO TO 20 C C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML C ERFC = 2.0 RETURN C 20 IF (X.GT.XMAX) GO TO 40 Y = ABS(X) IF (Y.GT.1.0) GO TO 30 C C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1. C IF (Y.LT.SQEPS) THEN ERFC = 1.0 - 2.0*X/SQRTPI ELSE ERFC = 1.0 - X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) ) END IF C RETURN C C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX C 30 Y = Y*Y IF (Y.LE.4.) THEN ERFC = EXP(-Y)/ABS(X) * + (0.5 + CSEVL ((8.0/Y-5.0)/3.0, ERC2CS, NTERC2) ) ELSE ERFC = EXP(-Y)/ABS(X) * + (0.5 + CSEVL (8.0/Y-1.0, ERFCCS, NTERFC) ) END IF IF (X.LT.0.0) ERFC = 2.0 - ERFC RETURN C 40 CALL XERROR ('ERFC X SO BIG ERFC UNDERFLOWS', 32, 1, 1) ERFC = 0.0 RETURN C END *ERF REAL FUNCTION ERF (X) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL SQEPS,SQRTPI,XBIG,Y INTEGER NTERF C C LOCAL ARRAYS REAL ERFCS(13) C C EXTERNAL FUNCTIONS REAL CSEVL,ERFC,R1MACH INTEGER INITS EXTERNAL CSEVL,ERFC,R1MACH,INITS C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,SIGN,SQRT C C C SERIES FOR ERF ON THE INTERVAL 0. TO 1.00000D+00 C WITH WEIGHTED ERROR 7.10E-18 C LOG WEIGHTED ERROR 17.15 C SIGNIFICANT FIGURES REQUIRED 16.31 C DECIMAL PLACES REQUIRED 17.71 C DATA ERF CS( 1) / -.0490461212 34691808E0 / DATA ERF CS( 2) / -.1422612051 0371364E0 / DATA ERF CS( 3) / .0100355821 87599796E0 / DATA ERF CS( 4) / -.0005768764 69976748E0 / DATA ERF CS( 5) / .0000274199 31252196E0 / DATA ERF CS( 6) / -.0000011043 17550734E0 / DATA ERF CS( 7) / .0000000384 88755420E0 / DATA ERF CS( 8) / -.0000000011 80858253E0 / DATA ERF CS( 9) / .0000000000 32334215E0 / DATA ERF CS(10) / -.0000000000 00799101E0 / DATA ERF CS(11) / .0000000000 00017990E0 / DATA ERF CS(12) / -.0000000000 00000371E0 / DATA ERF CS(13) / .0000000000 00000007E0 / C DATA SQRTPI /1.772453850 9055160E0/ DATA NTERF, XBIG, SQEPS / 0, 0., 0./ C IF (NTERF.NE.0) GO TO 10 NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3)) XBIG = SQRT(-LOG(SQRTPI*R1MACH(3))) SQEPS = SQRT(2.0*R1MACH(3)) C 10 Y = ABS(X) IF (Y.GT.1.) GO TO 20 C C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. C IF (Y.LE.SQEPS) THEN ERF = 2.0*X/SQRTPI ELSE ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF)) END IF C RETURN C C ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. C 20 IF (Y.LE.XBIG) THEN ERF = SIGN (1.0-ERFC(Y), X) ELSE ERF = SIGN (1.0, X) END IF C RETURN 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 ERROR = .FALSE. C IF (MSGTYP .EQ. 2) GO TO 10 C C CHECK FOR ODD C IF (MOD(NVAL, 2) .EQ. 1) RETURN C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE(IPRT, 1010) (NMVAR(I), I = 1, 6), (NMVAR(I), I = 1, 6), NVAL ERROR = .TRUE. RETURN C 10 CONTINUE C C CHECK FOR EVEN C IF (MOD(NVAL, 2) .EQ. 0) RETURN C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE(IPRT, 1020) (NMVAR(I), I = 1, 6), (NMVAR(I), I = 1, 6), NVAL ERROR = .TRUE. RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + 27H THE VALUE OF THE VARIABLE , 6A1, + 34H MUST BE ODD. THE INPUT VALUE OF , 6A1/ + 4H IS , I5, '.') 1020 FORMAT(/ + 27H THE VALUE OF THE VARIABLE , 6A1, + 35H MUST BE EVEN. THE INPUT VALUE OF , 6A1/ + 4H IS , I5, '.') C END *ERSEI SUBROUTINE ERSEI(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 (EXCLUSIVE) 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 REAL + 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 REAL VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C REAL VALMN, VALMX C THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE C ARGUMENT MUST LIE. C ERROR = .FALSE. C IF (((VALMN.LT.VAL) .AND. (VAL.LE.VALMX)) .OR. + (VALMX.LT.VALMN)) RETURN C ERROR = .TRUE. CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) + WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) + WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 17H MUST LIE BETWEEN, 1X, 8A1, 12H (EXCLUSIVE)/ + 5H AND , 8A1, 13H (INCLUSIVE).) 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 17H MUST LIE BETWEEN, 1X, G15.8, 12H (EXCLUSIVE)/ + 5H AND , G15.8, 13H (INCLUSIVE).) C END *ERSGE SUBROUTINE ERSGE(NMSUB, NMVAR, VAL, VALMN, MSGTYP, HEAD, ERROR, + NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THE ROUTINE CHECKS WHETHER THE VALUE VAL IS GREATER THAN OR C EQUAL TO VALMN , 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 - JUNE 10, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + VAL,VALMN INTEGER + MSGTYP LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 C LIMITS BASED ON OTHER INPUT ARGUMENTS. 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 REAL VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C REAL VALMN C THE MINIMUM VALUE THE ARGUMENT CAN VALIDLY HAVE. C ERROR = .FALSE. C IF (VAL .GE. VALMN) RETURN C ERROR = .TRUE. CALL IPRINT (IPRT) CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL C GO TO (10, 20), MSGTYP C C PRINT MESSAGE FOR VALUE TOO SMALL BASED ON LIMITS IMPOSED C BY STARPAC. C 10 WRITE (IPRT, 1010) (NMVAR(I),I=1,6), VALMN RETURN C 20 WRITE (IPRT, 1020) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , G21.14, '.') 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') C END *ERSGT SUBROUTINE ERSGT(NMSUB, NMVAR, VAL, VALMN, MSGTYP, HEAD, ERROR, + NMMIN) C C LATEST REVISION - 03/15/90 (JRD) C C THE ROUTINE CHECKS WHETHER THE VALUE VAL IS GREATER THAN C VALMN , 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 - JUNE 10, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + VAL,VALMN INTEGER + MSGTYP LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 C LIMITS BASED ON OTHER INPUT ARGUMENTS. 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 REAL VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C REAL VALMN C THE MINIMUM VALUE THE ARGUMENT CAN VALIDLY HAVE. C ERROR = .FALSE. C IF (VAL .GT. VALMN) RETURN C ERROR = .TRUE. CALL IPRINT (IPRT) CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL C GO TO (10, 20), MSGTYP C 10 WRITE (IPRT, 1010) (NMVAR(I),I=1,6), VALMN RETURN C 20 WRITE (IPRT, 1020) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 22H MUST BE GREATER THAN , G21.14, '.') 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 22H MUST BE GREATER THAN , 8A1, '.') C END *ERSIE SUBROUTINE ERSIE(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 (EXCLUSIVE), 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 REAL + 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 REAL VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C REAL VALMN, VALMX C THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE C ARGUMENT MUST LIE. C ERROR = .FALSE. C IF (((VALMN.LE.VAL) .AND. (VAL.LT.VALMX)) .OR. + (VALMX.LT.VALMN)) RETURN C ERROR = .TRUE. CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) + WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) + WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 17H MUST LIE BETWEEN, 1X, 8A1, 12H (INCLUSIVE)/ + 5H AND , 8A1, 13H (EXCLUSIVE).) 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 17H MUST LIE BETWEEN, 1X, G15.8, 12H (INCLUSIVE)/ + 5H AND , G15.8, 13H (EXCLUSIVE).) 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 REAL + 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 REAL VAL C THE INPUT VALUE OF THE ARGUMENT BEING CHECKED. C REAL VALMN, VALMX C THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE C ARGUMENT MUST LIE. C ERROR = .FALSE. C IF (((VALMN.LE.VAL) .AND. (VAL.LE.VALMX)) .OR. + (VALMX.LT.VALMN)) RETURN C ERROR = .TRUE. CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VAL C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM C OTHER INPUT ARGUMENTS. C IF (MSGTYP .EQ. 1) + WRITE (IPRT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMAX(I),I=1,8) C C PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC C IF (MSGTYP .EQ. 2) + WRITE (IPRT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20H THE INPUT VALUE OF , 6A1, 4H IS , G15.8, '.') 1010 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 16H MUST BE BETWEEN, 1X, 8A1, + 5H AND , 8A1, 12H, INCLUSIVE.) 1020 FORMAT( + 27H THE VALUE OF THE ARGUMENT , 6A1, + 16H MUST BE BETWEEN, 1X, G15.8, + 5H AND , G15.8, 12H, INCLUSIVE.) C END *ERSLF SUBROUTINE ERSLF (NMSUB, NMVAR, K, H, HEAD, ERROR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS ERROR CHECKING FOR THE INPUT C VALUES OF A SYMMETRIC LINEAR 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 LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + H(*) CHARACTER + NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IHM,IHP,IPRT,KHALF,KMID,NZERO C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL H(K) C THE VECTOR OF FILTER COEFFICIENTS. 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 IHM, IHP C INDEX VARIABLES FOR SYMMETRIC LOCATIONS AROUND THE MIDPOINT C OF THE FILTER. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. 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 CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C CHARACTER*1 NMVAR(8) C THE ARRAY CONTAINING THE NAME OF THE FILTER COEFFICIENT C ARRAY. C INTEGER NZERO C THE NUMBER OF FILTER COEFFICIENTS EQUAL TO ZERO. C ERROR = .FALSE. C KMID = (K + 1) / 2 KHALF = KMID - 1 NZERO = 0 DO 10 IHM = 1, KHALF IHP = K + 1 - IHM IF (H(IHM) .EQ. 0.0E0) NZERO = NZERO + 1 IF (H(IHM) .EQ. H(IHP)) GO TO 10 C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1010) (NMVAR(I), I = 1, 6), (H(I), I = 1, K) ERROR = .TRUE. RETURN 10 CONTINUE C IF (H(KMID) .EQ. 0.0E0) NZERO = NZERO + 1 C IF (NZERO .LT. KMID) RETURN C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1020) (NMVAR(I), I = 1, 6) ERROR = .TRUE. C RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + 18H THE INPUT FILTER , 6A1, 24H MUST BE SYMMETRIC. THE, + 30H INPUT FILTER COEFFICIENTS ARE/ + 5(1X, E15.5)) 1020 FORMAT(/ + 32H ALL THE FILTER COEFFICIENTS IN , 6A1, 16H ARE IDENTICALLY, + 15H EQUAL TO ZERO,/ + 42H THEREFORE NO FILTERING WILL BE PERFORMED.) 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 REAL + FC INTEGER + K LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS REAL + TEMP INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL 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 REAL TEMP C A TEMPORARY VARIABLE USED FOR TYPE CONVERSION. C ERROR = .FALSE. TEMP = K C IF (FC - 1.0E0/TEMP .GE. 0.0E0) GO TO 10 C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1010) FC, K ERROR = .TRUE. RETURN C 10 CONTINUE C IF (FC + 1.0E0/K .LT. 0.5E0) RETURN C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE (IPRT, 1020) FC, K ERROR = .TRUE. RETURN C C FORMAT STATEMENTS C 1010 FORMAT (/36H THE CUTOFF FREQUENCY, FC, MINUS ONE, + 41H OVER THE NUMBER OF FILTER TERMS, K, THAT/ + 53H IS, FC - 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO., + 29H THE INPUT VALUES OF FC AND K/ + 4H ARE, F8.5, 4H AND, I5, 15H, RESPECTIVELY.) 1020 FORMAT (/35H THE CUTOFF FREQUENCY, FC, PLUS ONE, + 45H OVER THE NUMBER OF FILTER TERMS, K, THAT IS,/ + 49H FC + 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO., + 29H THE INPUT VALUES OF FC AND K/ + 4H ARE, F7.5, 4H AND, I5, 15H, RESPECTIVELY.) C 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 REAL + VECLB INTEGER + MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + 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 REAL VEC(N) C THE VECTOR BEING TESTED. C REAL VECLB C THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST. 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 *ERVGTM SUBROUTINE ERVGTM (NMSUB, NMVAR, VEC, VCMISS, 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 VALUES OF VEC EQUAL TO VCMISS ARE EXEMPTED FROM THE CHECKING. 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 REAL + VCMISS,VECLB INTEGER + MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + VEC(*) CHARACTER + NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,NVMN C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK 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 REAL VCMISS C MISSING VALUE CODE IN VEC. C REAL VEC(N) C THE VECTOR BEING TESTED. C REAL VECLB C THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST. 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 (MVCHK(VEC(I), VCMISS)) GO TO 5 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 *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 REAL + 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,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 REAL VECLB C THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST. C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) C IF (MSGTYP.LE.3) THEN WRITE (IPRT, 1000) (NMVAR(I),I=1,6), VECLB, NV ELSE IF (MSGTYP.GE.7) THEN WRITE (IPRT, 1001) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV ELSE WRITE (IPRT, 1002) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV END IF END IF C GO TO (10, 20, 30, 40, 50, 60, 70), MSGTYP C 10 WRITE(IPRT, 1010) (NMVAR(I),I=1,6), VECLB RETURN C 20 WRITE(IPRT, 1020) (NMVAR(I),I=1,3), VECLB, NVMX RETURN C 30 WRITE(IPRT, 1030) (NMVAR(I),I=1,6), VECLB, VECLB RETURN C 40 WRITE(IPRT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C 50 WRITE(IPRT, 1050) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NVMX RETURN C 60 WRITE(IPRT, 1060) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), + (NMMIN(I),I=1,8) RETURN C 70 WRITE(IPRT, 1070) NVMN, (NMVAR(I),I=1,6), (NMMIN(I),I=1,8) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/ + 32H THE NUMBER OF VALUES IN VECTOR , 6A1, + 23H LESS THAN OR EQUAL TO , 1PE14.7, 4H IS , I6, '.') 1001 FORMAT (/ + 32H THE NUMBER OF VALUES IN VECTOR , 6A1, + ' GREATER THAN ', 8A1, ' IS ', I2, '.') 1002 FORMAT (/ + 32H THE NUMBER OF VALUES IN VECTOR , 6A1, + 23H LESS THAN OR EQUAL TO , 8A1, 4H IS , I6, '.') 1010 FORMAT( + 26H THE VALUES IN THE VECTOR , 6A1, + 26H MUST ALL BE GREATER THAN , 1PE14.7, '.') 1020 FORMAT( + 36H THE NUMBER OF VALUES IN THE VECTOR , 6A1, + 23H LESS THAN OR EQUAL TO , 1PE14.7/ + 19H MUST BE LESS THAN , I5, '.') 1030 FORMAT( + 37H SINCE THE FIRST VALUE OF THE VECTOR , 6A1, + 17H IS GREATER THAN , 1PE14.7/ + 40H ALL OF THE VALUES MUST BE GREATER THAN , 1PE14.7, '.') 1040 FORMAT( + 26H THE VALUES IN THE VECTOR , 6A1, + 26H MUST ALL BE GREATER THAN , 8A1, '.') 1050 FORMAT( + 36H THE NUMBER OF VALUES IN THE VECTOR , 6A1, + 23H LESS THAN OR EQUAL TO , 8A1/ + 19H MUST BE LESS THAN , I5, '.') 1060 FORMAT( + 37H SINCE THE FIRST VALUE OF THE VECTOR , 6A1, + 17H IS GREATER THAN , 8A1/ + 40H ALL OF THE VALUES MUST BE GREATER THAN , 8A1, '.') 1070 FORMAT(/' THERE MUST BE AT LEAST ', I2, ' VALUES IN VECTOR ', 6A1/ + ' GREATER THAN OR EQUAL TO ', 8A1, '.') C END *ERVII SUBROUTINE ERVII (NMSUB, NMVAR, Y, N, YLB, YUB, NVMX, + HEAD, MSGTYP, NV, ERROR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS FOR VALUES IN THE INPUT VECTOR Y C WHICH ARE OUTSIDE THE (INCLUSIVE) LIMITS YLB TO YUB, PRINTS C AN ERROR MESSAGE IF THE NUMBER OF VIOLATIONS EXCEEDS THE LARGEST C NUMBER OF VIOLATIONS ALLOWED, AND RETURNS THE NUMBER OF C VIOLATIONS AND AN ERROR FLAG INDICATING THE RESULTS. THREE C MESSAGES ARE AVAILABLE, SPECIFIED BY MSGTYP . C IF (MSGTYP = 0) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 1) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C IF (MSGTYP = 2) VIOLATIONS ARE COUNTED ONLY IF THE C THE FIRST ELEMENT IS NOT IN VIOLATION. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YUB INTEGER + MSGTYP,N,NV,NVMX LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + Y(*) CHARACTER + NMSUB(6)*1,NMVAR(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT,NNV,NNVMN C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 VARIABLE. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MSGTYP C THE INDICATOR VARIABLE FOR THE TYPE OF MESSAGE. C IF (MSGTYP = 0) NO VIOLATIONS ARE ALLOWED. C IF (MSGTYP = 1) THE NUMBER OF VIOLATIONS MUST C BE LESS THAN NVMX . C IF (MSGTYP = 2) 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 NMSUB(6) C THE CHARACTERS OF THE CALLING SUBROUTINES NAME. C CHARACTER*1 NMVAR(8) C THE CHARACTERS OF THE PARAMETERS NAME. C INTEGER NNV C THE NUMBER OF VALUES NOT IN VIOLATION. C INTEGER NNVMN C THE SMALLEST NUMBER OF VALUES NOT IN VIOLATION ALLOWED. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C INTEGER NVMX C THE LARGEST NUMBER OF VIOLATIONS ALLOWED. C REAL Y(N) C THE VECTOR BEING TESTED. C REAL YLB, YUB C THE (INCLUSIVE) RANGE THAT THE VECTOR IS BEING TESTED C AGAINST. C ERROR = .FALSE. C IF (N .LE. 0) RETURN C C TEST WHETHER TESTING IS NECESSRY C IF ((MSGTYP .EQ. 2) .AND. + (Y(1) .LT. YLB) .OR. (Y(1) .GT. YUB)) RETURN C C CHECK FOR VIOLATIONS C NV = 0 DO 10 I = 1, N IF ((Y(I).LT.YLB) .OR. (Y(I).GT.YUB)) NV = NV + 1 10 CONTINUE C IF (NV .LE. NVMX) RETURN C C VIOLATIONS FOUND C ERROR = .TRUE. CALL IPRINT(IPRT) C CALL EHDR(NMSUB, HEAD) C NNV = N - NV NNVMN = N - NVMX C IF (MSGTYP .EQ. 0) + WRITE(IPRT, 1010) (NMVAR(I), I = 1, 6), YLB, YUB, NV IF (MSGTYP .EQ. 1) + WRITE(IPRT, 1020) (NMVAR(I), I = 1, 6), YLB, YUB, + NNVMN, NNV IF (MSGTYP .EQ. 2) + WRITE(IPRT, 1030) (NMVAR(I), I = 1, 6), YLB, YUB C RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + 26H THE VALUES IN THE VECTOR , 6A1, + 26H MUST ALL BE IN THE RANGE , 1PE14.7, 3H TO/ + 1X, 1PE14.7, + 52H, INCLUSIVE. THE NUMBER OF VALUES OUTSIDE THIS RANGE, + 4H IS , I5, '.') 1020 FORMAT(/ + 36H THE NUMBER OF VALUES IN THE VECTOR , 6A1, + 14H IN THE RANGE , 1PE14.7, 3H TO/ + 1X, 1PE14.7, 34H, INCLUSIVE, MUST EQUAL OR EXCEED , I5, '.'/ + ' THE NUMBER OF VALUES IN THIS RANGE IS ', I5, '.') 1030 FORMAT(/ + 34H IF THE FIRST VALUE OF THE VECTOR , 6A1, + 16H IS IN THE RANGE, 1PE14.7, 3H TO/ + 1X, 1PE14.7, + 52H INCLUSIVE, ALL OF THE VALUES MUST BE IN THIS RANGE.) C END *ERVWT SUBROUTINE ERVWT (NMSUB, NMVAR1, WT, N, NNZWMN, HEAD, NNZW, + NZW, MSGTYP, ERROR, NMVAR2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS USER SUPPLIED WEIGHTS TO ASSURE THERE C ARE NO NEGATIVE WEIGHTS, AND THAT THERE ARE SUFFICIENT POSITIVE C WEIGHTS FOR THE TASK. IT RETURNS ERROR SET TO TRUE C IF NO ERRORS ARE FOUND, AND SET TO FALSE OTHERWISE, AND IN C ADDITION, RETURNS THE NUMBER OF NONZERO WEIGHTS AND THE NUMBER C OF ZERO WEIGHTS. 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,N,NNZW,NNZWMN,NZW LOGICAL + ERROR,HEAD C C ARRAY ARGUMENTS REAL + WT(*) CHARACTER + NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1 C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL EHDR,IPRINT 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 ON LIMITS C IMPOSED BY STARPAC. C MSGTYP = 2, THE INPUT VALUE WAS TOO SMALL BASED ON OTHER C INPUT ARGUMENTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. 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 NNZW C THE NUMBER OF NONZERO WEIGHTS. C INTEGER NNZWMN C THE MINIMUM NUMBER OF NONZERO WEIGHTS WHICH IS ACCEPTABLE. C INTEGER NZW C THE NUMBER OF ZERO WEIGHTS. C REAL WT(N) C THE WEIGHT VECTOR. C ERROR = .FALSE. C IF (N.LE.0) RETURN C C CHECK FOR NEGATIVE WEIGHTS AND COUNT NUMBER OF ZERO WEIGHTS. C NZW = 0 DO 10 I = 1, N IF (WT(I) .LT. 0.0E0) GO TO 20 IF (WT(I) .EQ. 0.0E0) NZW = NZW + 1 10 CONTINUE C NNZW = N - NZW IF (NNZW .GE. NNZWMN) RETURN C C INSUFFICIENT NUMBER OF POSITIVE WEIGHTS FOUND C ERROR = .TRUE. C CALL IPRINT(IPRT) C CALL EHDR(NMSUB, HEAD) C WRITE (IPRT, 1010) NNZW IF (MSGTYP.EQ.1) WRITE(IPRT, 1030) (NMVAR1(I), I=1,6), NNZWMN IF (MSGTYP.EQ.2) WRITE(IPRT,1040) (NMVAR1(I),I=1,6), + (NMVAR2(I),I=1,8) C RETURN C C NEGATIVE WEIGHTS FOUND C 20 ERROR = .TRUE. C CALL IPRINT(IPRT) CALL EHDR(NMSUB, HEAD) WRITE(IPRT, 1020) (NMVAR1(I), I = 1, 6) C RETURN C C FORMAT STATEMENTS C 1010 FORMAT(/ + 40H THE NUMBER OF NONZERO WEIGHTS FOUND IS , I6, '.') 1020 FORMAT(/ + 42H NEGATIVE VALUES WERE FOUND IN THE VECTOR , 6A1, '.'/ + 51H ALL WEIGHTS MUST BE GREATER THAN OR EQUAL TO ZERO.) 1030 FORMAT( + 34H THE NUMBER OF NONZERO WEIGHTS IN , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , I6, '.') 1040 FORMAT( + 34H THE NUMBER OF NONZERO WEIGHTS IN , 6A1, + 34H MUST BE GREATER THAN OR EQUAL TO , 8A1, '.') C 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 REAL + ETA INTEGER + IXM,M,N,NETA,NPAR,NROWIN C C ARRAY ARGUMENTS REAL + PAR(NPAR),PARTMP(NPAR),PV(N),XM(IXM,M) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C LOCAL SCALARS REAL + A,B,FAC,FPLRS,J,RSSSM,RSSSMJ,SQRTMP INTEGER + I,K,NROW C C LOCAL ARRAYS REAL + RSS(5) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL SETROW C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10,MAX,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL A, B C PARAMETERS OF THE FIT. C REAL ETA C THE NOISE IN THE MODEL RESULTS. C REAL FAC C A FACTOR USED IN THE COMPUTATIONS. C REAL 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 REAL 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 REAL PAR(NPAR) C MODEL PARAMETERS C REAL PARTMP(NPAR) C MODIFIED MODEL PARAMETERS C REAL PV(N) C PREDICTED VALUES C REAL RSS(5) C THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J. C REAL RSSSM C THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF C PARAMETER VALUES. C REAL RSSSMJ C THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH C SET OF PARAMETER VALUES. C REAL SQRTMP C THE SQUARE ROOT OF MACHINE PRECISION (FPLRS). C REAL XM(IXM,M) C INDEPENDENT VARIABLES C FPLRS = R1MACH(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.0E0 RSSSMJ = 0.0E0 DO 20 I=1,5 J = I-3 DO 10 K=1,NPAR PARTMP(K) = PAR(K)*(1.0E0+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.2E00*RSSSM B = 0.1E00*RSSSMJ FAC = 1.0E0 IF (RSS(3).NE.0.0E0) 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.0E0**(-NETA) RETURN END *EXTEND REAL FUNCTION EXTEND(X, I, N, SYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS FUNCTION RETURNS THE ITH TERM IN THE SERIES X, C EXTENDING IF NECESSARY WITH EVEN OR ODD SYMMETRY ACCORDING C TO THE SIGN OF SYM, WHICH SHOULD BE EITHER PLUS OR MINUS ONE. C (THE VALUE ZERO WILL RESULT IN THE EXTENDED VALUE BEING ZERO.) C THIS ROUTINE IS TAKEN FROM BLOOMFIELDS BOOK, PAGE 179. C C WRITTEN BY - PETER BLOOMFIELD C CODED BY - JANET R. DONALDSON 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 REAL + SYM INTEGER + I,N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS REAL + CON INTEGER + J C J = I CON = 1.0E0 10 IF (J .GE. 1) GO TO 20 J = 2-J CON = CON * SYM 20 IF (J .LE. N) GO TO 30 J = 2*N-J CON = CON * SYM GO TO 10 30 EXTEND = X(J)*CON C RETURN C END *FACTOR SUBROUTINE FACTOR(N, NPF, IPF, IPFEXP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE FACTORS AN INPUT INTEGER N AND RETURNS C THE NUMBER OF PRIME FACTORS IN NPF , THE VALUE OF THE C PRIME FACTORS IN THE VECTOR IPF , AND THE EXPONENT C OF EACH OF THE PRIME FACTORS IN THE VECTOR IPFEXP . C THE ELEMENTS OF IPF ARE STORED IN INCREASING ORDER. C THE LENGTH OF THE VECTORS IS SUFFICIENT TO ACCOMODATE C THE PRIME FACTORS OF AN INTEGER UP TO 2 ** 128 (APPROXIMATELY C 10 ** 40). C C THIS ROUTINE IS ADAPTED FROM THE FACTORING ROUTINE GIVEN C IN ACM ALGORITHM 467 (CACM, 1973, VOL. 16, NO. 11, PAGE 692-694). C C ADAPTED BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - OCTOBER 23, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NPF C C ARRAY ARGUMENTS INTEGER + IPF(50),IPFEXP(50) C C LOCAL SCALARS INTEGER + IDIV,IFCUR,IQUOT,NPART C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IDIV, IFCUR C VARIOUS VARIABLES USED TO FACTOR N . C INTEGER IPF(50), IPFEXP(50) C THE VECTORS OF PRIME FACTORS OF N , AND THEIR EXPONENTS, C RESPECTIVELY. C INTEGER IQUOT C A VARIABLE USED TO FACTOR N . C INTEGER N C THE VALUE TO BE FACTORED. C INTEGER NPART C A VARIABLE USED TO FACTOR N . C INTEGER NPF C THE NUMBER OF FACTORS FOUND IN N . C C DETERMINE THE FACTORS OF N C NPF = 0 IFCUR = 0 NPART = N IDIV = 2 10 IQUOT = NPART/IDIV IF (NPART.NE.IDIV*IQUOT) GO TO 40 IF (IDIV.LE.IFCUR) GO TO 20 NPF = NPF + 1 IPF(NPF) = IDIV IFCUR = IDIV IPFEXP(NPF) = 1 GO TO 30 20 IPFEXP(NPF) = IPFEXP(NPF) + 1 30 NPART = IQUOT GO TO 10 40 IF (IQUOT.LE.IDIV) GO TO 60 IF (IDIV.GE.3) GO TO 50 IDIV = 3 GO TO 10 50 IDIV = IDIV + 2 GO TO 10 60 IF (NPART.LE.1) RETURN IF (NPART.LE.IFCUR) GO TO 70 NPF = NPF + 1 IPF(NPF) = NPART IPFEXP(NPF) = 1 RETURN 70 IPFEXP(NPF) = IPFEXP(NPF) + 1 C RETURN END *FDUMP SUBROUTINE FDUMP C THIS IS A DUMMY ROUTINE TO BE SENT OUT ON C THE PORT SEDIT TAPE C RETURN END *FFTCT SUBROUTINE FFTCT(X, N2, IX) C C LATEST REVISION - 03/15/90 (JRD) C C COSINE TRANSFORM OF N=2*N2 SYMMETRIC DATA POINTS C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IX,N2 C C ARRAY ARGUMENTS REAL + X(IX) C C LOCAL SCALARS REAL + A2,AA,AB,CD,CN,EX,PI,SAVE,SD,SN INTEGER + I,ISN,J,K,M,M1,N1,NK C C EXTERNAL SUBROUTINES EXTERNAL FFT,GETPI,REALTR C C INTRINSIC FUNCTIONS INTRINSIC SIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AA, AB, A2 C REAL CD, CN C REAL EX C INTEGER I, ISN C INTEGER IX C THE DIMENSION OF X. C INTEGER J C INTEGER K C INTEGER M, M1 C INTEGER NK, N1 C INTEGER N2 C THE HALF LENGTH OF THE SYMMETRIC DATA ARRAY. N2 MUST BE EVEN. C REAL PI C THE VALUE OF PI. C REAL SAVE, SD, SN C REAL X(IX) C THE N2+2 VECTOR WITH FIRST HALF OF SYMMETRIC DATA STORED IN C THE FIRST N2+1 LOCATIONS. LOCATION N2+2 USED ONLY FOR C WORKSPACE. THE COSINE TRANSFORM COEFFICIENTS ARE RETURNED C IN THE FIRST N2+1 LOCATIONS OF X. C CALL GETPI(PI) C A2 = 0.0E0 N1 = N2 + 1 DO 10 J=2,N2,2 A2 = A2 + X(J) 10 CONTINUE A2 = 2.0E0*A2 M = N2/2 M1 = M + 1 EX = X(2) X(2) = 0.0E0 IF (N1.LT.4) GO TO 30 DO 20 I=4,N1,2 SAVE = EX - X(I) EX = X(I) X(I) = SAVE 20 CONTINUE 30 X(N2+2) = 0.0E0 ISN = -2 CALL REALTR(X, X(2), M, ISN) CALL FFT(X, X(2), M, M, M, ISN) SD = PI / (2*N2) CD = 2.0E0*SIN(SD)**2 SD = SIN(SD+SD) SN = 0.0E0 CN = 1.0E0 NK = N2 + 2 DO 40 J=2,M1 K = NK - J AA = X(J) + X(K) AB = (X(J)-X(K))*0.5E0 EX = CN - (CD*CN+SD*SN) SN = (SD*CN-CD*SN) + SN CN = 0.5E0/(EX*EX+SN*SN) + 0.5E0 SN = CN*SN CN = CN*EX EX = AB/SN X(J) = (AA+EX)*0.5E0 X(K) = (AA-EX)*0.5E0 40 CONTINUE EX = X(1) X(1) = EX + A2 X(N2+1) = EX - A2 X(N2+2) = 0.0E0 RETURN END *FFT SUBROUTINE FFT(A, B, NTOT, N, NSPAN, ISN) C C LATEST REVISION - 03/15/90 (JRD) C C MULTIVARIATE COMPLEX FOURIER TRANSFORM, COMPUTED IN PLACE C USING MIXED-RADIX FAST FOURIER TRANSFORM ALGORITHM. C BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968 C ARRAYS A AND B ORIGINALLY HOLD THE REAL AND IMAGINARY C COMPONENTS OF THE DATA, AND RETURN THE REAL AND C IMAGINARY COMPONENTS OF THE RESULTING FOURIER COEFFICIENTS. C MULTIVARIATE DATA IS INDEXED ACCORDING TO THE FORTRAN C ARRAY ELEMENT SUCCESSOR FUNCTION, WITHOUT LIMIT C ON THE NUMBER OF IMPLIED MULTIPLE SUBSCRIPTS. C THE SUBROUTINE IS CALLED ONCE FOR EACH VARIATE. C THE CALLS FOR A MULTIVARIATE TRANSFORM MAY BE IN ANY ORDER. C NTOT IS THE TOTAL NUMBER OF COMPLEX DATA VALUES. C N IS THE DIMENSION OF THE CURRENT VARIABLE. C NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES C WHILE INDEXING THE CURRENT VARIABLE. C THE SIGN OF ISN DETERMINES THE SIGN OF THE COMPLEX C EXPONENTIAL, AND THE MAGNITUDE OF ISN IS NORMALLY ONE. C A TRI-VARIATE TRANSFORM WITH A(N1,N2,N3), B(N1,N2,N3) C IS COMPUTED BY C CALL FFT(A,B,N1*N2*N3,N1,N1,1) C CALL FFT(A,B,N1*N2*N3,N2,N1*N2,1) C CALL FFT(A,B,N1*N2*N3,N3,N1*N2*N3,1) C FOR A SINGLE-VARIATE TRANSFORM, C NTOT = N = NSPAN = (NUMBER OF COMPLEX DATA VALUES), F.G. C CALL FFT(A,B,N,N,N,1) C THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX C ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO C GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO C PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY C VALUES, E.G. C CALL FFT(A,A(2),NTOT,N,NSPAN,2) C ARRAYS AT(MAXF), CK(MAXF), BT(MAXF), SK(MAXF), AND NP(MAXP) C ARE USED FOR TEMPORARY STORAGE. IF THE AVAILABEL STORAGE C IS INSUFFICIENT, THE PROGRAM IS TERMINATED BY A STOP. C MAXF MUST BE .GE. THE MAXIMUM PRIME FACTOR OF N. C MAXP MUST BE .GT. THE NUMBER OF PRIME FACTORS OF N. C C NB. THE ABOVE DESCRIPTION OF MAXP APPEARS TO BE INCORRECT. C MAXP SEEMS TO BE THE MAXIMUM SIZE OF THE SQUARE FREE C PORTION K OF N. C C IN ADDITION, IF THE SQUARE-FREE PORTION K OF N HAS TWO OR C MORE PRIME FACTORS, THEN MAXP MUST BE .GE. K-1. C DIMENSION A(1), B(1) C ARRAY STORAGE IN NFAC FOR A MAXIMUM OF 11 FACTORS OF N. C IF N HAS MORE THAN ONE SQUARE-FREE FACTOR, THE PRODUCT OF THE C SQUARE-FREE FACTORS MUST BE .LE. 210 C DIMENSION NFAC(11), NP(209) C ARRAY STORAGE FOR MAXIMUM PRIME FACTOR OF 23 C DIMENSION AT(23), CK(23), BT(23), SK(23) C C C VARIABLE DECLARATIONS C C PARAMETERS INTEGER + MAXF1 PARAMETER (MAXF1=23) INTEGER + MAXP1 PARAMETER (MAXP1=209) C C SCALAR ARGUMENTS INTEGER + ISN,N,NSPAN,NTOT C C ARRAY ARGUMENTS REAL + A(*),B(*) C C LOCAL SCALARS REAL + AA,AJ,AJM,AJP,AK,AKM,AKP,BB,BJ,BJM,BJP,BK,BKM,BKP,C1,C2,C3, + C72,CD,RAD,RADF,S1,S120,S2,S3,S72,SD INTEGER + I,II,INC,IPRT,J,JC,JF,JJ,K,K1,K2,K3,K4,KK,KS,KSPAN,KSPNN, + KT,M,MAXF,MAXP,NN,NT C C LOCAL ARRAYS REAL + AT(MAXF1),BT(MAXF1),CK(MAXF1),SK(MAXF1) INTEGER + NFAC(11),NP(MAXP1) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC ATAN,COS,MOD,SIN,SQRT C C EQUIVALENCES EQUIVALENCE (I,II) C C THE FOLLOWING TWO CONSTANTS SHOULD AGREE WITH THE ARRAY DIMENSIONS. MAXF = MAXF1 MAXP = MAXP1 IF (N.LT.2) RETURN C C INITIALIZE VARIABLES C C1 = 0 C2 = 0 C3 = 0 S1 = 0 S2 = 0 S3 = 0 K1 = 0 K2 = 0 K3 = 0 K4 = 0 C INC = ISN RAD = 8.0E0*ATAN(1.0E0) S72 = RAD/5.0E0 C72 = COS(S72) S72 = SIN(S72) S120 = SQRT(0.75E0) IF (ISN.GE.0) GO TO 10 S72 = -S72 S120 = -S120 RAD = -RAD INC = -INC 10 NT = INC*NTOT KS = INC*NSPAN KSPAN = KS NN = NT - INC JC = KS/N RADF = RAD*JC*0.5E0 I = 0 JF = 0 C DETERMINE THE FACTORS OF N M = 0 K = N GO TO 30 20 M = M + 1 NFAC(M) = 4 K = K/16 30 IF (K-(K/16)*16.EQ.0) GO TO 20 J = 3 JJ = 9 GO TO 50 40 M = M + 1 NFAC(M) = J K = K/JJ 50 IF (MOD(K,JJ).EQ.0) GO TO 40 J = J + 2 JJ = J**2 IF (JJ.LE.K) GO TO 50 IF (K.GT.4) GO TO 60 KT = M NFAC(M+1) = K IF (K.NE.1) M = M + 1 GO TO 100 60 IF (K-(K/4)*4.NE.0) GO TO 70 M = M + 1 NFAC(M) = 2 K = K/4 70 KT = M J = 2 80 IF (MOD(K,J).NE.0) GO TO 90 M = M + 1 NFAC(M) = J K = K/J 90 J = ((J+1)/2)*2 + 1 IF (J.LE.K) GO TO 80 100 IF (KT.EQ.0) GO TO 120 J = KT 110 M = M + 1 NFAC(M) = NFAC(J) J = J - 1 IF (J.NE.0) GO TO 110 C COMPUTE FOURIER TRANSFORM 120 SD = RADF/KSPAN CD = 2.0E0*SIN(SD)**2 SD = SIN(SD+SD) KK = 1 I = I + 1 IF (NFAC(I).NE.2) GO TO 170 C TRANSFORM FOR FACTOR OF 2 (INCLUDING ROTATION FACTOR) KSPAN = KSPAN/2 K1 = KSPAN + 2 130 K2 = KK + KSPAN AK = A(K2) BK = B(K2) A(K2) = A(KK) - AK B(K2) = B(KK) - BK A(KK) = A(KK) + AK B(KK) = B(KK) + BK KK = K2 + KSPAN IF (KK.LE.NN) GO TO 130 KK = KK - NN IF (KK.LE.JC) GO TO 130 IF (KK.GT.KSPAN) GO TO 360 140 C1 = 1.0E0 - CD S1 = SD 150 K2 = KK + KSPAN AK = A(KK) - A(K2) BK = B(KK) - B(K2) A(KK) = A(KK) + A(K2) B(KK) = B(KK) + B(K2) A(K2) = C1*AK - S1*BK B(K2) = S1*AK + C1*BK KK = K2 + KSPAN IF (KK.LT.NT) GO TO 150 K2 = KK - NT C1 = -C1 KK = K1 - K2 IF (KK.GT.K2) GO TO 150 AK = C1 - (CD*C1+SD*S1) S1 = (SD*C1-CD*S1) + S1 C THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR C1 = 0.5E0/(AK**2+S1**2) + 0.5E0 S1 = C1*S1 C1 = C1*AK KK = KK + JC IF (KK.LT.K2) GO TO 150 K1 = K1 + INC + INC KK = (K1-KSPAN)/2 + JC IF (KK.LE.JC+JC) GO TO 140 GO TO 120 C TRANSFORM FOR FACTOR OF 3 (OPTIONAL CODE) 160 K1 = KK + KSPAN K2 = K1 + KSPAN AK = A(KK) BK = B(KK) AJ = A(K1) + A(K2) BJ = B(K1) + B(K2) A(KK) = AK + AJ B(KK) = BK + BJ AK = -0.5E0*AJ + AK BK = -0.5E0*BJ + BK AJ = (A(K1)-A(K2))*S120 BJ = (B(K1)-B(K2))*S120 A(K1) = AK - BJ B(K1) = BK + AJ A(K2) = AK + BJ B(K2) = BK - AJ KK = K2 + KSPAN IF (KK.LT.NN) GO TO 160 KK = KK - NN IF (KK.LE.KSPAN) GO TO 160 GO TO 320 C TRANSFORM FOR FACTOR OF 4 170 IF (NFAC(I).NE.4) GO TO 260 KSPNN = KSPAN KSPAN = KSPAN/4 180 C1 = 1.0E0 S1 = 0 190 K1 = KK + KSPAN K2 = K1 + KSPAN K3 = K2 + KSPAN AKP = A(KK) + A(K2) AKM = A(KK) - A(K2) AJP = A(K1) + A(K3) AJM = A(K1) - A(K3) A(KK) = AKP + AJP AJP = AKP - AJP BKP = B(KK) + B(K2) BKM = B(KK) - B(K2) BJP = B(K1) + B(K3) BJM = B(K1) - B(K3) B(KK) = BKP + BJP BJP = BKP - BJP IF (ISN.LT.0) GO TO 220 AKP = AKM - BJM AKM = AKM + BJM BKP = BKM + AJM BKM = BKM - AJM IF (S1.EQ.0.0E0) GO TO 230 200 A(K1) = AKP*C1 - BKP*S1 B(K1) = AKP*S1 + BKP*C1 A(K2) = AJP*C2 - BJP*S2 B(K2) = AJP*S2 + BJP*C2 A(K3) = AKM*C3 - BKM*S3 B(K3) = AKM*S3 + BKM*C3 KK = K3 + KSPAN IF (KK.LE.NT) GO TO 190 210 C2 = C1 - (CD*C1+SD*S1) S1 = (SD*C1-CD*S1) + S1 C1 = 0.5E0/(C2**2+S1**2) + 0.5E0 S1 = C1*S1 C1 = C1*C2 C2 = C1**2 - S1**2 S2 = 2.0E0*C1*S1 C3 = C2*C1 - S2*S1 S3 = C2*S1 + S2*C1 KK = KK - NT + JC IF (KK.LE.KSPAN) GO TO 190 KK = KK - KSPAN + INC IF (KK.LE.JC) GO TO 180 IF (KSPAN.EQ.JC) GO TO 360 GO TO 120 220 AKP = AKM + BJM AKM = AKM - BJM BKP = BKM - AJM BKM = BKM + AJM IF (S1.NE.0.0E0) GO TO 200 230 A(K1) = AKP B(K1) = BKP A(K2) = AJP B(K2) = BJP A(K3) = AKM B(K3) = BKM KK = K3 + KSPAN IF (KK.LE.NT) GO TO 190 GO TO 210 C TRANSFORM FOR FACTOR OF 5 (OPTIONAL CODE) 240 C2 = C72**2 - S72**2 S2 = 2.0E0*C72*S72 250 K1 = KK + KSPAN K2 = K1 + KSPAN K3 = K2 + KSPAN K4 = K3 + KSPAN AKP = A(K1) + A(K4) AKM = A(K1) - A(K4) BKP = B(K1) + B(K4) BKM = B(K1) - B(K4) AJP = A(K2) + A(K3) AJM = A(K2) - A(K3) BJP = B(K2) + B(K3) BJM = B(K2) - B(K3) AA = A(KK) BB = B(KK) A(KK) = AA + AKP + AJP B(KK) = BB + BKP + BJP AK = AKP*C72 + AJP*C2 + AA BK = BKP*C72 + BJP*C2 + BB AJ = AKM*S72 + AJM*S2 BJ = BKM*S72 + BJM*S2 A(K1) = AK - BJ A(K4) = AK + BJ B(K1) = BK + AJ B(K4) = BK - AJ AK = AKP*C2 + AJP*C72 + AA BK = BKP*C2 + BJP*C72 + BB AJ = AKM*S2 - AJM*S72 BJ = BKM*S2 - BJM*S72 A(K2) = AK - BJ A(K3) = AK + BJ B(K2) = BK + AJ B(K3) = BK - AJ KK = K4 + KSPAN IF (KK.LT.NN) GO TO 250 KK = KK - NN IF (KK.LE.KSPAN) GO TO 250 GO TO 320 C TRANSFORM FOR ODD FACTORS 260 K = NFAC(I) KSPNN = KSPAN KSPAN = KSPAN/K IF (K.EQ.3) GO TO 160 IF (K.EQ.5) GO TO 240 IF (K.EQ.JF) GO TO 280 JF = K S1 = RAD/K C1 = COS(S1) S1 = SIN(S1) IF (JF.GT.MAXF) GO TO 590 CK(JF) = 1.0E0 SK(JF) = 0.0E0 J = 1 270 CK(J) = CK(K)*C1 + SK(K)*S1 SK(J) = CK(K)*S1 - SK(K)*C1 K = K - 1 CK(K) = CK(J) SK(K) = -SK(J) J = J + 1 IF (J.LT.K) GO TO 270 280 K1 = KK K2 = KK + KSPNN AA = A(KK) BB = B(KK) AK = AA BK = BB J = 1 K1 = K1 + KSPAN 290 K2 = K2 - KSPAN J = J + 1 AT(J) = A(K1) + A(K2) AK = AT(J) + AK BT(J) = B(K1) + B(K2) BK = BT(J) + BK J = J + 1 AT(J) = A(K1) - A(K2) BT(J) = B(K1) - B(K2) K1 = K1 + KSPAN IF (K1.LT.K2) GO TO 290 A(KK) = AK B(KK) = BK K1 = KK K2 = KK + KSPNN J = 1 300 K1 = K1 + KSPAN K2 = K2 - KSPAN JJ = J AK = AA BK = BB AJ = 0.0E0 BJ = 0.0E0 K = 1 310 K = K + 1 AK = AT(K)*CK(JJ) + AK BK = BT(K)*CK(JJ) + BK K = K + 1 AJ = AT(K)*SK(JJ) + AJ BJ = BT(K)*SK(JJ) + BJ JJ = JJ + J IF (JJ.GT.JF) JJ = JJ - JF IF (K.LT.JF) GO TO 310 K = JF - J A(K1) = AK - BJ B(K1) = BK + AJ A(K2) = AK + BJ B(K2) = BK - AJ J = J + 1 IF (J.LT.K) GO TO 300 KK = KK + KSPNN IF (KK.LE.NN) GO TO 280 KK = KK - NN IF (KK.LE.KSPAN) GO TO 280 C MULTIPLY BY ROTATION FACTOR (EXCEPT FOR FACTORS OF 2 AND 4) 320 IF (I.EQ.M) GO TO 360 KK = JC + 1 330 C2 = 1.0E0 - CD S1 = SD 340 C1 = C2 S2 = S1 KK = KK + KSPAN 350 AK = A(KK) A(KK) = C2*AK - S2*B(KK) B(KK) = S2*AK + C2*B(KK) KK = KK + KSPNN IF (KK.LE.NT) GO TO 350 AK = S1*S2 S2 = S1*C2 + C1*S2 C2 = C1*C2 - AK KK = KK - NT + KSPAN IF (KK.LE.KSPNN) GO TO 350 C2 = C1 - (CD*C1+SD*S1) S1 = S1 + (SD*C1-CD*S1) C1 = 0.5E0/(C2**2+S1**2) + 0.5E0 S1 = C1*S1 C2 = C1*C2 KK = KK - KSPNN + JC IF (KK.LE.KSPAN) GO TO 340 KK = KK - KSPAN + JC + INC IF (KK.LE.JC+JC) GO TO 330 GO TO 120 C PERMUTE THE RESULTS TO NORMAL ORDER--- DONE IN TWO STAGES C PERMUTATION FOR SQUARE FACTORS OF N 360 NP(1) = KS IF (KT.EQ.0) GO TO 450 K = KT + KT + 1 IF (M.LT.K) K = K - 1 J = 1 NP(K+1) = JC 370 NP(J+1) = NP(J)/NFAC(J) NP(K) = NP(K+1)*NFAC(J) J = J + 1 K = K - 1 IF (J.LT.K) GO TO 370 K3 = NP(K+1) KSPAN = NP(2) KK = JC + 1 K2 = KSPAN + 1 J = 1 IF (N.NE.NTOT) GO TO 410 C PERMUTATION FOR SINGLE-VARIATE TRANSFORM (OPTIONAL CODE) 380 AK = A(KK) A(KK) = A(K2) A(K2) = AK BK = B(KK) B(KK) = B(K2) B(K2) = BK KK = KK + INC K2 = KSPAN + K2 IF (K2.LT.KS) GO TO 380 390 K2 = K2 - NP(J) J = J + 1 K2 = NP(J+1) + K2 IF (K2.GT.NP(J)) GO TO 390 J = 1 400 IF (KK.LT.K2) GO TO 380 KK = KK + INC K2 = KSPAN + K2 IF (K2.LT.KS) GO TO 400 IF (KK.LT.KS) GO TO 390 JC = K3 GO TO 450 C PERMUTATION FOR MULTIVARIATE TRANSFORM 410 K = KK + JC 420 AK = A(KK) A(KK) = A(K2) A(K2) = AK BK = B(KK) B(KK) = B(K2) B(K2) = BK KK = KK + INC K2 = K2 + INC IF (KK.LT.K) GO TO 420 KK = KK + KS - JC K2 = K2 + KS - JC IF (KK.LT.NT) GO TO 410 K2 = K2 - NT + KSPAN KK = KK - NT + JC IF (K2.LT.KS) GO TO 410 430 K2 = K2 - NP(J) J = J + 1 K2 = NP(J+1) + K2 IF (K2.GT.NP(J)) GO TO 430 J = 1 440 IF (KK.LT.K2) GO TO 410 KK = KK + JC K2 = KSPAN + K2 IF (K2.LT.KS) GO TO 440 IF (KK.LT.KS) GO TO 430 JC = K3 450 IF (2*KT+1.GE.M) RETURN KSPNN = NP(KT+1) C PERMUTATION FOR SQUARE-FREE FACTORS OF N J = M - KT NFAC(J+1) = 1 460 NFAC(J) = NFAC(J)*NFAC(J+1) J = J - 1 IF (J.NE.KT) GO TO 460 KT = KT + 1 NN = NFAC(KT) - 1 IF (NN.GT.MAXP) GO TO 590 JJ = 0 J = 0 GO TO 490 470 JJ = JJ - K2 K2 = KK K = K + 1 KK = NFAC(K) 480 JJ = KK + JJ IF (JJ.GE.K2) GO TO 470 NP(J) = JJ 490 K2 = NFAC(KT) K = KT + 1 KK = NFAC(K) J = J + 1 IF (J.LE.NN) GO TO 480 C DETERMINE THE PERMUTATION CYCLES OF LENGTH GREATER THAN 1 J = 0 GO TO 510 500 K = KK KK = NP(K) NP(K) = -KK IF (KK.NE.J) GO TO 500 K3 = KK 510 J = J + 1 KK = NP(J) IF (KK.LT.0) GO TO 510 IF (KK.NE.J) GO TO 500 NP(J) = -J IF (J.NE.NN) GO TO 510 MAXF = INC*MAXF C REORDER A AND B, FOLLOWING THE PERMUTATION CYCLES GO TO 580 520 J = J - 1 IF (NP(J).LT.0) GO TO 520 JJ = JC 530 KSPAN = JJ IF (JJ.GT.MAXF) KSPAN = MAXF JJ = JJ - KSPAN K = NP(J) KK = JC*K + II + JJ K1 = KK + KSPAN K2 = 0 540 K2 = K2 + 1 AT(K2) = A(K1) BT(K2) = B(K1) K1 = K1 - INC IF (K1.NE.KK) GO TO 540 550 K1 = KK + KSPAN K2 = K1 - JC*(K+NP(K)) K = -NP(K) 560 A(K1) = A(K2) B(K1) = B(K2) K1 = K1 - INC K2 = K2 - INC IF (K1.NE.KK) GO TO 560 KK = K2 IF (K.NE.J) GO TO 550 K1 = KK + KSPAN K2 = 0 570 K2 = K2 + 1 A(K1) = AT(K2) B(K1) = BT(K2) K1 = K1 - INC IF (K1.NE.KK) GO TO 570 IF (JJ.NE.0) GO TO 530 IF (J.NE.1) GO TO 520 580 J = K3 + 1 NT = NT - KSPNN II = NT - INC + 1 IF (NT.GE.0) GO TO 520 RETURN C ERROR FINISH, INSUFFICIENT ARRAY STORAGE 590 ISN = 0 CALL IPRINT(IPRT) WRITE(IPRT, 1000) C C NB. THE FOLLOWING STOP SHOULD BE CHANGED TO A RETURN WHEN C THE TIME SERIES ROUTINES ARE MODIFIED FOR STARPAC. C STOP C C FORMAT STATEMENTS C 1000 FORMAT (' ', 17('*')/18H * ERROR MESSAGE */1X, 17('*')// + 45H ARRAY BOUNDS EXCEEDED WITHIN SUBROUTINE FFT./ + 44H PLEASE BRING THIS ERROR TO THE ATTENTION OF/ + 22H JANET R. DONALDSON/ + 16H 303-497-5114/ + 16H FTS 320-5114) END *FFTLEN SUBROUTINE FFTLEN(N, NDIV, NFFT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE SMALLEST VALUE OF NFFT WHICH C EQUALS OR EXCEEDS N + 2, SUCH THAT NFFT - 2 IS DIVISIBLE BY C NDIV AND HAS NO PRIME FACTORS GREATER THAN 23, AND THE C PRODUCT OF THE NON SQUARE PRIME FACTORS OF NFFT - 2 DO NOT C EXCEED 209. THE VALUE OF NFFT THUS MEET THE REQUIREMENTS OF C THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE C USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV C IS CHOSEN. 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 + N,NDIV,NFFT C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,ERR02,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,LNDIV(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,IPRINT,SETESL C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02 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 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 WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C CHARACTER*1 LN(8), LNDIV(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER N C THE NUMBER UPON WHICH NFFT IS BASED. C INTEGER NDIV C A REQUIRED FACTOR OF NFFT - 2. C INTEGER NFFT C THE RETURNED VALUE WHICH MEETS THE ABOVE DESCRIPTION. C CHARACTER*1 NMSUB(6) C THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING C SUBROUTINE. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'F', 'F', 'T', 'L', 'E', 'N'/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6) + / 'N', ' ', ' ', ' ', ' ', ' '/ DATA + LN(7), LN(8) + / ' ', ' '/ DATA + LNDIV(1), LNDIV(2), LNDIV(3), LNDIV(4), LNDIV(5), LNDIV(6) + / 'N', 'D', 'I', 'V', ' ', ' '/ DATA + LNDIV(7), LNDIV(8) + / ' ', ' '/ C C ERROR CHECKING C IERR = 0 HEAD = .TRUE. C CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERR01, LN) C CALL EISGE(NMSUB, LNDIV, NDIV, 1, 1, HEAD, ERR02, LNDIV) C C IF ((.NOT. ERR01) .AND. (.NOT. ERR02)) GO TO 10 C C PRINT PROPER CALL SEQUENCE C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) C RETURN C 10 CONTINUE C CALL SETESL(N, NDIV, NFFT) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 34H CALL FFTLEN (N, NDIV, NFFT)) C END *FFTR SUBROUTINE FFTR (YFFT, N, NFFT, IEXTND, NF, AB, LAB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE FOURIER TRANSFORM OF A SERIES. C C WRITTEN BY - JANET R. DONALDSON 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 + IEXTND,LAB,N,NF,NFFT C C ARRAY ARGUMENTS REAL + AB(*),YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + YEXTND INTEGER + I,IPRT,ISN,N1,NFFT1,NFFT2 LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS CHARACTER + LLAB(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,EISGE,ENFFT,FFT,IPRINT,REALTR C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AB(LAB) C THE VECTOR OF THE NF REAL AND IMAGINARY COMPONENTS OF THE C FOURIER COEFFICIENTS. C LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (TRUE) OR NOT (FALSE). C INTEGER I C AN INDEX VARIABLE. 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 IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER LAB C THE LENGTH OF THE VECTOR AB. C CHARACTER*1 LLAB(8), LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS. C INTEGER N1 C THE VALUE N+1. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C INTEGER NFFT1 C THE EFFECTIVE SERIES LENGTH ACTUALLY USED. C INTEGER NFFT2 C THE EFFECTIVE LENGTH OF THE SERIES STORED AS A COMPLEX C VARIABLE. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C REAL YEXTND C THE VALUE USED TO EXTEND THE SERIES. C REAL YFFT(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'F', 'F', 'T', 'R', ' ', ' '/ DATA + LLAB(1), LLAB(2), LLAB(3), LLAB(4), LLAB(5), LLAB(6) + / 'L', 'A', 'B', ' ', ' ', ' '/ DATA + LLAB(7), LLAB(8) + / ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6) + / 'N', ' ', ' ', ' ', ' ', ' '/ DATA + LN(7), LN(8) + / ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN) IF (ERR01) GO TO 5 C CALL ENFFT(NMSUB, NFFT, 2, N, LAB, NFFT1, HEAD, ERR02, LN) NF = NFFT1/2 C CALL EISGE(NMSUB, LLAB, LAB, NFFT1, 9, HEAD, ERR03, LLAB) C IF (ERR02 .OR. ERR03) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C COPY THE INPUT SERIES TO AB, EXTENDING APPROPRIATELY. C YEXTND = 0.0E0 IF (IEXTND .NE. 0) CALL AMEAN (YFFT, N, YEXTND) C DO 20 I = 1, N AB(I) = YFFT(I) 20 CONTINUE C N1 = N+1 DO 30 I = N1, NFFT1 AB(I) = YEXTND 30 CONTINUE C NFFT2 = (NFFT1-2) / 2 ISN = 2 C CALL FFT (AB(1), AB(2), NFFT2, NFFT2, NFFT2, ISN) CALL REALTR (AB(1), AB(2), NFFT2, ISN) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 53H CALL FFTR (YFFT, N, NFFT, IEXTND, NF, AB, LAB)) 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 REAL + RSS,YSS LOGICAL + EXACT C C LOCAL SCALARS REAL + FPLRS,RSSTST C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH 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 REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RSSTST C THE VALUE FOR TESTING WHETHER THE RESIDUAL SUM OF SQUARES C IS ZERO (TO WITHIN MACHINE PRECISION). C REAL YSS C THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y. C FPLRS = R1MACH(4) C C TEST FOR EXACT FIT C EXACT = .FALSE. RSSTST = RSS IF (YSS.GT.0.0E0) RSSTST = RSSTST / YSS RSSTST = SQRT(RSSTST) IF (RSSTST.LT.10.0E0*FPLRS) EXACT = .TRUE. C RETURN C END *FITPT1 SUBROUTINE FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, + NNZW, WEIGHT, IPTOUT) 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 - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IPTOUT,IXM,M,N,NNZW LOGICAL + WEIGHT C C ARRAY ARGUMENTS REAL + PV(N),RES(N),SDPV(N),SDRES(N),WT(N),XM(IXM,M),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + FPLM INTEGER + I,IPRT,JCOL1,JCOLM,K,NMAX C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,OBSSUM C C INTRINSIC FUNCTIONS INTRINSIC MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IERR C THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE C BEEN DETECTED. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED C IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED. C INTEGER IPTOUT C THE VARIABLE USED TO CONTROL PRINTED OUTPUT. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER JCOLM C THE LAST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED. C INTEGER JCOL1 C THE FIRST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED. C INTEGER K C AN INDEX VARIABLE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NMAX C THE MAXIMUM NUMBER OF ROWS TO BE PRINTED. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(N) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C FPLM = R1MACH(2) C CALL IPRINT(IPRT) C WRITE (IPRT,1100) C IF (WEIGHT) THEN WRITE (IPRT,1010) ELSE WRITE (IPRT,1000) END IF WRITE (IPRT, 1110) C C TEST WHETHER COLUMN VECTOR XM(*, 1) = VECTOR 1.0E0 C DO 10 I=1,N IF (XM(I,1).NE.1.0E0) GO TO 20 10 CONTINUE GO TO 30 C C NOT A UNIT VECTOR C 20 JCOL1 = 1 JCOLM = MIN(M,3) GO TO 40 C C UNIT VECTOR C 30 JCOLM = MIN(M,4) JCOL1 = MIN(2,JCOLM) 40 K = JCOLM - JCOL1 + 1 C NMAX = N IF ((IPTOUT.EQ.1) .AND. (N.GE.45)) NMAX = MIN(N,40) C C PRINT OBSERVATION SUMMARY C CALL OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, + WEIGHT, K, 1, NMAX, JCOL1, JCOLM) C IF (NMAX.GE.N) GO TO 200 C DO 195 I = 1, 3 C GO TO (160, 170, 180), K 160 WRITE (IPRT,1120) GO TO 190 170 WRITE (IPRT,1130) GO TO 190 180 WRITE (IPRT,1140) C 190 CONTINUE WRITE (IPRT, 1150) IF (WEIGHT) WRITE (IPRT, 1160) C 195 CONTINUE C C PRINT LAST LINE OF OUTPUT C CALL OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, + WEIGHT, K, N, N, JCOL1, JCOLM) C 200 CONTINUE C IF ((NNZW.LT.N) .AND. (IERR.EQ.0)) WRITE (IPRT, 1060) IF ((NNZW.LT.N) .AND. (IERR.EQ.4)) WRITE (IPRT, 1070) IF ((NNZW.EQ.N) .AND. (IERR.EQ.4)) WRITE (IPRT, 1080) IF ((IERR.GT.0) .AND. (IERR.NE.4)) WRITE (IPRT, 1090) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/53X, 9HDEPENDENT, 7X, 9HPREDICTED, 5X, 12H STD DEV OF , + 24X, 4HSTD / + 2X, 3HROW, 13X, 16HPREDICTOR VALUES, 20X, 8HVARIABLE, 8X, + 6H VALUE, 8X, 12HPRED VALUE , 6X, 9HRESIDUAL , 8X, 3HRES) 1010 FORMAT (/53X, 9HDEPENDENT, 7X, 9HPREDICTED, 5X, 12H STD DEV OF , + 24X, 4HSTD / + 2X, 3HROW, 13X, 16HPREDICTOR VALUES, 20X, 8HVARIABLE, 8X, + 6H VALUE, 8X, 12HPRED VALUE , 6X, 9HRESIDUAL , 8X, 3HRES, + 4X, 6HWEIGHT) 1060 FORMAT (// 37H * NC - VALUE NOT COMPUTED BECAUSE, + 20H THE WEIGHT IS ZERO.) 1070 FORMAT (// 44H * NC - VALUE NOT COMPUTED BECAUSE EITHER, + 53H THE WEIGHT OR THE STANDARD DEVIATION OF THE RESIDUAL, + 9H IS ZERO.) 1080 FORMAT (// 37H * NC - VALUE NOT COMPUTED BECAUSE, + 48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.) 1090 FORMAT (// 29H * NC - VALUE NOT COMPUTED, + 54H BECAUSE CONVERGENCE PROBLEMS PREVENTED THE COVARIANCE, + 28H MATRIX FROM BEING COMPUTED.) 1100 FORMAT (//31H RESULTS FROM LEAST SQUARES FIT/ 1X, 31('-')) 1110 FORMAT (' ') 1120 FORMAT (4X, '.', 25X, '.') 1130 FORMAT (4X, '.', 3X, 2(14X, '.')) 1140 FORMAT (4X, '.', 10X, '.', 2(14X, '.')) 1150 FORMAT ('+', 49X, 11X, '.', 3(15X, '.'), 11X, '.') 1160 FORMAT ('+', 130X, '.') END *FITPT2 SUBROUTINE FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE, ADAPTED FROM OMNITAB II, PRINTS C THE FOUR STANDARDIZED RESIDUAL PLOTS. 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 REAL + RSS INTEGER + N,NNZW LOGICAL + WEIGHT C C ARRAY ARGUMENTS REAL + PV(N),RES(N),SDRES(N),WT(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ANNZW,DOT,FAC1,FAC2,FPLM,GAMMA,PI,PVDIV,PVMAX,PVMID,PVMIN, + RATIO,ROWDIV,ROWMAX,ROWMID,ROWMIN,W,XDIV,XMAX,XMIN,YLABEL, + YMAX,YMIN INTEGER + I,I1,I2,IDOT,IFIRST,IMID,IPLOT,IPRB,IPRT,IPV,IROW,IX,K,L, + NCOL,NCOLP1,NCOLPL,NCOLT2,NDOT,NROW CHARACTER + IBLANK*1,IMINUS*1,IPLUS*1,ISTAR*1 C C LOCAL ARRAYS CHARACTER + LINE(102)*1 C C EXTERNAL FUNCTIONS REAL + R1MACH LOGICAL + MVCHK EXTERNAL R1MACH,MVCHK C C EXTERNAL SUBROUTINES EXTERNAL GETPI,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC INT,MAX,MIN,MOD C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ANNZW C THE NUMBER OF NONZERO WEIGHTS, USED IN COMPUTING C THE NORMAL PROBABILITY PLOT. C REAL DOT C ... C REAL FAC1, FAC2 C FACTORS USED IN COMPUTING THE NORMAL PROBABILITY PLOT. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL GAMMA C A VALUE USED IN COMPUTING THE NORMAL PROBABILITY PLOT. C INTEGER I C AN INDEX VARIABLE. C CHARACTER*1 IBLANK C THE VALUE OF THE CHARACTER -BLANK-. C INTEGER IERR C THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE C BEEN DETECTED. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED C IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED. C INTEGER IFIRST C THE FIRST ROW OF THE VARIABLES TO BE PLOTTED. C INTEGER IMID C THE MIDPOINT OF THE FIRST PLOT OF THE SECOND SET C CHARACTER*1 IMINUS C THE CHARACTER MINUS. C INTEGER IPLOT C AN INDICATOR VARIABLE DESIGNATING WHETHER THE FIRST OR C SECOND SET OF TWO PLOTS ARE BEING PRINTED. C CHARACTER*1 IPLUS C THE CHARACTER PLUS. C INTEGER IPRB C THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE C PROBABILITY PLOT. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IPV C THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOT C VERSUS PREDICTED VALUE. C INTEGER IROW C THE ROW OF THE VARIABLES BEING PLOTTED. C CHARACTER*1 ISTAR C THE CHARACTER STAR. C INTEGER IX C THE LOCATION IN THE PLOT STRING OF THE SYMBOL FOR THE PLOTS C VERSUS THE INDEPENDENT VARIABLE. C INTEGER I1, I2 C ... C INTEGER K, L C INDEX VARIABLES. C CHARACTER*1 LINE(102) C THE SYMBOLS (BLANKS AND CHARACTERS) FOR A GIVEN LINE C OF THE PLOT. C INTEGER N C THE NUMBER OF OBSERVATIONS IN EACH COLUMN OF DATA. C INTEGER NCOL, NCOLPL, NCOLP1, NCOLT2 C THE NUMBER OF COLUMNS IN THE PLOT, NCOL+L, NCOL+1, C AND NCOL * 2. C INTEGER NDOT C ... C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NROW C THE NUMBER OF COLUMNS IN THE PLOT. C REAL PI C THE VALUE OF PI. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT COEFFICIENT ESTIMATES C REAL PVDIV C THE VALUE OF A DIVISION ALONG THE -PREDICTED VALUE- AXIS. C REAL PVMAX C THE LARGEST VALUE IN THE VECTOR PV. C REAL PVMID C THE MIDPOINT OF THE RANGE OF VALUES IN THE VECTOR PV. C REAL PVMIN C THE SMALLEST VALUE IN THE VECTOR PV. C REAL RATIO C A VALUE USED TO PRODUCE THE NORMAL PROBABILITY PLOT. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL ROWDIV C THE VALUE OF A DIVISION ALONG THE -ROW- AXIS. C REAL ROWMAX C THE LARGEST ROW VALUE. C REAL ROWMID C THE MIDPOINT OF THE RANGE OF THE ROWS PLOTTED. C REAL ROWMIN C THE SMALLEST ROW VALUE PLOTTED. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL W C THE VALUE OF THE WEIGHT FOR THE CURRENT VALUE BEING PLOTTED. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(N) C THE USER SUPPLIED WEIGHTS. C REAL XDIV C THE VALUE OF A DIVISION ALONG THE X AXIS. C REAL XMAX C THE LARGEST VALUE ALONG THE X AXIS. C REAL XMIN C THE SMALLEST VALUE ALONG THE X AXIS. C REAL YLABEL C THE LABEL TO BE PRINTED ALONG THE Y AXIS. C REAL YMAX C THE LARGEST VALUE ALONG THE Y AXIS C REAL YMIN C THE SMALLEST VALUE ALONG THE Y AXIS. C DATA IPLUS/'+'/, IMINUS/'-'/, ISTAR/'*'/, IBLANK/' '/ C CALL IPRINT(IPRT) C FPLM = R1MACH(2) C C CHECK FOR INSUFFICIENT POINTS TO PLOT C IF (IERR.EQ.4) THEN DO 1 I = 1, N IF (SDRES(I).NE.FPLM) GO TO 5 1 CONTINUE WRITE (IPRT, 1090) RETURN END IF 5 CONTINUE C C INITIALIZE VARIABLES FOR PROBABILITY PLOT C CALL GETPI(PI) GAMMA = PI/8.0E0 ANNZW = NNZW FAC1 = 1.0E0 / (ANNZW - 2.0E0*GAMMA + 1.0E0) FAC2 = 10.0E0 C C INITIALIZE THE PLOT SIZE (IN PLOT UNITS) C NROW = 26 NCOL = 51 NCOLP1 = NCOL + 1 NCOLT2 = 2*NCOL IMID = (NCOL-1)/2 C C FIND THE FIRST ROW OF OBSERVATIONS WITH NONZERO WEIGHTS C IFIRST = 1 IF (.NOT. WEIGHT) GO TO 20 DO 10 I=1,N IF (WT(I).LE.0.0E0) GO TO 10 IFIRST = I GO TO 20 10 CONTINUE C C BEGIN COMPUTATIONS FOR FIRST SET OF PLOTS C 20 IPLOT = 1 C C SET X AXIS LIMITS FOR STANDARDIZED RESIDUAL VS ROW PLOT, C AND STANDARDIZED RESIDUALS VS PREDICTED VALUES PLOT. C ROWMIN = IFIRST PVMIN = PV(IFIRST) PVMAX = PV(IFIRST) ROWMAX = IFIRST DO 30 I=IFIRST,N W = 1.0E0 IF (WEIGHT) W = WT(I) IF (W.GT.0.0E0) THEN ROWMAX = I IF (PV(I).LT.PVMIN) PVMIN = PV(I) IF (PV(I).GT.PVMAX) PVMAX = PV(I) END IF 30 CONTINUE C IF (PVMIN.LT.PVMAX) GO TO 35 IF (PVMIN.EQ.0.0E0) GO TO 33 PVMIN = PVMIN - PVMIN/2.0E0 PVMAX = PVMAX + PVMAX/2.0E0 GO TO 35 33 CONTINUE PVMIN = -0.5E0 PVMAX = 0.5E0 35 CONTINUE C ROWMID = (ROWMAX+ROWMIN)/2.0E0 ROWDIV = (ROWMAX-ROWMIN)/(NCOL-1) PVMID = (PVMAX+PVMIN)/2.0E0 PVDIV = (PVMAX-PVMIN)/(NCOL-1) C C PRINT TITLES FOR FIRST PLOTS C WRITE (IPRT,1000) GO TO 90 C C BEGIN COMPUTATIONS FOR SECOND SET OF PLOTS C 40 IPLOT = 2 C C SET AXIS LIMITS FOR THE STANDARDIZED RESIDUALS VS C STANDARDIZED RESIDUALS LAGED BY ONE AND FOR PROBABILITY PLOT C XMIN = -3.75E0 XMAX = 3.75E0 XDIV = (XMAX-XMIN)/(NCOL-1) C C PRINT TITLES FOR SECOND PLOTS C WRITE (IPRT,1050) C C WRITE FIRST LINE OF PLOTS C 90 CONTINUE C C PRINT PLOTS, ONE LINE AT A TIME C YLABEL = 3.75E0 YMAX = FPLM YMIN = 4.05E0 DO 160 K=1,NROW YMIN = YMIN - 0.3E0 IF (-3.70E0.GE.YMIN) YMIN = -FPLM DO 100 L=1,NCOL NCOLPL = L + NCOL LINE(L) = IBLANK LINE(NCOLPL) = IBLANK IF ((K.NE.1) .AND. (K.NE.NROW)) GO TO 100 LINE(L) = IMINUS LINE(NCOLPL) = IMINUS IF ((MOD(L,10).NE.1) .AND. (L.NE.1+NCOL/2)) GO TO 100 LINE(L) = IPLUS LINE(NCOLPL) = IPLUS 100 CONTINUE DO 110 I=1,N IF (WEIGHT) THEN W = WT(I) ELSE W = 1.0E0 END IF IF ((W.NE.0.0E0) .AND. (.NOT.MVCHK(SDRES(I),FPLM))) THEN IF ((SDRES(I).GT.YMIN) .AND. (SDRES(I).LE.YMAX)) THEN IF (IPLOT.EQ.1) THEN C C SET PLOT LINE FOR FIRST SET OF PLOTS C IROW = INT(((I-ROWMIN)/ROWDIV)+1.5E0) LINE(IROW) = ISTAR IPV = INT((PV(I)-PVMIN)/PVDIV+1.5E0) + NCOL LINE(IPV) = ISTAR ELSE C C SET PLOT LINE FOR PROBABILITY PLOT C RATIO = (ANNZW-GAMMA) * FAC1 IPRB = INT(4.91E0*(RATIO**0.14E0- + (1.0E0-RATIO)**0.14E0)*FAC2) + 77 IF (IPRB.LE.NCOL) IPRB = NCOL+1 IF (IPRB.GE.103) IPRB = 102 LINE(IPRB) = ISTAR ANNZW = ANNZW - 1.0E0 IF ((ANNZW.LT.2.0E0) .AND. (NNZW.LE.10)) THEN GAMMA = 1.0E0/3.0E0 END IF END IF END IF END IF 110 CONTINUE C C SET PLOT LINE FOR CORRELATION PLOT C IF (IPLOT.EQ.2) THEN IF (K.LE.N-1) THEN DOT = 0.0E0 IF (WEIGHT) THEN NDOT = 0 DO 120 IDOT = 1, N-K IF ((WT(IDOT).GT.0.0E0) .AND. + (WT(IDOT+K).GT.0.0E0)) THEN NDOT = NDOT + 1 DOT = DOT + RES(IDOT)*RES(IDOT+K) END IF 120 CONTINUE IF (NDOT.GE.1) THEN DOT = DOT * (N-K) / NDOT END IF ELSE DO 130 IDOT = 1, N-K DOT = DOT + RES(IDOT)*RES(IDOT+K) 130 CONTINUE END IF IX = INT(IMID*DOT/RSS) + IMID + 1 I1 = MIN(IX,IMID+1) I2 = MAX(IX,IMID+1) DO 140 IX=I1,I2 LINE(IX) = ISTAR 140 CONTINUE END IF END IF IF (MOD(K,5).EQ.1) THEN IF (IPLOT.EQ.1) THEN WRITE (IPRT,2020) YLABEL, (LINE(L),L=1,NCOL), YLABEL, + (LINE(L),L=NCOLP1,NCOLT2) ELSE WRITE (IPRT,1020) K, (LINE(L),L=1,NCOL), YLABEL, + (LINE(L),L=NCOLP1,NCOLT2) END IF YLABEL = YLABEL - 1.5 ELSE WRITE (IPRT,1030) (LINE(L),L=1,102) END IF YMAX = YMIN 160 CONTINUE C C PRINT BOTTOM LINE OF GRAPHS C IF (IPLOT.EQ.1) THEN C C PRINT X AXIS LABELS FOR FIRST SET OF PLOTS C WRITE (IPRT,1040) ROWMIN, ROWMID, ROWMAX, PVMIN, PVMID, PVMAX GO TO 40 ELSE C C PRINT X AXIS LABELS FOR SECOND SET OF PLOTS C WRITE (IPRT,1070) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/20X, 23H STD RES VS ROW NUMBER , 35X, + 29H STD RES VS PREDICTED VALUES ) C1010 FORMAT (7X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+', C * 10X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+') 1020 FORMAT (1X, I5, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+') 1030 FORMAT (6X, '-', 51A1, '-', 8X, '-', 51A1, '-') 1040 FORMAT (1X, F8.1, 17X, F8.1, 17X, F8.1, 4X, G11.4, 14X, G11.4, + 10X, G11.4) 1050 FORMAT (/13X, 'AUTOCORRELATION FUNCTION OF RESIDUALS', + 23X, 36H NORMAL PROBABILITY PLOT OF STD RES ) C1060 FORMAT ('+', F5.2, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+') 1070 FORMAT (4X, 5H-1.00, 22X, 3H0.0, 21X, 4H1.00, 5X, 4H-2.5, 23X, + 3H0.0, 22X, 3H2.5) C1080 FORMAT ('+', 6X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), C * '+', 10X, 2('+', 9A1), '+', 4A1, 'X', 4A1, 2('+', 9A1), '+') 1090 FORMAT (// 1X, 13('*')/ 1X, 13H* WARNING */ 1X, 13('*')// + 54H THE STANDARDIZED RESIDUAL PLOTS HAVE BEEN SUPPRESSED., + 45H NONE OF THE STANDARDIZED RESIDUALS COULD BE, + 10H COMPUTED,/ + 50H BECAUSE FOR EACH OBSERVATION EITHER THE WEIGHT OR, + 48H THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.) 2020 FORMAT (1X, F5.2, '+', 51A1, '+', 3X, F5.2, '+', 51A1, '+') END *FITSXP SUBROUTINE FITSXP(PAR, PV, SDPV, RES, SDRES, VCV, N, NPAR, IVCV, + RSD) C C LATEST REVISION - 03/15/90 (JRD) C C GENERATES REPORTS FOR LEAST SQUARES EXERCISER RETURNED STORAGE C C WRITTEN BY - LINDA L. MITCHELL 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 REAL + RSD INTEGER + IVCV,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,NPAR) C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LSTVEC,MATPRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C INDEX VARIABLE C INTEGER IPRT C LOGICAL OUTPUT UNIT C INTEGER IVCV C ACTUAL FIRST DIMENSION OF VCV C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NPAR C NUMBER OF PARAMETERS C REAL PAR(NPAR) C THE ESTIMATED PARAMETERS. C REAL PV(N) C PREDICTED VALUES C REAL RES(N) C RESIDUALS C REAL RSD C RESIDUAL STANDARD DEVIATION C REAL SDPV(N) C STANDARD DEVIATION OF PREDICTED VALUES C REAL SDRES(N) C STANDARD DEVIATION OF RESIDUALS C REAL VCV(IVCV,NPAR) C VARIANCE COVARANCE MATRIX C CALL IPRINT(IPRT) WRITE (IPRT,1000) WRITE (IPRT,1002) CALL LSTVEC(NPAR, PAR) WRITE (IPRT,1001) DO 10 I=1,N WRITE (IPRT,1010) PV(I), SDPV(I), RES(I), SDRES(I) 10 CONTINUE WRITE (IPRT,1020) CALL MATPRT(VCV, VCV, NPAR, IPRT, 1, 1, IVCV) WRITE (IPRT,1030) RSD C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(//40H RETURNED RESULTS FROM LEAST SQUARES FIT/ 1X, 39('-')) 1001 FORMAT (//7X, 2HPV, 13X, 4HSDPV, 12X, 3HRES,12X, 5HSDRES) 1002 FORMAT (//20H PARAMETERS FROM FIT) 1010 FORMAT (1X, G14.7, 2X, G14.7, 2X, G14.7, 2X, G14.7) 1020 FORMAT (//27H VARIANCE COVARIANCE MATRIX) 1030 FORMAT (//6H RSD =, G14.7) END *FITXSP SUBROUTINE FITXSP(PAR, PV, SDPV, RES, SDRES, VCV, N, NPAR, IVCV, + NNZW, NPARE, RSD) C C LATEST REVISION - 03/15/90 (JRD) C C GENERATES REPORTS FOR LEAST SQUARES EXERCISER RETURNED STORAGE 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 REAL + RSD INTEGER + IVCV,N,NNZW,NPAR,NPARE C C ARRAY ARGUMENTS REAL + PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,NPAR) C C LOCAL SCALARS INTEGER + I,IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,MATPRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C INDEX VARIABLE C INTEGER IPRT C LOGICAL OUTPUT UNIT C INTEGER IVCV C ACTUAL FIRST DIMENSION OF VCV C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NPAR C NUMBER OF PARAMETERS C INTEGER NPARE C NUMBER OF PARAMETERS ESTIMATED BY ROUTINE. C INTEGER NNZW C NUMBER OF NONZERO WEIGHTS. C REAL PAR(NPAR) C THE ESTIMATED PARAMETERS. C REAL PV(N) C PREDICTED VALUES C REAL RES(N) C RESIDUALS C REAL RSD C RESIDUAL STANDARD DEVIATION C REAL SDPV(N) C STANDARD DEVIATION OF PREDICTED VALUES C REAL SDRES(N) C STANDARDIZED RESIDUALS. C REAL VCV(IVCV,NPAR) C VARIANCE COVARANCE MATRIX C CALL IPRINT(IPRT) WRITE (IPRT,1000) DO 10 I=1,N IF (I.LE.NPAR) THEN WRITE (IPRT,1010) I,PAR(I),RES(I),PV(I),SDPV(I),SDRES(I) ELSE WRITE (IPRT,1070) I,RES(I),PV(I),SDPV(I),SDRES(I) END IF 10 CONTINUE WRITE (IPRT,1030) CALL MATPRT(VCV, VCV, IVCV, IPRT, 1, 1, IVCV) WRITE (IPRT,1060) RSD WRITE (IPRT,1040) NNZW WRITE (IPRT,1050) NPARE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/12X, 3HPAR, 12X, 3HRES, 12X, 2HPV, 13X, 4HSDPV, 12X, + 5HSDRES/) 1010 FORMAT (1X, I5, G14.7, 2X, 4(G14.7, 2X)) 1030 FORMAT (/27H VARIANCE COVARIANCE MATRIX) 1040 FORMAT (8H NNZW = , I5) 1050 FORMAT (9H NPARE = , I5) 1060 FORMAT (/7H RSD = , G14.7) 1070 FORMAT (1X, I5, 16X, 4(G14.7, 2X)) 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 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 *FLTAR SUBROUTINE FLTAR (Y, N, IAR, PHI, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE FILTERS THE INPUT SERIES Y USING THE IAR TERMS C OF THE AUTOREGRESSIVE FILTER PHI, COPYING THE FILTERED SERIES C 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 + IAR,N,NYF C C ARRAY ARGUMENTS REAL + PHI(*),Y(*),YF(*) C C LOCAL SCALARS REAL + TEMP INTEGER + I,I1,J,K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEXING VARIABLE. C INTEGER IAR C THE NUMBER OF FILTER TERMS. C INTEGER I1, J, K C INDEXING VARIABLES. 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 REAL PHI(IAR) C THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED. C REAL TEMP C A TEMPORARY STORAGE LOCATION. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C DO 10 I = 1, N YF(I) = Y(I) 10 CONTINUE C NYF = N - IAR C DO 30 I = 1, NYF K = I + IAR TEMP = YF(K) DO 20 J = 1, IAR K = K - 1 TEMP = TEMP - PHI(J) * YF(K) 20 CONTINUE YF(I) = TEMP 30 CONTINUE C I1 = NYF + 1 C DO 40 I = I1, N YF(I) = 0.0E0 40 CONTINUE RETURN END *FLTARM SUBROUTINE FLTARM (Y, YMISS, N, IAR, PHI, YF, YFMISS, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE FILTERS THE INPUT SERIES Y, WHICH CONTAINS MISSING C DATA, USING THE IAR TERMS OF THE AUTOREGRESSIVE FILTER PHI, C 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 REAL + YFMISS,YMISS INTEGER + IAR,N,NYF C C ARRAY ARGUMENTS REAL + PHI(*),Y(*),YF(*) C C LOCAL SCALARS REAL + FPLM,TEMP INTEGER + I,I1,J,K C C EXTERNAL FUNCTIONS REAL + R1MACH LOGICAL + MVCHK EXTERNAL R1MACH,MVCHK C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IAR C THE NUMBER OF FILTER TERMS. C INTEGER I1, J, K C INDEXING VARIABLES. 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 REAL PHI(IAR) C THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED. C REAL TEMP C A TEMPORARY STORAGE LOCATION. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C REAL YFMISS C THE MISSING VALUE CODE USED IN THE FILTERED SERIES TO C INDICATE THE VALUE COULD NOT BE COMPUTED DUE TO MISSING DATA. C REAL YMISS C THE MISSING VALUE CODE USED IN THE INPUT SERIES TO INDICATE C AN OBSERVATION IS MISSING. C FPLM = R1MACH(2) C YFMISS = FPLM C DO 10 I = 1, N YF(I) = Y(I) 10 CONTINUE C NYF = N - IAR C DO 50 I = 1, NYF TEMP = YFMISS K = I + IAR IF (MVCHK(YF(K), YMISS)) GO TO 40 TEMP = YF(K) DO 30 J = 1, IAR K = K - 1 IF (.NOT. MVCHK(YF(K), YMISS)) GO TO 20 TEMP = YFMISS GO TO 40 20 CONTINUE TEMP = TEMP - PHI(J) * YF(K) 30 CONTINUE 40 YF(I) = TEMP 50 CONTINUE C I1 = NYF + 1 C DO 60 I = I1, N YF(I) = 0.0E0 60 CONTINUE RETURN END *FLTMA SUBROUTINE FLTMA (Y, N, K, HMA, 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 REAL + HMA INTEGER + K,N,NYF C C ARRAY ARGUMENTS REAL + Y(N),YF(N) C C LOCAL SCALARS REAL + SUM INTEGER + I,I1,II,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL HMA C THE VALUE OF EACH OF THE SIMPLE MOVING AVERAGE LINEAR FILTER C COEFFICIENTS. C INTEGER I, II, I1, J C INDEXING VARIABLES. C INTEGER K C THE NUMBER OF FILTER TERMS. 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 REAL SUM C A TEMPORARY LOCATION USED IN COMPUTING THE FILTERED SERIES. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C DO 10 I = 1, N YF(I) = Y(I) 10 CONTINUE C NYF = N - (K - 1) C DO 30 I = 1, NYF II = I - 1 SUM = 0.0E0 DO 20 J = 1, K II = II + 1 SUM = SUM + HMA*YF(II) 20 CONTINUE YF(I) = SUM 30 CONTINUE C I1 = NYF + 1 C DO 40 I = I1, N YF(I) = 0.0E0 40 CONTINUE C RETURN END *FLTMD SUBROUTINE FLTMD (X, Y, N, KMD, SYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE APPLIES ONE MODIFIED DANIEL FILTERS TO A SYMMETRIC C SERIES. THIS ROUTINE IS ADAPTED FROM BLOOMFIELDS ROUTINE MODDAN. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + SYM INTEGER + KMD,N C C ARRAY ARGUMENTS REAL + X(N),Y(N) C C LOCAL SCALARS REAL + CON INTEGER + I,J,KUSED,LIM C C EXTERNAL FUNCTIONS REAL + EXTEND EXTERNAL EXTEND C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CON C A FACTOR USED IN THE COMPUTATIONS. C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER KMD C THE INPUT FILTER LENGTH. C INTEGER KUSED C THE FILTER LENGTH ACTUALLY USED. C INTEGER LIM C A LOOP LIMIT. C INTEGER N C THE NUMBER OF POINTS IN THE SERIES TO BE FILTERED. C REAL SYM C AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SERIES C IS SYMMETRIC (SYM = 1.0E0) OR NOT (SYM = -1.0E0). C REAL X(N) C ON INPUT, THE SERIES TO BE FILTERED. ON OUTPUT, THE C SMOOTHED SERIES. C REAL Y(N) C ON INPUT, A WORK VECTOR. ON OUTPUT, THE INPUT SERIES X. C C DO 10 I = 1, N Y(I) = X(I) 10 CONTINUE C IF (KMD .LE. 0) RETURN C KUSED = KMD + MOD(KMD,2) IF (KUSED .GT. N) KUSED = KUSED - 2 C LIM = KUSED-1 CON = 1.0E0 / (2*KUSED) DO 40 I = 1, N X(I) = Y(I) IF (LIM .EQ. 0) GO TO 30 DO 20 J = 1, LIM X(I) = X(I) + EXTEND(Y, I-J, N, SYM) + + EXTEND(Y, I+J, N, SYM) 20 CONTINUE 30 X(I) = (X(I) + (EXTEND(Y, I-KUSED, N, SYM) + + EXTEND(Y, I+KUSED, N, SYM)) * 0.5E0) * CON 40 CONTINUE C RETURN C 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 REAL + H(K),Y(N),YF(N) C C LOCAL SCALARS REAL + TEMP INTEGER + I,I1,IHM,IHP,IKMID,IM,IP,J,KHALF,KMID C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL TEMP C A TEMPORY STORAGE LOCATION. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. 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.0E0 40 CONTINUE RETURN END *GAMI REAL FUNCTION GAMI (A, X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE THE INCOMPLETE GAMMA FUNCTION DEFINED BY C C GAMI = INTEGRAL FROM T = 0 TO X OF EXP(-T) * T**(A-1.0) . C C GAMI IS EVALUATED FOR POSITIVE VALUES OF A AND NON-NEGATIVE VALUES C OF X. A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR C WHEN GAMI IS VERY LARGE OR VERY SMALL, BECAUSE LOGARITHMIC VARIABLES C ARE USED. C C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,X C C LOCAL SCALARS REAL FACTOR C C EXTERNAL FUNCTIONS REAL ALNGAM,GAMIT,R1MACH EXTERNAL ALNGAM,GAMIT,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC EXP,LOG C IF (A.LE.0.0) CALL XERROR ('GAMI A MUST BE GT ZERO', 25, 1, 2) IF (X.LT.0.0) CALL XERROR ('GAMI X MUST BE GE ZERO', 25, 2, 2) C GAMI = 0.0 IF (X.EQ.0.0) RETURN C C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. C FACTOR = ALNGAM(A) + A*LOG(X) IF (FACTOR.GT.LOG(R1MACH(2))) THEN GAMI = R1MACH(2) ELSE GAMI = EXP(FACTOR) * GAMIT(A,X) END IF C RETURN END *GAMIT REAL FUNCTION GAMIT (A, X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C EVALUATE TRICOMI-S INCOMPLETE GAMMA FUNCTION DEFINED BY C C GAMIT = X**(-A)/GAMMA(A) * INTEGRAL T = 0 TO X OF EXP(-T) * T**(A-1.) C C AND ANALYTIC CONTINUATION FOR A .LE. 0.0. GAMMA(X) IS THE COMPLETE C GAMMA FUNCTION OF X. GAMIT IS EVALUATED FOR ARBITRARY REAL VALUES OF C A AND FOR NON-NEGATIVE VALUES OF X (EVEN THOUGH GAMIT IS DEFINED FOR C X .LT. 0.0), EXCEPT THAT FOR X = 0 AND A .LE. 0.0, GAMIT IS INFINITE, C A FATAL ERROR. C C A SLIGHT DETERIORATION OF 2 OR 3 DIGITS ACCURACY WILL OCCUR WHEN C GAMIT IS VERY LARGE OR VERY SMALL IN ABSOLUTE VALUE, BECAUSE LOG- C ARITHMIC VARIABLES ARE USED. ALSO, IF THE PARAMETER A IS VERY CLOSE C TO A NEGATIVE INTEGER (BUT NOT A NEGATIVE INTEGER), THERE IS A LOSS C OF ACCURACY, WHICH IS REPORTED IF THE RESULT IS LESS THAN HALF C MACHINE PRECISION. C C REF. -- W. GAUTSCHI, AN EVALUATION PROCEDURE FOR INCOMPLETE GAMMA C FUNCTIONS, ACM TRANS. MATH. SOFTWARE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,X C C LOCAL SCALARS REAL AEPS,AINTA,ALGAP1,ALNEPS,ALNG,ALX,BOT,H,SGA,SGNGAM,SQEPS,T C C EXTERNAL FUNCTIONS REAL ALNGAM,GAMR,R1MACH,R9GMIT,R9LGIC,R9LGIT EXTERNAL ALNGAM,GAMR,R1MACH,R9GMIT,R9LGIC,R9LGIT C C EXTERNAL SUBROUTINES EXTERNAL ALGAMS,XERCLR,XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,AINT,EXP,LOG,SIGN,SQRT C DATA ALNEPS, SQEPS, BOT / 3*0.0 / C IF (ALNEPS.NE.0.0) GO TO 10 ALNEPS = -LOG(R1MACH(3)) SQEPS = SQRT(R1MACH(4)) BOT = LOG(R1MACH(1)) C 10 IF (X.LT.0.0) CALL XERROR ('GAMIT X IS NEGATIVE', 21, 2, 2) C IF (X.NE.0.0) ALX = LOG(X) SGA = 1.0 IF (A.NE.0.0) SGA = SIGN (1.0, A) AINTA = AINT (A+0.5*SGA) AEPS = A - AINTA C IF (X.GT.0.0) GO TO 20 GAMIT = 0.0 IF (AINTA.GT.0.0 .OR. AEPS.NE.0.0) GAMIT = GAMR(A+1.0) RETURN C 20 IF (X.GT.1.0) GO TO 40 IF (A.GE.(-0.5) .OR. AEPS.NE.0.0) CALL ALGAMS (A+1.0, ALGAP1, 1 SGNGAM) GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) RETURN C 40 IF (A.LT.X) GO TO 50 T = R9LGIT (A, X, ALNGAM(A+1.0)) IF (T.LT.BOT) CALL XERCLR GAMIT = EXP(T) RETURN C 50 ALNG = R9LGIC (A, X, ALX) C C EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X)) C H = 1.0 IF (AEPS.EQ.0.0 .AND. AINTA.LE.0.0) GO TO 60 CALL ALGAMS (A+1.0, ALGAP1, SGNGAM) T = LOG(ABS(A)) + ALNG - ALGAP1 IF (T.GT.ALNEPS) GO TO 70 IF (T.GT.(-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T) IF (ABS(H).GT.SQEPS) GO TO 60 CALL XERCLR CALL XERROR ('GAMIT RESULT LT HALF PRECISION', 32, 1, 1) C 60 T = -A*ALX + LOG(ABS(H)) IF (T.LT.BOT) CALL XERCLR GAMIT = SIGN (EXP(T), H) RETURN C 70 T = T - A*ALX IF (T.LT.BOT) CALL XERCLR GAMIT = -SGA*SGNGAM*EXP(T) RETURN C END *GAMLIM SUBROUTINE GAMLIM (XMIN, XMAX) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C CALCULATE THE MINIMUM AND MAXIMUM LEGAL BOUNDS FOR X IN GAMMA(X). C XMIN AND XMAX ARE NOT THE ONLY BOUNDS, BUT THEY ARE THE ONLY NON- C TRIVIAL ONES TO CALCULATE. C C OUTPUT ARGUMENTS -- C XMIN MINIMUM LEGAL VALUE OF X IN GAMMA(X). ANY SMALLER VALUE OF C X MIGHT RESULT IN UNDERFLOW. C XMAX MAXIMUM LEGAL VALUE OF X IN GAMMA(X). ANY LARGER VALUE WILL C CAUSE OVERFLOW. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL XMAX,XMIN C C LOCAL SCALARS REAL ALNBIG,ALNSML,XLN,XOLD INTEGER I C C EXTERNAL FUNCTIONS REAL R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,MAX C ALNSML = LOG(R1MACH(1)) XMIN = -ALNSML DO 10 I=1,10 XOLD = XMIN XLN = LOG(XMIN) XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) 1 / (XMIN*XLN + 0.5) IF (ABS(XMIN-XOLD).LT.0.005) GO TO 20 10 CONTINUE CALL XERROR ('GAMLIM UNABLE TO FIND XMIN', 27, 1, 2) C 20 XMIN = -XMIN + 0.01 C ALNBIG = LOG(R1MACH(2)) XMAX = ALNBIG DO 30 I=1,10 XOLD = XMAX XLN = LOG(XMAX) XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) 1 / (XMAX*XLN - 0.5) IF (ABS(XMAX-XOLD).LT.0.005) GO TO 40 30 CONTINUE CALL XERROR ('GAMLIM UNABLE TO FIND XMAX', 27, 2, 2) C 40 XMAX = XMAX - 0.01 XMIN = MAX (XMIN, -XMAX+1.) C RETURN END *GAMMA REAL FUNCTION GAMMA (X) C JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL DXREL,PI,SINPIY,SQ2PIL,XMAX,XMIN,Y INTEGER I,N,NGCS C C LOCAL ARRAYS REAL GCS(23) C C EXTERNAL FUNCTIONS REAL CSEVL,R1MACH,R9LGMC INTEGER INITS EXTERNAL CSEVL,R1MACH,R9LGMC,INITS C C EXTERNAL SUBROUTINES EXTERNAL GAMLIM,XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,AINT,EXP,FLOAT,LOG,SIN,SQRT C C DATA GCS ( 1) / .0085711955 90989331E0/ DATA GCS ( 2) / .0044153813 24841007E0/ DATA GCS ( 3) / .0568504368 1599363E0/ DATA GCS ( 4) /-.0042198353 96418561E0/ DATA GCS ( 5) / .0013268081 81212460E0/ DATA GCS ( 6) /-.0001893024 529798880E0/ DATA GCS ( 7) / .0000360692 532744124E0/ DATA GCS ( 8) /-.0000060567 619044608E0/ DATA GCS ( 9) / .0000010558 295463022E0/ DATA GCS (10) /-.0000001811 967365542E0/ DATA GCS (11) / .0000000311 772496471E0/ DATA GCS (12) /-.0000000053 542196390E0/ DATA GCS (13) / .0000000009 193275519E0/ DATA GCS (14) /-.0000000001 577941280E0/ DATA GCS (15) / .0000000000 270798062E0/ DATA GCS (16) /-.0000000000 046468186E0/ DATA GCS (17) / .0000000000 007973350E0/ DATA GCS (18) /-.0000000000 001368078E0/ DATA GCS (19) / .0000000000 000234731E0/ DATA GCS (20) /-.0000000000 000040274E0/ DATA GCS (21) / .0000000000 000006910E0/ DATA GCS (22) /-.0000000000 000001185E0/ DATA GCS (23) / .0000000000 000000203E0/ C DATA PI /3.14159 26535 89793 24E0/ C SQ2PIL IS LOG (SQRT (2.*PI) ) DATA SQ2PIL /0.91893 85332 04672 74E0/ DATA NGCS, XMIN, XMAX, DXREL /0, 3*0.0 / C IF (NGCS.NE.0) GO TO 10 C C --------------------------------------------------------------------- C INITIALIZE. FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF C TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER C THAN MACHINE PRECISION. C NGCS = INITS (GCS, 23, 0.1*R1MACH(3)) C CALL GAMLIM (XMIN, XMAX) DXREL = SQRT (R1MACH(4)) C C --------------------------------------------------------------------- C FINISH INITIALIZATION. START EVALUATING GAMMA(X). C 10 Y = ABS(X) IF (Y.GT.10.0) GO TO 50 C C COMPUTE GAMMA(X) FOR ABS(X) .LE. 10.0. REDUCE INTERVAL AND C FIND GAMMA(1+Y) FOR 0. .LE. Y .LT. 1. FIRST OF ALL. C N = X IF (X.LT.0.) N = N - 1 Y = X - FLOAT(N) N = N - 1 GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS) IF (N.EQ.0) RETURN C IF (N.GT.0) GO TO 30 C C COMPUTE GAMMA(X) FOR X .LT. 1. C N = -N IF (X.EQ.0.) CALL XERROR ('GAMMA X IS 0', 14, 4, 2) IF (X.LT.0. .AND. X+FLOAT(N-2).EQ.0.) CALL XERROR ( 1 'GAMMA X IS A NEGATIVE INTEGER', 31, 4, 2) IF (X.LT.(-0.5) .AND. ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL 1 XERROR ( 'GAMMA ANSWER LT HALF PRECISION BECAUSE X TOO NEAR N 2EGATIVE INTEGER', 68, 1, 1) C DO 20 I=1,N GAMMA = GAMMA / (X+FLOAT(I-1)) 20 CONTINUE RETURN C C GAMMA(X) FOR X .GE. 2. C 30 DO 40 I=1,N GAMMA = (Y+FLOAT(I))*GAMMA 40 CONTINUE RETURN C C COMPUTE GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). C 50 IF (X.GT.XMAX) CALL XERROR ('GAMMA X SO BIG GAMMA OVERFLOWS', 1 32, 3, 2) C GAMMA = 0. IF (X.LT.XMIN) CALL XERROR ('GAMMA X SO SMALL GAMMA UNDERFLOWS', 1 35, 2, 1) IF (X.LT.XMIN) RETURN C GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) ) IF (X.GT.0.) RETURN C IF (ABS((X-AINT(X-0.5))/X).LT.DXREL) CALL XERROR ( 1 'GAMMA ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 2 61, 1, 1) C SINPIY = SIN (PI*Y) IF (SINPIY.EQ.0.) CALL XERROR ( 1 'GAMMA X IS A NEGATIVE INTEGER', 31, 4, 2) C GAMMA = -PI / (Y*SINPIY*GAMMA) C RETURN END *GAMR REAL FUNCTION GAMR (X) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C THIS ROUTINE, NOT GAMMA(X), SHOULD BE THE FUNDAMENTAL ONE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL ALNGX,SGNGX INTEGER IROLD C C EXTERNAL FUNCTIONS REAL GAMMA EXTERNAL GAMMA C C EXTERNAL SUBROUTINES EXTERNAL ALGAMS,XERCLR,XGETF,XSETF C C INTRINSIC FUNCTIONS INTRINSIC ABS,AINT,EXP C GAMR = 0.0 IF (X.LE.0.0 .AND. AINT(X).EQ.X) RETURN C CALL XGETF (IROLD) CALL XSETF (1) IF (ABS(X).GT.10.0) GO TO 10 GAMR = 1.0/GAMMA(X) CALL XERCLR CALL XSETF (IROLD) RETURN C 10 CALL ALGAMS (X, ALNGX, SGNGX) CALL XERCLR CALL XSETF (IROLD) GAMR = SGNGX * EXP(-ALNGX) RETURN C END *GENI SUBROUTINE GENI(IVECT, N, IINIT, ISTP) C C LATEST REVISION - 03/15/90 (JRD) C C PUT VALUES IINIT STEP ISTP THROUGH IINIT + (N - 1)*ISTP INTO C A VECTOR IVECT OF LENGTH N. NO ERROR CHECKING IS DONE. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING LAB/BOULDER C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IINIT,ISTP,N C C ARRAY ARGUMENTS INTEGER + IVECT(N) C C LOCAL SCALARS INTEGER + I,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C INITIALIZATION VALUE. C INTEGER IINIT, ISTP C INPUT PARAMETERS. THE INITIAL VALUE AND THE INCREMENT USED C IN CREATING THE INITIALIZATION VALUES. C INTEGER IVECT(N) C OUTPUT PARAMETER. THE VECTOR INTO WHICH TO PUT THE VALUES C IINIT, IINIT + ISTP, ..., IINIT + (N - 1)*ISTP. C INTEGER J C LOOP PARAMETER. C INTEGER N C INPUT PARAMETER. THE LENGTH OF IVECT. C I = IINIT DO 10 J=1,N IVECT(J) = I I = I + ISTP 10 CONTINUE RETURN END *GENR SUBROUTINE GENR(RVECT, N, RINIT, RSTP) C C LATEST REVISION - 03/15/90 (JRD) C C PUT VALUES RINIT STEP RSTP THROUGH RINIT + (N - 1)*RSTP INTO C A VECTOR RVECT OF LENGTH N. NO ERROR CHECKING IS DONE. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING LAB/BOULDER C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + RINIT,RSTP INTEGER + N C C ARRAY ARGUMENTS REAL + RVECT(N) C C LOCAL SCALARS REAL + R INTEGER + J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER J C LOOP PARAMETER. C INTEGER N C INPUT PARAMETER. THE LENGTH OF RVECT. C REAL R C INITIALIZATION VALUE. C REAL RINIT, RSTP C INPUT PARAMETERS. THE INITIAL VALUE AND THE INCREMENT USED C IN CREATING THE INITIALIZATION VALUES. C REAL RVECT(N) C OUTPUT PARAMETER. THE VECTOR INTO WHICH TO PUT THE VALUES C RINIT, RINIT + RSTP, ..., RINIT + (N - 1)*RSTP. C R = RINIT DO 10 J=1,N RVECT(J) = R R = R + RSTP 10 CONTINUE RETURN 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 REAL + PI C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL PI C THE VALUE OF PI. C PI = 3.141592653589793238462643383279E0 RETURN END *GFAEST SUBROUTINE GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE GAIN FUNCTION OF AN AUTOREGRESSIVE C LINEAR FILTER USING THE ALGORITHM GIVEN ON PAGES 419 AND 420 C JENKINS AND WATTS. 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 REAL + DELTA INTEGER + IAR,NF C C ARRAY ARGUMENTS REAL + FREQ(NF),GAIN(NF),PHAS(NF),PHI(IAR) C C LOCAL SCALARS REAL + ARG,C,PI,S,V0,V1,V2,Z0,Z1,Z2 INTEGER + I,J,JJ C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC ATAN2,COS,SIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ARG C A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES. C REAL C C A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES. C REAL DELTA C THE SAMPLING INTERVAL OF THE ORIGINAL SERIES. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO C BE ESTIMATED. C REAL GAIN(NF) C THE ARRAY IN WHICH THE GAIN FUNCTION ESTIMATES ARE RETURNED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE NUMBER OF FILTER COEFFICIENTS. C INTEGER J, JJ C INDEX VARIABLES. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES C ARE TO BE COMPUTED. C REAL PHAS(NF) C THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED. C REAL PHI(IAR) C THE VECTOR CONTAINING THE AUTOREGRESSIVE FILTER COEFFICIENTS. C REAL PI C THE VALUE OF PI. C REAL S C A VALUE USED TO COMPUTE THE GAIN FUNCTION ESTIMATES. C REAL V0, V1, V2 C CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES. C REAL Z0, Z1, Z2 C CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES. C CALL GETPI(PI) C C COMPUTE GAIN FUNCTION ESTIMATES AND THEIR CONFIDENCE LIMITS. C DO 30 I = 1, NF IF (FREQ(I).EQ.0.0E0) THEN ARG = 0.0E0 C = 1.0E0 S = 0.0E0 ELSE IF (FREQ(I).EQ.0.25E0) THEN ARG = PI/2.0E0 C = 0.0E0 S = 1.0E0 ELSE IF (FREQ(I).EQ.0.5E0) THEN ARG = PI C = -1.0E0 S = 0.0E0 ELSE ARG = 2.0E0 * PI * FREQ(I) C = COS(ARG) S = SIN(ARG) END IF V0 = 0.0E0 V1 = 0.0E0 Z0 = 0.0E0 Z1 = 0.0E0 C JJ = IAR + 1 C DO 20 J = 1, IAR JJ = JJ -1 C V2 = C * V1 - V0 - PHI(JJ) V0 = V1 V1 = V2 C Z2 = S * Z1 - Z0 - PHI(JJ) Z0 = Z1 Z1 = Z2 20 CONTINUE C V2 = DELTA * (1.0E0 + (V1 * C - V0)) C Z2 = DELTA * Z1 * S C GAIN(I) = SQRT(V2*V2 + Z2*Z2) C PHAS(I) = -0.5E0 * PI IF (Z2.NE.0.0E0 .AND. V2.NE.0.0E0) PHAS(I) = ATAN2(Z2, V2) C 30 CONTINUE C RETURN END *GFARF SUBROUTINE GFARF (PHI, IAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE TO COMPUTE THE GAIN C FUNCTION OF AN AUTOREGRESSIVE FILTER (SHORT CALL). 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 + IAR C C ARRAY ARGUMENTS REAL + PHI(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + DELTA,FMAX,FMIN,YPLTMN,YPLTMX INTEGER + IGFERR,IPRT,NF,NORD,NPRT LOGICAL + ERR01,HEAD,SYM C C LOCAL ARRAYS REAL + FREQ(101),GAIN(101),PHAS(101),XORD(101),YORD(101) INTEGER + ISORT(101) CHARACTER + LIAR(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,GFAEST,GFORD,GFOUT,IPRINT,SETFRQ C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE SAMPLING INTERVAL. C LOGICAL ERR01 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FMAX, FMIN C THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN C FUNCTION IS TO BE ESTIMATED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION C HAS BEEN ESTIMATED. C REAL GAIN(101) C THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE C STORED. 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C CHARACTER*1 LIAR(8) C THE ARRAY CONTAINING THE NAME OF THE VARIABLE IAR. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION C IS TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NORD C THE NUMBER OF VALUES TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C REAL PHAS(101) C THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED. C REAL PHI(IAR) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C LOGICAL SYM C THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION C COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER. C REAL XORD(101) C THE X COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YORD(101) C THE Y COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'G', 'F', 'A', 'R', 'F', ' '/ DATA + LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5), LIAR(6), LIAR(7), + LIAR(8) + / 'I', 'A', 'R', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LIAR, IAR, 1, 1, HEAD, ERR01, LIAR) C IF (.NOT. ERR01) GO TO 10 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET VARIOUS PROGRAM PARAMETERS C SYM = .FALSE. C NF = 101 C FMIN = 0.0E0 FMAX = 0.5E0 C DELTA = 1.0E0 C NPRT = -1 C C SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED C CALL SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, DELTA) C C COMPUTE THE GAIN FUNCTION C CALL GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA) C C SET THE COORDINATES FOR THE PLOT. C CALL GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD, NORD, + YPLTMN, YPLTMX, NPRT, IGFERR) C C PLOT THE RESULTS. C CALL GFOUT (XORD, YORD, NORD, FREQ, PHAS, NF, IAR, SYM, FMIN, + FMAX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 28H CALL GFARF (PHI, IAR)) END *GFARFS SUBROUTINE GFARFS (PHI, IAR, NF, FMIN, FMAX, GAIN, PHAS, FREQ, + NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE TO COMPUTE THE GAIN C FUNCTION OF AN AUTOREGRESSIVE FILTER (SHORT CALL). 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 REAL + FMAX,FMIN INTEGER + IAR,LDSTAK,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),GAIN(*),PHAS(*),PHI(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,FMN,FMX,YPLTMN,YPLTMX INTEGER + IGFERR,IO,IPRT,ISORT,LDSMIN,NALL0,NORD,XORD,YORD LOGICAL + ERR01,ERR02,ERR03,HEAD,SYM C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LIAR(8)*1,LLDS(8)*1,LNF(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,GFAEST,GFORD,GFOUT,IPRINT,LDSCMP,SETFRQ,STKCLR, + STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03 C VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FMAX, FMIN C THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN C FUNCTION IS TO BE ESTIMATED. C REAL FMN, FMX C THE FREQUENCY RANGE ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION C HAS BEEN ESTIMATED. C REAL GAIN(NF) C THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE C STORED. 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 IAR C THE NUMBER OF FILTER COEFFICIENTS. 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 IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER ISORT C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C CHARACTER*1 LIAR(8), LLDS(8), LNF(8) C THE ARRAYS CONTAINING THE NAMES OF CHECKED VARIABLES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION C IS TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NORD C THE NUMBER OF POINTS TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C REAL PHAS(NF) C THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED. C REAL PHI(IAR) C THE VECTOR CONTAINING THE FILTER COEFFICIENTS. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL SYM C THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION C COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER. C INTEGER XORD C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE X COORDINATES FOR THE GAIN FUNCTION PLOT C INTEGER YORD C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE Y COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'G', 'F', 'A', 'R', 'F', 'S'/ DATA + LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5), LIAR(6), + LIAR(7), LIAR(8) /'I', 'A', 'R', ' ', ' ', ' ', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7), + LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8) + / 'N', 'F', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LIAR, IAR, 1, 1, HEAD, ERR01, LIAR) C CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR02, LNF) C IF (ERR02) GO TO 10 C CALL LDSCMP(3*IO, 0, NF, 0, 0, 0, 'S', 2*IO*NF, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS) C IF (ERR01.OR.ERR02.OR.ERR03) GO TO 10 GO TO 20 C 10 IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C IF (NPRT .NE. 0) THEN CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) ELSE NALL0 = 0 END IF C C SET VARIOUS PROGRAM PARAMETERS C SYM = .FALSE. C DELTA = 1.0E0 C C SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED C FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF CALL SETFRQ (FREQ, NF, 2, FMN, FMX, DELTA) C C COMPUTE THE GAIN FUNCTION C CALL GFAEST (PHI, IAR, NF, FREQ, GAIN, PHAS, DELTA) C IF (NPRT .EQ. 0) RETURN C C SET VARIOUS POINTERS FOR THE PLOTTING ARRAYS C XORD = STKGET(NF, 3) YORD = STKGET(NF, 3) C ISORT = STKGET(NF, 2) C IF (IERR .EQ. 1) GO TO 10 C C PLOT THE RESULTS C CALL GFORD (FREQ, GAIN, ISTAK(ISORT), NF, RSTAK(XORD), + RSTAK(YORD), NORD, YPLTMN, YPLTMX, NPRT, IGFERR) CALL GFOUT (RSTAK(XORD), RSTAK(YORD), NORD, FREQ, PHAS, NF, + IAR, SYM, FMN, FMX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB) C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 10 C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL GFARFS (PHI, IAR,'/ + ' + NF, FMIN, FMAX, GAIN, PHAS, FREQ, NPRT,', + ' LDSTAK)') END *GFORD SUBROUTINE GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD, + NORD, YPLTMN, YPLTMX, NPRT, IGFERR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES ORDANENTS FOR THE GAIN FUNCTION PLOTS. 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 REAL + YPLTMN,YPLTMX INTEGER + IGFERR,NF,NORD,NPRT C C ARRAY ARGUMENTS REAL + FREQ(NF),GAIN(NF),XORD(NF),YORD(NF) INTEGER + ISORT(NF) C C LOCAL SCALARS REAL + GAINMN,GAINMX,YMAX INTEGER + I,J C C EXTERNAL SUBROUTINES EXTERNAL SPCCK C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL GAIN(NF) C THE VECTOR IN WHICH THE GAIN FUNCTION IS STORED. C REAL GAINMN, GAINMX C THE MINIMUM AND MAXIMUM GAIN FUNCTION VALUE TO BE PLOTTED. C INTEGER I C AN INDEX VARIABLE C INTEGER IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER ISORT(NF) C THE ARRAY USED FOR SORTING. C INTEGER J C AN INDEXING VARIABLE. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NORD C THE NUMBER OF ORDINATES TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C REAL XORD(NF) C THE X ORDINATES FOR THE SPECTRUM PLOT. C REAL YMAX C THE MAXIMUM ACTUAL SPECTRUM VALUE (IN DECIBELS) TO BE PLOTTED. C REAL YORD(NF) C THE Y ORDINATES FOR THE SPECTRUM PLOTS. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS. C IGFERR = 0 C CALL SPCCK (GAIN, ISORT, NF, GAINMN, GAINMX, NORD, IGFERR) C IF (IGFERR .NE. 0) RETURN C J = 0 C IF (NPRT.GE.1) GO TO 30 C C SET ORDINATES FOR DECIBLE PLOTS C YMAX = 10.0E0 * LOG10(GAINMX) C YPLTMX = 0.0E0 YPLTMN = 10.0E0 * LOG10(GAINMN) - YMAX C DO 10 I = 1, NF IF (GAIN(I) .LT. GAINMN) GO TO 10 J = J + 1 XORD(J) = FREQ(I) YORD(J) = 10.0E0 * LOG10(GAIN(I)) - YMAX 10 CONTINUE C RETURN C 30 CONTINUE C YPLTMX = GAINMX YPLTMN = GAINMN C C SET ORDINATES FOR LOG PLOTS C DO 50 I = 1, NF IF (GAIN(I) .LT. GAINMN) GO TO 50 J = J + 1 XORD(J) = FREQ(I) YORD(J) = GAIN(I) 50 CONTINUE C RETURN END *GFOUT SUBROUTINE GFOUT (XORD, YORD, NORD, FREQ, PHAS, NF, + NTERM, SYM, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT, IGFERR, + NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES THE GAIN FUNCTION PLOTS. 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 REAL + XPLTMN,XPLTMX,YPLTMN,YPLTMX INTEGER + IGFERR,NF,NORD,NPRT,NTERM LOGICAL + SYM C C ARRAY ARGUMENTS REAL + FREQ(NF),PHAS(NF),XORD(NORD),YORD(NORD) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + PI,XMN,XMX,YMN,YMX INTEGER + ILOG,IPRT LOGICAL + ERROR C C LOCAL ARRAYS INTEGER + ISYM(1) C C EXTERNAL SUBROUTINES EXTERNAL GETPI,IPRINT,PPLMT,PPMN,VERSP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C AN ERROR FLAG. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO C BE ESTIMATED. C INTEGER IERR C THE ERROR FLAG. C INTEGER IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER ILOG C THE VARIABLE CONTROLLING THE PLOT AXIS TYPE (LOG OR LINEAR) C INTEGER IPRT C THE UNIT NUMBER FOR THE OUTPUT. C INTEGER ISYM(1) C A DUMMY ARRAY FOR THE CALL TO PPMN. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES C ARE TO BE COMPUTED. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NORD C THE NUMBER OF ORDINATES TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NTERM C THE NUMBER OF TERMS IN THE FILTER FOR WHICH THE GAIN C FUNCTION WAS COMPUTED. C REAL PHAS(NF) C THE ARRAY IN WHICH THE PHASE OF THE FILTER IS RETURNED. C REAL PI C THE VALUE OF PI. C LOGICAL SYM C AN INDICATOR VARIABLE USED TO DETERMINE IF THE FILTER WAS C SYMMETRIC OR NOT. C REAL XMN, XMX C ... C REAL XORD(NORD) C THE X COORDINATES FOR THE GAIN FUNCTION PLOT C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YMN, YMX C ... C REAL YORD(NORD) C THE Y COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH. C CALL IPRINT (IPRT) C CALL VERSP(.TRUE.) C IF (SYM) WRITE (IPRT, 1000) NTERM IF (.NOT. SYM) WRITE (IPRT, 1003) NTERM C IF (IGFERR .EQ. 0) GO TO 5 WRITE (IPRT, 1004) RETURN C 5 CONTINUE C IF (NPRT.GE.1) THEN ILOG = 1 ELSE ILOG = 0 END IF C C DETERMINE THE BOUNDS FOR THE X AND Y AXIS AND COMPLETE THE C ERROR CHECKING C CALL PPLMT (YORD, YORD, XORD, XORD, NORD, 1, NORD, + YPLTMN, YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, + ERROR, NMSUB, .FALSE.) IF (ERROR) THEN IERR = 1 RETURN ELSE CALL PPMN (YORD, YORD, XORD, XORD, NORD, 1, NORD, 0, ISYM, 1, 0, + 0, YMN, YMX, XMN, XMX, .FALSE., ILOG) END IF C IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) GO TO 10 C WRITE (IPRT, 1002) C 10 IF (SYM) RETURN C WRITE (IPRT, 1006) C CALL VERSP(.TRUE.) C C PRINT PHASE PLOT FOR AUTOREGRESSIVE FILTER C CALL GETPI(PI) C WRITE (IPRT, 1005) NTERM C CALL PPLMT (PHAS, PHAS, FREQ, FREQ, NORD, 1, NORD, + -PI, PI, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, + ERROR, NMSUB, .FALSE.) IF (ERROR) THEN IERR = 1 RETURN ELSE CALL PPMN (PHAS, PHAS, FREQ, FREQ, NORD, 1, NORD, 0, ISYM, 1, 0, + 0, YMN, YMX, XMN, XMX, .FALSE., 0) END IF C IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) RETURN C WRITE (IPRT, 1002) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (18H GAIN FUNCTION OF , I3, 15H TERM SYMMETRIC, + 14H LINEAR FILTER) 1002 FORMAT(5H+FREQ/ + 7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X, + 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X, + 6H2.2222, 4X, 2H2.) 1003 FORMAT (18H GAIN FUNCTION OF , I3, 21H TERM AUTOREGRESSIVE,, + 22H OR DIFFERENCE, FILTER) 1004 FORMAT (//51H THE PLOT HAS BEEN SUPRESSED BECAUSE FEWER THAN TWO/ + 45H NON ZERO GAIN FUNCTION VALUES WERE COMPUTED.) 1005 FORMAT (19H PHASE FUNCTION OF , I3, 21H TERM AUTOREGRESSIVE,, + 22H OR DIFFERENCE, FILTER) 1006 FORMAT ('1') END *GFSEST SUBROUTINE GFSEST (H, K, NF, FREQ, GAIN, DELTA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE GAIN FUNCTION OF AN INPUT SYMMETRIC C LINEAR FILTER AT THE FREQUENCIES SPECIFIED IN FREQ USING THE C TRANSFORM ALGORITHM SHOWN ON PAGE 311 OF JENKINS AND WATTS. 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 REAL + DELTA INTEGER + K,NF C C ARRAY ARGUMENTS REAL + FREQ(NF),GAIN(NF),H(K) C C LOCAL SCALARS REAL + C,PI,V0,V1,V2 INTEGER + I,J,KHALF,KMID C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC ABS,COS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL C C A VALUE USED TO COMPUTE THE GAIN FUNCTION. C REAL DELTA C THE SAMPLING INTERVAL OF THE ORIGINAL SERIES. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE C ESTIMATED. C REAL GAIN(NF) C THE ARRAY IN WHICH THE GAIN FUNCTION ESTIMATES ARE RETURNED. C REAL H(K) C THE SYMMETRIC LINEAR FILTER WEIGHTS. C INTEGER I, J C INDEX VARIABLES. C INTEGER K C THE NUMBER OF TERMS IN THE SYMMETRIC LINEAR FILTER. C INTEGER KHALF, KMID C HALF THE FILTER LENGTH, AND THE MIDPOINT OF THE FILTER, C RESPECTIVELY. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE GAIN FUNCTION ESTIMATES C ARE TO BE ESTIMATED. C REAL PI C THE VALUE OF PI. C REAL V0, V1, V2 C CONSTANTS USED FOR COMPUTING THE GAIN FUNCTION ESTIMATES. C CALL GETPI(PI) C C COMPUTE GAIN FUNCTION ESTIMATES AND THEIR CONFIDENCE LIMITS. C KMID = (K+1) / 2 KHALF = KMID - 1 C DO 30 I = 1, NF C = COS(2.0E0 * PI * FREQ(I)) V0 = 0.0E0 V1 = 0.0E0 DO 20 J = 1, KHALF V2 = 2.0E0 * C * V1 - V0 + H(J) V0 = V1 V1 = V2 20 CONTINUE GAIN(I) = ABS(DELTA * (H(KMID) + 2.0E0 * (V1 * C - V0))) 30 CONTINUE RETURN END *GFSLF SUBROUTINE GFSLF (H, K) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE C GAIN FUNCTION OF A SYMMETRIC LINEAR FILTER (SHORT CALL). 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 REAL + H(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + DELTA,FMAX,FMIN,YPLTMN,YPLTMX INTEGER + IGFERR,IPRT,NF,NORD,NPRT LOGICAL + ERR01,ERR02,ERR03,HEAD,SYM C C LOCAL ARRAYS REAL + FREQ(101),GAIN(101),XORD(101),YORD(101) INTEGER + ISORT(101) CHARACTER + LH(8)*1,LK(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERIODD,ERSLF,GFORD,GFOUT,GFSEST,IPRINT,SETFRQ C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE SAMPLING INTERVAL. C LOGICAL ERR01, ERR02, ERR03 C VALUES INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FMAX, FMIN C THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN C FUNCTION IS TO BE ESTIMATED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION C HAS BEEN ESTIMATED. C REAL GAIN(101) C THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE C STORED. C REAL H(K) C THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS. 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 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 IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER ISORT(101) C THE ARRAY USED FOR SORTING. C INTEGER K C THE NUMBER OF FILTER TERMS. C CHARACTER*1 LH(8), LK(8) C THE ARRAY CONTAINING THE NAME OF THE VARIABLES H AND K. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION C IS TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NORD C THE NUMBER OF POINTS TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL SYM C THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION C COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER. C REAL XORD(101) C THE X COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YORD(101) C THE Y COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'G', 'F', 'S', 'L', 'F', ' '/ DATA + LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8) + / 'H', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02) C IF ((.NOT. ERR01) .AND. (.NOT. ERR02)) THEN CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR03) ELSE ERR03 = .FALSE. END IF C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C C SET VARIOUS PROGRAM PARAMETERS C SYM = .TRUE. NF = 101 C FMIN = 0.0E0 FMAX = 0.5E0 C DELTA = 1.0E0 C NPRT = -1 C C SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED C CALL SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, DELTA) C C COMPUTE THE GAIN FUNCTION C CALL GFSEST (H, K, NF, FREQ, GAIN, DELTA) C C PLOT THE RESULTS C CALL GFORD (FREQ, GAIN, ISORT, NF, XORD, YORD, NORD, + YPLTMN, YPLTMX, NPRT, IGFERR) C CALL GFOUT (XORD, YORD, NORD, FREQ, GAIN, NF, K, + SYM, FMIN, FMAX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 24H CALL GFSLF (H, K)) END *GFSLFS SUBROUTINE GFSLFS (H, K, NF, FMIN, FMAX, GAIN, FREQ, NPRT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING THE C GAIN FUNCTION OF A SYMMETRIC LINEAR FILTER (SHORT CALL). 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 REAL + FMAX,FMIN INTEGER + K,LDSTAK,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),GAIN(*),H(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,FMN,FMX,YPLTMN,YPLTMX INTEGER + IGFERR,IO,IPRT,ISORT,LDSMIN,NALL0,NORD,XORD,YORD LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD,SYM C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LH(8)*1,LK(8)*1,LLDS(8)*1,LNF(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERIODD,ERSLF,GFORD,GFOUT,GFSEST,IPRINT,LDSCMP, + SETFRQ,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FMAX, FMIN C THE MINIMUM AND MAXIMUM FREQUENCY FOR WHICH THE GAIN C FUNCTION IS TO BE ESTIMATED. C REAL FMN, FMX C THE FREQUENCY RANGE ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE GAIN FUNCTION C HAS BEEN ESTIMATED. C REAL GAIN(NF) C THE VECTOR IN WHICH THE GAIN FUNCTION ESTIMATES ARE C STORED. C REAL H(K) C THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS. 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 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 IGFERR C AN ERROR FLAG INDICATING WHETHER COMPUTATIONS SEEM C TO HAVE PRODUCED REASONABLE RESULTS. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT. C INTEGER IPRT C THE UNIT NUMBER USED FOR OUTPUT. C INTEGER ISORT C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER K C THE NUMBER OF FILTER TERMS. 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 LH(8), LK(8), LLDS(8), LNF(8) C THE ARRAYS CONTAINING THE NAMES OF THE CHECKED VARIABLES C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE GAIN FUNCTION C IS TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NORD C THE NUMBER OF POINTS TO BE PLOTTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBELS/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL SYM C THE VARIABLE USED TO INDICATE WHETHER THE GAIN FUNCTION C COMPUTED WAS FOR A SYMMETRIC OR AUTOREGRESSIVE FILTER. C INTEGER XORD C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE X COORDINATES FOR THE GAIN FUNCTION PLOT C INTEGER YORD C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE Y COORDINATES FOR THE GAIN FUNCTION PLOT C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'G', 'F', 'S', 'L', 'F', 'S'/ DATA + LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8) + / 'H', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), + LK(7), LK(8) /'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), LLDS(7), + LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8) + / 'N', 'F', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK) CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02) ERR03 = .TRUE. IF ((.NOT. ERR01) .AND. (.NOT. ERR02)) + CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR03) CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR04, LNF) C IF (ERR04) GO TO 10 C CALL LDSCMP(3*IO, 0, IO*NF, 0, 0, 0, 'S', 2*IO*NF, LDSMIN) CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS) C IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR05) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C IF (NPRT .NE. 0) THEN CALL STKSET (LDSTAK, 4) NALL0 = STKST(1) ELSE NALL0 = 0 END IF C C SET VARIOUS PROGRAM PARAMETERS C SYM = .TRUE. C DELTA = 1.0E0 C C SET FREQUENCIES AT WHICH THE GAIN FUNCTION IS TO BE ESTIMATED C FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF CALL SETFRQ (FREQ, NF, 2, FMN, FMX, DELTA) C C COMPUTE THE GAIN FUNCTION C CALL GFSEST (H, K, NF, FREQ, GAIN, DELTA) C IF (NPRT .EQ. 0) RETURN C C SET VARIOUS POINTERS FOR THE PLOTTING ARRAYS C XORD = STKGET(NF, 3) YORD = STKGET(NF, 3) C ISORT = STKGET(NF, 2) C IF (IERR .EQ. 1) GO TO 10 C C PLOT THE RESULTS C CALL GFORD (FREQ, GAIN, ISTAK(ISORT), NF, RSTAK(XORD), + RSTAK(YORD), NORD, YPLTMN, YPLTMX, NPRT, IGFERR) CALL GFOUT (RSTAK(XORD), RSTAK(YORD), NORD, FREQ, GAIN, NF, K, + SYM, FMN, FMX, YPLTMN, YPLTMX, NPRT, IGFERR, NMSUB) C CALL STKCLR(NALL0) C IF (IERR .EQ. 1) GO TO 10 C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL GFSLFS (H, K, NF, FMIN, FMAX, GAIN, FREQ, NPRT,', + ' LDSTAK)') 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 REAL + YMEAN INTEGER + N C C ARRAY ARGUMENTS REAL + 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED SERIES C REAL YMEAN C THE GEOMETRIC MEAN OF THE OBSERVED SERIES C YMEAN = 0.0E0 DO 10 I = 1, N YMEAN = YMEAN + LOG(Y(I)) 10 CONTINUE YMEAN = EXP(YMEAN/N) RETURN 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 REAL + D(P),DIG(P),DIHDI(1),L(1),STEP(P),V(21),W(1) C C LOCAL SCALARS REAL + 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 REAL + DOTPRD,LSVMIN,RMDCON,V2NORM EXTERNAL DOTPRD,LSVMIN,RMDCON,V2NORM C C EXTERNAL SUBROUTINES EXTERNAL LITVMU,LIVMUL,LSQRT C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,MIN,SQRT C C *** PARAMETER DECLARATIONS *** C C INTEGER KA, P C REAL 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 LSQRT - 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 REAL 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 REAL 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, LSQRT, LSVMIN, RMDCON, V2NORM C REAL 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 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.0E0/, EPSFAC/50.0E0/, FOUR/4.0E0/, HALF/0.5E0/, + KAPPA/2.0E0/, NEGONE/-1.0E0/, ONE/1.0E0/, P001/1.0E-3/, + SIX/6.0E0/, THREE/3.0E0/, TWO/2.0E0/, ZERO/0.0E0/ 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.0E0 PHI = 0.0E0 DST = 0.0E0 ALPHAK = 0.0E0 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 LSQRT(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 LSQRT(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 *HIPASS SUBROUTINE HIPASS (Y, N, FC, K, HHP, YF, NYF) 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 REAL + FC INTEGER + K,N,NYF C C ARRAY ARGUMENTS REAL + HHP(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT 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,IPRINT,LPFLT C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS 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.0E0, + 0.5E0, 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 CALL IPRINT (IPRT) WRITE (IPRT, 1000) 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 RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 46H CALL HIPASS (Y, N, FC, K, HHP, YF, NYF)) END *HISTC SUBROUTINE HISTC (Y, N, NCELL, YLB, YUB, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR PRODUCING A HISTOGRAM 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 - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YUB INTEGER + LDSTAK,N,NCELL C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IDP,IFP,IINT,IPRT,LSORT,NALL0,NCELLS,YDIST C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL HSTER,HSTMN,IPRINT,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC ANINT,LOG10,MIN,NINT,REAL C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 IDP C THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION C VECTOR. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C INTEGER NCELL C THE USER SUPPLIED VALUE FOR THE NUMBER OF CELLS IN THE C HISTOGRAM. IF NCELL IS LESS THAN OR EQUAL TO ZERO, THE C NUMBER OF CELLS TO BE USED (NCELLS) WILL BE CALCULATED FROM C THE NUMBER OF OBSERVATIONS. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE HISTOGRAM. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C INTEGER YDIST C THE STARTING LOCATION IN RSTAK OF THE DISTRIBUTION VECTOR. C REAL YLB C THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C REAL YUB C THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'H', 'I', 'S', 'T', 'C', ' '/ C DATA IDP /4/ DATA IINT /2/ C C COMPUTE NCELLS C IF ((NCELL.LE.0) .AND. (N.GE.1)) THEN NCELLS = MIN(NINT(5.5E0+1.5E0*ANINT(LOG10(REAL(N)))),25) ELSE NCELLS = NCELL END IF C C CHECK FOR ERRORS IN THE INPUT PARAMETERS C CALL HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR) IF (IERR.EQ.0) GO TO 10 C C PRINT ERROR MESSAGE. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C SET UP FRAMEWORK AREA. C 10 CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP WORK VECTORS C IFP = 3 C LSORT = STKGET(N,IINT) YDIST = STKGET(NCELLS,IFP) C C COMPUTE THE HISTOGRAM. C CALL HSTMN(Y, N, NCELLS, YLB, YUB, ISTAK(LSORT), RSTAK(YDIST)) C C RETURN THE WORK VECTORS. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL HISTC (Y, N, NCELL, YLB, YUB, LDSTAK)') END *HIST SUBROUTINE HIST(Y, N, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR PRODUCING A HISTOGRAM C (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + YLB,YUB INTEGER + IDP,IFP,IINT,IPRT,LSORT,NALL0,NCELLS,YDIST C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL HSTER,HSTMN,IPRINT,STKCLR,STKSET C C INTRINSIC FUNCTIONS INTRINSIC ANINT,LOG10,MIN,NINT,REAL C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 IDP C THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION C VECTOR. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE HISTOGRAM. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C INTEGER YDIST C THE STARTING LOCATION IN RSTAK OF THE DISTRIBUTION VECTOR. C REAL YLB C THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C REAL YUB C THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'H', 'I', 'S', 'T', ' ', ' '/ C DATA IDP /4/ DATA IINT /2/ DATA YLB/0.0E0/, YUB/0.0E0/ C C COMPUTE NCELLS C IF (N.GE.1) THEN NCELLS = MIN(NINT(5.5E0+1.5E0*ANINT(LOG10(REAL(N)))),25) ELSE NCELLS = 1 END IF C C CHECK FOR ERRORS IN THE INPUT PARAMETERS C CALL HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR) IF (IERR.EQ.0) GO TO 10 C C PRINT ERROR MESSAGE. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C SET UP FRAMEWORK AREA. C 10 CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP WORK VECTORS C IFP = 3 C LSORT = STKGET(N,IINT) YDIST = STKGET(NCELLS,IFP) C C COMPUTE THE HISTOGRAM. C CALL HSTMN(Y, N, NCELLS, YLB, YUB, ISTAK(LSORT), RSTAK(YDIST)) C C RETURN THE WORK VECTORS. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL HIST (Y, N, LDSTAK)') END *HPCOEF SUBROUTINE HPCOEF (HLP, K, HHP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTE THE HI-PASS FILTER CORRESPONDING C TO THE INPUT K TERM LOW PASS 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 INTEGER + K C C ARRAY ARGUMENTS REAL + HHP(*),HLP(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS CHARACTER + LHLP(8)*1,LK(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERIODD,ERSLF,HPFLT,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03 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 REAL HHP(K) C THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS C WILL BE RETURNED. C REAL HLP(K) C THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS C ARE STORED. 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 LHLP(8), LK(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES HLP AND K. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'H', 'P', 'C', 'O', 'E', 'F'/ DATA + LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8) + / 'K', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LHLP(1), LHLP(2), LHLP(3), LHLP(4), LHLP(5), LHLP(6), LHLP(7), + LHLP(8) + / 'H', 'L', 'P', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LK, K, 1, 1, HEAD, ERR01, LK) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR02) C IF (ERR01 .OR. ERR02) GO TO 10 C CALL ERSLF(NMSUB, LHLP, K, HLP, HEAD, ERR03) C IF (ERR03) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C CALL HPFLT (HLP, K, HHP) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 32H CALL HPCOEF (HLP, K, HHP)) 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 REAL + HHP(K),HLP(K) C C LOCAL SCALARS INTEGER + I,KMID C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL HHP(K) C THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS C WILL BE RETURNED. C REAL 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 DO 20 I = 1, K HHP(I) = -HLP(I) 20 CONTINUE C KMID = (K + 1) / 2 C HHP(KMID) = HHP(KMID) + 1.0E0 C RETURN END *HSTER SUBROUTINE HSTER(NMSUB, Y, N, NCELLS, LDSTAK, YLB, YUB, IERR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE CHECKS INPUT PARAMETERS TO THE USER C CALLABLE MEMBERS OF THE HIST FAMILY OF ROUTINES C FOR ERRORS AND REPORTS ANY THAT IT FINDS, BESIDES C RETURNING A FLAG INDICATING THAT ERRORS HAVE BEEN C FOUND. C C WRITTEN BY - JOHN E. KOONTZ, JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YUB INTEGER + IERR,LDSTAK,N,NCELLS C C ARRAY ARGUMENTS REAL + Y(*) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + LDSMIN,NV LOGICAL + HEAD,IER1,IER2,IER3,IER4 C C LOCAL ARRAYS CHARACTER + LLDS(8)*1,LN(8)*1,LONE(8)*1,LY(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERVII,LDSCMP 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 IERR C OUTPUT PARAMETER. A FLAG INDICATING WHETHER OR C NOT AN ERROR HAS BEEN FOUND. 0 = OK, 1 = ERROR. C LOGICAL IER1 C TRUE IF N .LT. 3 C LOGICAL IER2 C TRUE IF LDSTAK .LT. (N + 13)/2. C LOGICAL IER3 C TRUE IF ALL Y VALUES ARE EQUAL. C LOGICAL IER4 C TRUE IF NO DATA WITHIN USER LIMITS C INTEGER LDSMIN C MINIMUM LENGTH OF FRAMEWORK AREA IN DOUBLE C PRECISION ELEMENTS. C INTEGER LDSTAK C INPUT PARAMETER. THE NUMBER OF LOCATIONS PROVIDED IN C THE FRAMEWORK AREA. C CHARACTER*1 LLDS(8), LN(8), LONE(8), LY(8) C THE ARRAY(S) CONTAINING THE NAME(S) FO THE VARIALBE(S) CHECKED C FOR ERRORS C INTEGER N C INPUT PARAMETER. THE NUMBER OF ELEMENTS IN Y. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE HISTOGRAM. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE C INTEGER NV C THE NUMBER OF VALUES OUTSIDE USER SUPPLIED LIMITS. C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF N OBSERVATIONS. C REAL YLB C THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C REAL YUB C THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C C INITIALIZE NAME VECTORS C DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8) /'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), + LONE(7), LONE(8) /'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ DATA LY(1), LY(2), LY(3), LY(4), LY(5), LY(6), + LY(7), LY(8) /'Y', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C C INITIALIZE ERROR FLAGS C IER1 = .FALSE. IER2 = .FALSE. IER3 = .FALSE. IER4 = .FALSE. C IERR = 0 C HEAD = .TRUE. C C CHECK TO SEE THAT THERE IS AT LEAST ONE DATA POINTS. C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, IER1, LONE) C C CHECK FOR SUFFICIENT WORK AREA C CALL LDSCMP(2, 0, N, 0, 0, 0, 'S', NCELLS, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, IER2, LLDS) C C CHECK WHETHER THERE IS ANY DATA BETWEEN USER SUPPLIED LIMITS C IF ((YLB.LT.YUB) .AND. (N.GE.1)) + CALL ERVII (NMSUB, LY, Y, N, YLB, YUB, N-1, HEAD, 1, NV, IER4) C C SEE IF ANY ERRORS WERE FOUND. C IF (IER1 .OR. IER2 .OR. IER3 .OR. IER4) IERR = 1 RETURN END *HSTMN SUBROUTINE HSTMN(Y, N, NCELLS, YLB, YUB, LSORT, YDIST) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN ROUTINE FOR PRODUCING A HISTOGRAM C C ORIGINAL VERSION ADAPTED FROM AN EARLY VERSION OF MINITAB. C C ADAPTED BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YUB INTEGER + N,NCELLS C C ARRAY ARGUMENTS REAL + Y(N),YDIST(NCELLS) INTEGER + LSORT(N) C C LOCAL SCALARS REAL + ALPHA,B1SQRT,B2,CFRACT,CFRCTM,CNTMX,FRACT,P,SCALE,SUM1,SUM2, + SUM3,SUMD2,SUMD3,SUMD4,SUMDA,SUMT1,TEMP,WIDTH,XN,XNN,YINTMP, + YMAX,YMDDSD,YMEAN,YMEANT,YMED,YMIDRG,YMIN,YRANGE,YSD,YVAR INTEGER + I,IFLAG,IPRT,J,MID,NHIGH,NLOW,NOBS,NUM,NUMS CHARACTER + IPLUS*1 C C LOCAL ARRAYS REAL + A(6) C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,SUMBS,SUMDS,SUMSS,SUMTS, + VERSP C C INTRINSIC FUNCTIONS INTRINSIC ABS,INT,MAX,MOD,NINT,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL A(6) C A VECTOR USED FOR PRINTING THE HISTOGRAM SCALE. C REAL ALPHA C THE PERCENTAGE TO BE TRIMMED OFF EACH END OF Y FOR THE C TRIMMED MEANS CALCULATIONS. C REAL B1SQRT C BETA ONE - A MEASURE OF SKEWNESS C REAL B2 C BETA TWO - A MEASURE OF KURTOSIS C REAL CFRACT C THE CUMULATIVE DISTRIBUTION C REAL CFRCTM C THE REVERSE CUMULATIVE DISTRIBUTION C REAL CNTMX C THE SIZE OF THE LARGEST CELL COUNT C REAL FRACT C THE FRACTION OF THE OBSERVATIONS IN A GIVEN CELL C INTEGER I C AN INDEX C INTEGER IFLAG C IF 1, THEN MORE THAN 50 OBS. FELL IN A SINGLE CELL, C AND A SCALED HISTOGRAM WILL BE PROVIDED. C CHARACTER*1 IPLUS C THE CHARACTER + C INTEGER IPRT C THE NUMBER OF THE STANDARD OUTPUT UNIT. C INTEGER J C AN INDEX. C INTEGER LSORT(N) C THE PERMUTATION VECTOR. C INTEGER MID C THE INDEX OF THE (AN) ELEMENT OF Y CLOSEST TO ZERO, WHEN C Y HAS BEEN SORTED. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION. C INTEGER NHIGH C THE INDEX OF THE LARGEST VALUE IN THE SORTED ARRAY C TO BE USED IN THE HISTOGRAM C INTEGER NLOW C THE INDEX OF THE SMALLEST VALUE IN THE SORTED ARRAY C TO BE USED IN THE HISTOGRAM C INTEGER NOBS C THE NUMBER OF OBSERVATIONS ACTUALLY USED IN THE HISTOGRAM C INTEGER NUM C THE CELL COUNT C INTEGER NUMS C THE SCALED CELL COUNT C REAL P C A VARIABLE USED TO DETERMINE THE SCALE C REAL SCALE C THE PRINTED INCREMENT ON THE HISTOGRAM SCALE C REAL SUMDA C THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN. C REAL SUMD2 C THE SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMD3 C THE SUM OF THE CUBES OF THE DIFFERENCES. C REAL SUMD4 C THE SUM OF THE 4TH POWERS OF THE DIFFERENCES. C REAL SUMT1 C THE SUM OF THE ALPHA TRIMMED ARRAY Y. C REAL SUM1, SUM2, SUM3 C VARIOUS SUMS OF THE DATA. C REAL TEMP C A TEMPORARY STORAGE VARIABLE C REAL WIDTH C THE WIDTH OF A CELL C REAL XN C THE FOATING POINT REPRESENTATION OF N C REAL XNN C THE UNROUNDED NUMBER OF PLOTTING POSISTIONS ON A SCALES C HISTOGRAM C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C REAL YDIST(NCELLS) C THE FREQUENCY DISTRIBUTION USED TO CREATE THE HISTOGRAM. C REAL YINTMP C THE MIDPOINT OF THE ITH CELL C REAL YLB C THE LOWER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C REAL YMAX C THE HISTOGRAM UPPER BOUND USED C REAL YMDDSD C THE MEAN ABSOLUTE DEVIATION / THE STANDARD DEVIATION C REAL YMEAN, YMEANT C THE MEAN OF THE OBSERVATIONS USED IN THE HISTOGRAM C REAL YMED C THE MEDIAN OF THE OBSERVATIONS USED IN THE HISTOGRAM C REAL YMIDRG C THE MID RANGE OF THE OBSERVATIONS USED IN THE HISTOGRAM C REAL YMIN C THE HISTOGRAM LOWER BOUND USED. C REAL YRANGE C THE RANGE OF THE OBSERVATIONS USED IN THE HISTOGRAM C REAL YSD C THE STANDARD DEVIATION OF THE OBSERVATIONS USED IN THE C HISTOGRAM. C REAL YUB C THE UPPER BOUND FOR SELECTING DATA FROM Y FOR THE HISTOGRAM. C REAL YVAR C THE VARIANCE OF THE OBSERVATIONS. C DATA IPLUS /'+'/ DATA ALPHA/0.25E0/ C CALL IPRINT(IPRT) C C SORT DATA C CALL GENI(LSORT, N, 1, 1) CALL SRTIR(LSORT, N, Y) C C FIX UPPER AND LOWER BOUNDS. C NLOW = 1 NHIGH = N IF (YLB.EQ.YUB) GO TO 50 C C FIND INDEX OF THE FIRST VALUE OF Y .GE. YLB C DO 20 I=1,N IF (Y(I).LT.YLB) GO TO 20 NLOW = I GO TO 30 20 CONTINUE C C FIND INDEX OF THE LAST VALUE OF Y .LE. YUB C 30 DO 40 I=1,N J = N - I + 1 IF (Y(J).GT.YUB) GO TO 40 NHIGH = J GO TO 50 40 CONTINUE 50 CONTINUE XN = NHIGH-NLOW+1 NOBS = NHIGH - NLOW + 1 C C COMPUTE MEDIAN, EXTREMA, MID-RANGE, RANGE AND FREQUENCY C DISTRIBUTION FOR NCELLS CELLS C CALL STAT1(Y(NLOW), NOBS, YMED, YMIN, YMAX, YMIDRG, YRANGE, + NCELLS, YLB, YUB, YDIST) C IF (YLB.GE.YUB) GO TO 55 C YMIN = YLB YMAX = YUB C 55 CONTINUE C C COMPUTE MEAN, TRIMMED MEAN, STANDARD DEVIATION, C MEAN DEVIATION/STANDARD DEVIATION, BETA ONE, AND BETA TWO C CALL SUMBS(Y, N, NLOW, MID, NHIGH) CALL SUMSS(Y, N, NLOW, MID, NHIGH, SUM1, SUM2, SUM3, YMEAN) CALL SUMTS(Y(NLOW), NOBS, ALPHA, SUMT1, YMEANT) CALL SUMDS(Y, N, NLOW, MID, NHIGH, YMEAN, SUMDA, SUMD2, SUMD3, + SUMD4) C YVAR = 0.0E0 YSD = 0.0E0 B1SQRT = 0.0E0 B2 = 0.0E0 YMDDSD = 0.0E0 C IF ((SUMD2.LE.0.0E0) .OR. (NOBS.LE.1)) GO TO 60 C YVAR = SUMD2/(NOBS-1) YSD = SQRT(YVAR) B1SQRT = ABS((SUMD3/XN)/((SUMD2/XN)**1.5E0)) B2 = (SUMD4/XN)/((SUMD2/XN)**2) YMDDSD = SUMDA/(YSD*NOBS) C 60 CONTINUE C C OUTPUT STATISTICS C CALL VERSP(.TRUE.) WRITE (IPRT,1070) N, Y(NLOW), Y(NHIGH), YMIN, YMAX WRITE (IPRT,1000) + NCELLS, NOBS, YMEANT, Y(NLOW), YSD, Y(NHIGH), YMDDSD, + YMEAN, B1SQRT, YMED, B2 WRITE (IPRT,1010) C C CHECK FOR MORE THAN 50 VALUES IN INTERVAL AND FIND MAX. VALUE. C IFLAG = 0 CNTMX = 0.0E0 DO 80 I=1,NCELLS IF (YDIST(I).GT.CNTMX) CNTMX = YDIST(I) 80 CONTINUE IF (NINT(CNTMX).GT.50) IFLAG = 1 C C DETERMINE SCALE. C IF (IFLAG.EQ.0) THEN SCALE = 1.0E0 ELSE P = CNTMX/XN SCALE = 0.05E0 IF (P.GT.0.25E0) SCALE = 0.1E0 IF (P.GT.0.5E0) SCALE = 0.2E0 END IF C C PRINT COLUMN HEADINGS AND HISTOGRAM SCALE. C IF (IFLAG.EQ.0) WRITE (IPRT,1020) IF (IFLAG.NE.0) WRITE (IPRT,1080) WRITE (IPRT,1090) IF (IFLAG.NE.0) GO TO 100 WRITE (IPRT,1030) (I,I=10,50,10) GO TO 120 100 A(1) = 0.0E0 DO 110 I=1,5 A(I+1) = A(I) + SCALE 110 CONTINUE WRITE (IPRT,1040) (A(I),I=1,6) 120 WRITE (IPRT,1050) CFRACT = 0.0E0 CFRCTM = 1.0E0 TEMP = 0.0E0 WIDTH = (YMAX-YMIN)/NCELLS YINTMP = YMIN YINTMP = YINTMP - WIDTH/2.0E0 DO 150 I=1,NCELLS NUM = INT(YDIST(I)+0.5E0) IF (MOD(NCELLS,2).EQ.1 .AND. I.EQ.NCELLS/2+1 + .AND. YMIN.EQ.(-YMAX)) THEN YINTMP = 0.0E0 ELSE YINTMP = YINTMP + WIDTH END IF FRACT = YDIST(I)/XN CFRACT = CFRACT + FRACT CFRCTM = 1.0E0 - TEMP TEMP = CFRACT IF (NUM.LE.0) THEN WRITE (IPRT,1060) YINTMP, CFRACT, CFRCTM, FRACT, NUM ELSE IF (IFLAG.EQ.0) THEN NUMS = NUM ELSE XNN = FRACT*10.0E0/SCALE NUMS = INT(XNN) NUMS = MAX(1, NUMS + INT(XNN-NUMS+0.5E0)) END IF WRITE (IPRT,1060) YINTMP, CFRACT, CFRCTM, FRACT, + NUM, (IPLUS,J=1,NUMS) END IF 150 CONTINUE C C RESTORE DATA TO ORIGINAL ORDER C CALL SRTRI(Y, N, LSORT) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT(/26H NUMBER OF CELLS = , I15/ + 26H OBSERVATIONS USED = , I15, 11X, + 22H25 PCT TRIMMED MEAN = , 1PE15.8/ + 26H MIN. OBSERVATION USED = , E15.8, 11X, + 22HSTANDARD DEVIATION = , E15.8/ + 26H MAX. OBSERVATION USED = , E15.8, 11X, + 22HMEAN DEV./STD. DEV. = , E15.8/ + 26H MEAN VALUE = , E15.8, 11X, + 22HSQRT(BETA ONE) = , E15.8/ + 26H MEDIAN VALUE = , E15.8, 11X, + 22HBETA TWO = , E15.8) 1010 FORMAT(//44H FOR A NORMAL DISTRIBUTION, THE VALUES (MEAN, + 56H DEVIATION/STANDARD DEVIATION), SQRT(BETA ONE), AND BETA, + 22H TWO ARE APPROXIMATELY/ + ' 0.8, 0.0 AND 3.0, RESPECTIVELY. TO TEST THE ', + 59HNULL HYPOTHESIS OF NORMALITY, SEE TABLES OF CRITICAL VALUES, + 13H PP. 207-208,/ 22H BIOMETRIKA TABLES FOR, + 58H STATISTICIANS, VOL. 1. SEE PP. 67-68 FOR A DISCUSSION OF, + 13H THESE TESTS.) 1020 FORMAT(///5X,39HINTERVAL CUM. 1-CUM. CELL NO.,19X, + 22HNUMBER OF OBSERVATIONS) 1030 FORMAT('+',47X,1H0,8X,5(I2,8X)) 1040 FORMAT('+',46X,6(F4.2,6X)) 1050 FORMAT(4X,42('-'),2X,'+',5(10H---------+)) 1060 FORMAT(3X,1PE13.6,2X,2(0PF5.3,3X),F5.3,1X,I5,4X,50A1) 1070 FORMAT (10H HISTOGRAM// + 26H NUMBER OF OBSERVATIONS = , I15/ + 26H MINIMUM OBSERVATION = , 1PE15.8/ + 26H MAXIMUM OBSERVATION = , E15.8// + 26H HISTOGRAM LOWER BOUND = , E15.8/ + 26H HISTOGRAM UPPER BOUND = , E15.8) 1080 FORMAT(///5X,39HINTERVAL CUM. 1-CUM. CELL NO.,23X, + 13HCELL FRACTION) 1090 FORMAT(5X,41HMID POINT FRACT. FRACT. FRACT. OBS. ) END INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET) C C IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND C SETS IT TO IVALUE IF SET = .TRUE. . C C IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND C SETS IT TO IVALUE IF SET = .TRUE. . C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER ISW,IVALUE LOGICAL SET C C LOCAL SCALARS INTEGER LERROR,LRECOV C C LOCAL ARRAYS INTEGER IPARAM(2) C C EQUIVALENCES EQUIVALENCE (IPARAM(1),LERROR), (IPARAM(2),LRECOV) C C C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. C DATA LERROR/0/ , LRECOV/2/ C I8SAVE=IPARAM(ISW) IF (SET) IPARAM(ISW)=IVALUE C RETURN 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 ICNTI = 0 DO 10 J = 1, NIV IF (IV(J) .EQ. I) ICNTI = ICNTI + 1 10 CONTINUE RETURN 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 SCOPY, 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 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 *IDAMAX INTEGER FUNCTION IDAMAX(N,DX,INCX) C C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX)) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER INCX,N C C ARRAY ARGUMENTS DOUBLE PRECISION DX(*) C C LOCAL SCALARS DOUBLE PRECISION DMAX,XMAG INTEGER I,II,NS C C INTRINSIC FUNCTIONS INTRINSIC DABS C IDAMAX = 0 IF(N.LE.0) RETURN IDAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C DMAX = DABS(DX(1)) NS = N*INCX II = 1 DO 10 I = 1,NS,INCX XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 5 IDAMAX = II DMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 30 IDAMAX = I DMAX = XMAG 30 CONTINUE RETURN END *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 INTEGER + I1MACH EXTERNAL I1MACH 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 *INITDS INTEGER FUNCTION INITDS (DOS, NOS, ETA) C C INITIALIZE THE DOUBLE PRECISION ORTHOGONAL SERIES DOS SO THAT INITDS C IS THE NUMBER OF TERMS NEEDED TO INSURE THE ERROR IS NO LARGER THAN C ETA. ORDINARILY ETA WILL BE CHOSEN TO BE ONE-TENTH MACHINE PRECISION. C C INPUT ARGUMENTS -- C DOS DBLE PREC ARRAY OF NOS COEFFICIENTS IN AN ORTHOGONAL SERIES. C NOS NUMBER OF COEFFICIENTS IN DOS. C ETA REQUESTED ACCURACY OF SERIES. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL ETA INTEGER NOS C C ARRAY ARGUMENTS DOUBLE PRECISION DOS(NOS) C C LOCAL SCALARS REAL ERR INTEGER I,II C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,SNGL C C IF (NOS.LT.1) CALL XERROR ( 1 'INITDS NUMBER OF COEFFICIENTS LT 1', 35, 2, 2) C ERR = 0.0 DO 10 II=1,NOS I = NOS + 1 - II ERR = ERR + ABS(SNGL(DOS(I))) IF (ERR.GT.ETA) GO TO 20 10 CONTINUE C 20 IF (I.EQ.NOS) CALL XERROR ('INITDS ETA MAY BE TOO SMALL', 28, 1 1, 2) INITDS = I C RETURN END *INITS INTEGER FUNCTION INITS (OS, NOS, ETA) C APRIL 1977 VERSION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C INITIALIZE THE ORTHOGONAL SERIES SO THAT INITS IS THE NUMBER OF TERMS C NEEDED TO INSURE THE ERROR IS NO LARGER THAN ETA. ORDINARILY, ETA C WILL BE CHOSEN TO BE ONE-TENTH MACHINE PRECISION. C C INPUT ARGUMENTS -- C OS ARRAY OF NOS COEFFICIENTS IN AN ORTHOGONAL SERIES. C NOS NUMBER OF COEFFICIENTS IN OS. C ETA REQUESTED ACCURACY OF SERIES. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL ETA INTEGER NOS C C ARRAY ARGUMENTS REAL OS(NOS) C C LOCAL SCALARS REAL ERR INTEGER I,II C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS C C IF (NOS.LT.1) CALL XERROR ( 1 'INITS NUMBER OF COEFFICIENTS LT 1', 35, 2, 2) C ERR = 0. DO 10 II=1,NOS I = NOS + 1 - II ERR = ERR + ABS(OS(I)) IF (ERR.GT.ETA) GO TO 20 10 CONTINUE C 20 IF (I.EQ.NOS) CALL XERROR ('INITS ETA MAY BE TOO SMALL', 28, 1 1, 2) INITS = I C RETURN 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 INITIALIZATIONS C DATA IEW /15/, IMAXE /7/, IMAXW /132/, IOCPL /15/ C C COMMENCE BODY OF ROUTINE C IWIDTH = 132 INPERL = (MIN(IWIDTH, IMAXW) - IOCPL)/IEW INPERL = MIN(INPERL, IMAXE) RETURN END *IPGDV SUBROUTINE IPGDV (PER, NF, N, PERI, FREQ, XAXIS, YAXIS, ISYM, + LPCV, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRAL PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 + LPCV,N,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(NF),PER(NF),PERI(NF),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C LOCAL SCALARS INTEGER + ISPCER,NPTS C C EXTERNAL SUBROUTINES EXTERNAL IPGMN,IPGORD,IPGOUT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FREQ(NF) C THE ARRAY IN WHICH THE FREQUENCIES AT WHICH THE PERIODOGRAM C WAS ESTIMATED ARE STORED. C INTEGER ISPCER C AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER N C THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH C THE PERIODOGRAM WAS COMPUTED. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A PAGE PLOT. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE ESTIMATED. C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL PER(NF) C THE RAW PERIODOGRAM. C REAL PERI(NF) C THE ARRAY CONTAINING THE INTEGRATED PERIODOGRAM VALUES. C REAL XAXIS(LPCV), YAXIS(LPCV) C THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS. C C COMPUTE THE INTEGRATED PERIODOGRAM C CALL IPGMN(PER, NF, PERI, ISPCER) C IF (ISPCER .NE. 0) GO TO 10 C IF (NPRT .EQ. 0) RETURN C C SET CO-ORDINATES FOR THE INTEGRATED PERIODOGRAM C CALL IPGORD(PERI, NF, N, FREQ, XAXIS, YAXIS, ISYM, NPTS, LPCV) C C PLOT THE INTEGRATED PERIODOGRAM C 10 CALL IPGOUT (XAXIS, YAXIS, ISYM, NPTS, LPCV, ISPCER) C RETURN C END *IPGM SUBROUTINE IPGM (YFFT, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE INTEGRATED PERIODOGRAM OF A SERIES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + FREQ,IEXTND,IPRT,ISYM,LDSMIN,LPCV,NALL0,NF,NFFT,NPRT, + XAXIS,YAXIS LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LLDS(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CNTR,EISGE,IPGDV,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C INTEGER FREQ C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C CHARACTER*1 LLDS(8), LLYFFT(8), LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE C TIME OF THIS CALL. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A PAGE PLOT. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER XAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED. C INTEGER YAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'I', 'P', 'G', 'M', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) + /'L','Y','F','F','T',' ',' ',' '/ 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, 17, 1, HEAD, ERR01, LN) IF (ERR01) GO TO 5 C C SET LENGTH OF EXTENDED SERIES C CALL SETESL(N, 2, NFFT) NF = NFFT/2 C CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT) C CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NFFT+206, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS) C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = NF + 103 NPRT = 1 C C CENTER THE SERIES C CALL CNTR(YFFT, N, YFFT) IEXTND = 0 C C SUBDIVIDE THE STACK. C ISYM = STKGET(LPCV, 2) XAXIS = STKGET(LPCV, 3) YAXIS = STKGET(LPCV, 3) C FREQ = XAXIS C C COMPUTE THE RAW PERIODOGRAM. C CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, YFFT, LYFFT, RSTAK(YAXIS), + RSTAK(FREQ), LPCV, 0, NMSUB) C C CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED C PERIODOGRAM. C CALL IPGDV (YFFT, NF, N, YFFT, RSTAK(FREQ), RSTAK(XAXIS), + RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL IPGM (YFFT, N, LYFFT, LDSTAK)') END *IPGMN SUBROUTINE IPGMN (PER, NF, PERI, ISPCER) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE INTEGRATED PERIODOGRAM. C C WRITTEN BY - JANET R. DONALDSON 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 + ISPCER,NF C C ARRAY ARGUMENTS REAL + PER(NF),PERI(NF) C C LOCAL SCALARS REAL + SM INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER ISPCER C AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C COMPUTED. C REAL PER(NF) C THE RAW PERIODOGRAM. C REAL PERI(NF) C THE ARRAY WHICH CONTAINS THE INTEGRATED PERIODOGRAM. C REAL SM C A VALUE USED TO COMPUTE THE INTEGRATED PERIODOGRAM ESTIMATES. C C SM = 0.0E0 C DO 30 I = 1, NF SM = SM + PER(I) PERI(I) = SM 30 CONTINUE C ISPCER = 1 IF (SM .EQ. 0.0E0) RETURN C ISPCER = 0 C DO 40 I = 1, NF PERI(I) = PERI(I)/SM 40 CONTINUE C RETURN END *IPGMP SUBROUTINE IPGMP (PER, FREQ, NF, N, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE INTEGRATED PERIODOGRAM OF A SERIES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,N,NF C C ARRAY ARGUMENTS REAL + FREQ(*),PER(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,ISYM,LDSMIN,LPCV,NALL0,NPRT,PERI,XAXIS,YAXIS LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LLDS(8)*1,LN(8)*1,LNF(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,IPGDV,IPRINT,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FREQ(NF) C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER ISYM C ... C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C CHARACTER*1 LLDS(8), LN(8), LNF(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER LPCV C ... C INTEGER N C THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH C THE PERIODOGRAM WAS COMPUTED. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE C TIME OF THIS CALL. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A PAGE PLOT. C REAL PER(NF) C THE RAW PERIODOGRAM. C INTEGER PERI C THE STARTING LOCATION IN THE STACK FOR C THE VECTOR CONTAINING THE INTEGRATED PERIODOGRAM. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER XAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED. C INTEGER YAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'I', 'P', 'G', 'M', 'P', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + /'N',' ',' ',' ',' ',' ',' ',' '/ DATA + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8) + /'N','F',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN) C CALL EISGE(NMSUB, LNF, NF, (N+2)/2, 1, HEAD, ERR02, LNF) C IF (ERR01) GO TO 5 C CALL LDSCMP(4, 0, NF+103, 0, 0, 0, 'S', 3*NF+206, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS) C IF (ERR02 .OR. ERR03) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = NF + 103 NPRT = 1 C C SUBDIVIDE THE STACK. C ISYM = STKGET(LPCV, 2) PERI = STKGET(NF, 3) XAXIS = STKGET(LPCV, 3) YAXIS = STKGET(LPCV, 3) C C CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED C PERIODOGRAM. C CALL IPGDV (PER, NF, N, RSTAK(PERI), FREQ, RSTAK(XAXIS), + RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL IPGMP (PER, FREQ, NF, N, LDSTAK)') END *IPGMPS SUBROUTINE IPGMPS (PER, FREQ, NF, N, LDSTAK, PERI, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE INTEGRATED PERIODOGRAM OF A SERIES (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),PER(*),PERI(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,ISYM,LDSMIN,LPCV,NALL0,XAXIS,YAXIS LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LLDS(8)*1,LN(8)*1,LNF(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,IPGDV,IPRINT,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FREQ(NF) C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C CHARACTER*1 LLDS(8), LN(8), LNF(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER N C THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH C THE PERIODOGRAM WAS COMPUTED. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE C TIME OF THIS CALL. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C COMPUTED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A PAGE PLOT. C REAL PER(NF) C THE INTEGRATED PERIODOGRAM. C REAL PERI(NF) C THE VECTOR IN WHICH THE INTEGRATED PERIODOGRAM IS STORED. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER XAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED. C INTEGER YAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'I', 'P', 'G', 'M', 'P', 'S'/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + /'N',' ',' ',' ',' ',' ',' ',' '/ DATA + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), LNF(8) + /'N','F',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR01, LN) C CALL EISGE(NMSUB, LNF, NF, (N+2)/2, 1, HEAD, ERR02, LNF) C IF (ERR01) GO TO 5 C IF (NPRT .EQ. 0) THEN LDSMIN = 0 ELSE CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NF+206, LDSMIN) END IF C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS) C IF (ERR02 .OR. ERR03) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = NF + 103 C C SUBDIVIDE THE STACK. C IF (NPRT .EQ. 0) THEN ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE ISYM = STKGET(LPCV, 2) XAXIS = STKGET(LPCV, 3) YAXIS = STKGET(LPCV, 3) END IF C C CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED C PERIODOGRAM. C CALL IPGDV (PER, NF, N, PERI, FREQ, RSTAK(XAXIS), + RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL IPGMPS (PER, FREQ, NF, N, LDSTAK, PERI, NPRT)') END *IPGMS SUBROUTINE IPGMS (YFFT, N, LYFFT, LDSTAK, NF, PERI, LPERI, FREQ, + LFREQ, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE INTEGRATED PERIODOGRAM OF A SERIES (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,LFREQ,LPERI,LYFFT,N,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),PERI(*),YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IEXTND,IPRT,ISYM,LDSMIN,LPCV,NALL0,NFFT,XAXIS,YAXIS LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) CHARACTER + LLDS(8)*1,LLFREQ(8)*1,LLPERI(8)*1,LLYFFT(8)*1,LN(8)*1, + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CNTR,EISGE,IPGDV,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL FREQ(LFREQ) C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LFREQ C THE LENGTH OF THE VECTOR FREQ. C CHARACTER*1 LLDS(8), LLFREQ(8), LLPERI(8), LLYFFT(8), LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPERI C THE LENGTH OF THE VECTOR PERI. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE C TIME OF THIS CALL. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A PAGE PLOT. C REAL PERI(LPERI) C THE VECTOR IN WHICH THE INTEGRATED PERIODOGRAM IS STORED. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER XAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE X AXIS VALUES TO BE PLOTTED ARE STORED. C INTEGER YAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'I', 'P', 'G', 'M', 'S', ' '/ DATA + LLFREQ(1), LLFREQ(2), LLFREQ(3), LLFREQ(4), LLFREQ(5), + LLFREQ(6), LLFREQ(7), LLFREQ(8) + /'L','F','R','E','Q',' ',' ',' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LLPERI(1), LLPERI(2), LLPERI(3), LLPERI(4), LLPERI(5), + LLPERI(6), LLPERI(7), LLPERI(8) + /'L','P','E','R','I',' ',' ',' '/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) + /'L','Y','F','F','T',' ',' ',' '/ 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, 17, 1, HEAD, ERR01, LN) IF (ERR01) GO TO 5 C C SET LENGTH OF EXTENDED SERIES C CALL SETESL(N, 2, NFFT) NF = NFFT/2 C CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT) C CALL EISGE(NMSUB, LLPERI, LPERI, NF, 9, HEAD, ERR03, LLPERI) C CALL EISGE(NMSUB, LLFREQ, LFREQ, NF, 9, HEAD, ERR04, LLFREQ) C IF (NPRT .EQ. 0) THEN LDSMIN = 0 ELSE CALL LDSCMP(3, 0, NF+103, 0, 0, 0, 'S', 2*NFFT+206, LDSMIN) END IF C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR05, LLDS) C IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = NF + 103 C C CENTER THE SERIES C CALL CNTR(YFFT, N, YFFT) IEXTND = 0 C C SUBDIVIDE THE STACK. C IF (NPRT .EQ. 0) THEN ISYM = 1 XAXIS = 1 YAXIS = 1 ELSE ISYM = STKGET(LPCV, 2) XAXIS = STKGET(LPCV, 3) YAXIS = STKGET(LPCV, 3) END IF C C COMPUTE THE RAW PERIODOGRAM. C CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, PERI, LPERI, RSTAK(YAXIS), + FREQ, LFREQ, 0, NMSUB) C C CALL THE MAIN DRIVER FOR COMPUTING (AND PLOTTING) THE INTEGRATED C PERIODOGRAM. C CALL IPGDV (PERI, NF, N, PERI, FREQ, RSTAK(XAXIS), + RSTAK(YAXIS), ISTAK(ISYM), LPCV, NPRT) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL IPGMS (YFFT, N, LYFFT, LDSTAK,'/ + ' + NF, PERI, LPERI, FREQ, LFREQ, NPRT)') END *IPGORD SUBROUTINE IPGORD (PERI, NF, N, FREQ, XAXIS, YAXIS, ISYM, NPTS, + LPCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRAL PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 + LPCV,N,NF,NPTS C C ARRAY ARGUMENTS REAL + FREQ(NF),PERI(NF),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C LOCAL SCALARS REAL + CI,CIMID INTEGER + I,II,NLIM C C LOCAL ARRAYS REAL + S(40) C C INTRINSIC FUNCTIONS INTRINSIC MOD,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CI, CIMID C THE WIDTH AND MIDPOINT OF THE TEST INTERVAL FOR WHITE NOISE. C REAL FREQ(NF) C THE ARRAY IN WHICH THE FREQUENCIES AT WHICH THE PERIODOGRAM C WAS ESTIMATED ARE STORED. C INTEGER I C AN INDEX VARIABLE C INTEGER II C AN INDEX VARIABLE C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER N C THE ACTUAL NUMBER OF OBSERVATIONS IN THE SERIES FROM WHICH C THE PERIODOGRAM WAS COMPUTED. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE ESTIMATED. C INTEGER NLIM C THE NUMBER OF POINTS AT WHICH THE WHITE NOISE LIMITS ARE TO C PLOTTED. C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL PERI(NF) C THE ARRAY CONTAINING THE INTEGRATED PERIODOGRAM VALUES. C REAL S(40) C VALUES USED TO COMPUTE THE CONFIDENCE LIMITS. C REAL XAXIS(LPCV), YAXIS(LPCV) C THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS. C DATA S(1)/0.975E0/, S(2)/0.842E0/, S(3)/0.708E0/ DATA S(4)/0.624E0/, S(5)/0.563E0/ DATA S(6)/0.519E0/, S(7)/0.483E0/, S(8)/0.454E0/ DATA S(9)/0.430E0/, S(10)/0.409E0/ DATA S(11)/0.391E0/, S(12)/0.375E0/, S(13)/0.361E0/ DATA S(14)/0.349E0/, S(15)/0.338E0/ DATA S(16)/0.327E0/, S(17)/0.318E0/, S(18)/0.309E0/ DATA S(19)/0.301E0/, S(20)/0.294E0/ DATA S(21)/0.287E0/, S(22)/0.281E0/, S(23)/0.275E0/ DATA S(24)/0.269E0/, S(25)/0.264E0/ DATA S(26)/0.259E0/, S(27)/0.254E0/, S(28)/0.250E0/ DATA S(29)/0.246E0/, S(30)/0.242E0/ DATA S(31)/0.238E0/, S(32)/0.234E0/, S(33)/0.231E0/ DATA S(34)/0.227E0/, S(35)/0.224E0/ DATA S(36)/0.221E0/, S(37)/0.218E0/, S(38)/0.215E0/ DATA S(39)/0.213E0/, S(40)/0.210E0/ C I = N + MOD(N,2) - 1 C IF (I .LE. 40) THEN CI = S(I) ELSE CI = 1.36E0 / SQRT(REAL(I)) END IF C DO 10 I = 1, NF XAXIS(I) = FREQ(I) YAXIS(I) = PERI(I) ISYM(I) = 1 10 CONTINUE C NLIM = 101 C II = NF C DO 30 I = 1, NLIM, 2 CIMID = REAL(I-1) / REAL(NLIM-1) IF (CIMID - CI .LT. 0.0E0) GO TO 20 II = II + 1 XAXIS(II) = CIMID / 2.0E0 YAXIS(II) = CIMID - CI ISYM(II) = 2 20 IF (CIMID + CI .GT. 1.0E0) GO TO 30 II = II + 1 XAXIS(II) = CIMID / 2.0E0 YAXIS(II) = CIMID + CI ISYM(II) = 2 30 CONTINUE C NPTS = II C RETURN END *IPGOUT SUBROUTINE IPGOUT (XAXIS, YAXIS, ISYM, NPTS, LPCV, ISPCER) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES THE INTEGRATED PERIODOGRAM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 + ISPCER,LPCV,NPTS C C ARRAY ARGUMENTS REAL + XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPMN,VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE LOGICAL UNIT NUMBER FOR THE OUTPUT. C INTEGER ISPCER C AN ERROR INDICATOR FOR THE INTEGRATED PERIODOGRAM COMPUTATIONS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL XAXIS(LPCV), YAXIS(LPCV) C THE X, Y CO-ORDINATES FOR THE SPECTRAL PLOTS. C C C SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH. C CALL IPRINT (IPRT) C CALL VERSP(.TRUE.) WRITE (IPRT, 1000) C IF (ISPCER .EQ. 0) GO TO 5 C WRITE (IPRT, 1003) RETURN C 5 CONTINUE C CALL PPMN (YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM, + LPCV, 0, -1, 0.0E0, 1.0E0, 0.0E0, 0.5E0, .FALSE., 0) WRITE(IPRT, 1002) RETURN C C FORMAT STATEMENTS C 1000 FORMAT(34H INTEGRATED SAMPLE PERIODOGRAM (+)/ + 5X, 49H WITH 95 PER CENT TEST LIMITS FOR WHITE NOISE (.)) C1001 FORMAT(5H+FREQ/ C 1 7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X, C 2 3H2.5, 4X, 2H2.) 1002 FORMAT(5H+FREQ/ + 7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X, + 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X, + 6H2.2222, 4X, 2H2.) 1003 FORMAT (///42H THE INTEGRATED PERIODOGRAM OF THIS SERIES, + 22H COULD NOT BE COMPUTED/ + 44H BECAUSE THE VARIANCE OF THE SERIES IS ZERO.) END *IPRINT SUBROUTINE IPRINT(IPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE LOGICAL UNIT FOR PRINTED OUTPUT. 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 + IPRT C C EXTERNAL FUNCTIONS INTEGER + I1MACH EXTERNAL I1MACH C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IPRT C THE UNIT NUMBER FOR OUTPUT. C IPRT = I1MACH(2) RETURN 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 REAL + D(P),V(*),X(P) INTEGER + IV(*) C C LOCAL SCALARS REAL + 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 REAL 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 REAL 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 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.0E0/ C C----------------------------------------------------------------------- C PU = IV(PRUNIT) IF (PU .EQ. 0) GO TO 999 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) WRITE(PU, 1010) 1010 FORMAT(12H0 IT NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX) IV(NEEDHD) = 0 WRITE(PU,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX) GO TO 20 C C *** PRINT LONG SUMMARY LINE *** C 15 IF (IV(NEEDHD) .EQ. 1) WRITE(PU,1015) 1015 FORMAT(12H0 IT NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX, + 4X,15HMODEL STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF) IV(NEEDHD) = 0 M = IV(SUSED) NRELDF = ZERO IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF WRITE(PU,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,4E11.3,7A1,4E11.3) C 20 GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1 C 30 WRITE(PU,1030) 1030 FORMAT(26H0***** X-CONVERGENCE *****) GO TO 180 C 35 WRITE(PU,1035) 1035 FORMAT(42H0***** RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 40 WRITE(PU,1040) 1040 FORMAT(49H0***** X- AND RELATIVE FUNCTION CONVERGENCE *****) GO TO 180 C 45 WRITE(PU,1045) 1045 FORMAT(42H0***** ABSOLUTE FUNCTION CONVERGENCE *****) GO TO 180 C 50 WRITE(PU,1050) 1050 FORMAT(33H0***** SINGULAR CONVERGENCE *****) GO TO 180 C 60 WRITE(PU,1060) 1060 FORMAT(30H0***** FALSE CONVERGENCE *****) GO TO 180 C 70 WRITE(PU,1070) 1070 FORMAT(38H0***** FUNCTION EVALUATION LIMIT *****) GO TO 180 C 80 WRITE(PU,1080) 1080 FORMAT(28H0***** ITERATION LIMIT *****) GO TO 180 C 90 WRITE(PU,1090) 1090 FORMAT(18H0***** STOPX *****) GO TO 180 C 110 WRITE(PU,1100) 1100 FORMAT(45H0***** INITIAL SUM OF SQUARES OVERFLOWS *****) C GO TO 150 C 120 WRITE(PU,1120) 1120 FORMAT(37H0***** BAD PARAMETERS TO ASSESS *****) GO TO 999 C 130 WRITE(PU,1130) 1130 FORMAT(36H0***** J COULD NOT BE COMPUTED *****) IF (IV(NITER) .GT. 0) GO TO 190 GO TO 150 C 140 WRITE(PU,1140) IV1 1140 FORMAT(14H0***** IV(1) =,I5,6H *****) GO TO 999 C C *** INITIAL CALL ON ITSMRY *** C 150 IF (IV(X0PRT) .NE. 0) WRITE(PU,1150) (I, X(I), D(I), I = 1, P) 1150 FORMAT(23H0 I INITIAL X(I),7X,4HD(I)//(1X,I5,E17.6,E14.3)) IF (IV1 .GE. 13) GO TO 999 IV(NEEDHD) = 0 IV(PRNTIT) = 0 IF (OL .EQ. 0) GO TO 999 IF (OL .LT. 0) WRITE(PU,1010) IF (OL .GT. 0) WRITE(PU,1015) WRITE(PU,1160) V(F) 1160 FORMAT(12H0 0 1,E11.3,11X,E11.3) 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(PU,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF 1180 FORMAT(9H0FUNCTION,E17.6,8H RELDX,E20.6/12H FUNC. EVALS, + I8,9X,'GRAD. EVALS',I8/' PRELDF',E19.6,3X,'NPRELDF',E18.6) C IF (IV(NFCOV) .GT. 0) WRITE(PU,1185) IV(NFCOV) 1185 FORMAT('0',I4,' EXTRA FUNC. EVALS FOR COVARIANCE.') IF (IV(NGCOV) .GT. 0) WRITE(PU,1186) IV(NGCOV) 1186 FORMAT(1X,I4,' EXTRA GRAD. EVALS FOR COVARIANCE.') C 190 IF (IV(SOLPRT) .EQ. 0) GO TO 210 IV(NEEDHD) = 1 G1 = IV(G) WRITE(PU,1190) 1190 FORMAT('0 I FINAL X(I)',8X,'D(I)',10X,'G(I)'/) DO 200 I = 1, P WRITE(PU,1200) I, X(I), D(I), V(G1) G1 = G1 + 1 200 CONTINUE 1200 FORMAT(1X,I5,E17.6,2E14.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) WRITE(PU,1220) 1220 FORMAT(43H0++++++ INDEFINITE COVARIANCE MATRIX ++++++) IF (-2 .EQ. COV1) WRITE(PU,1225) 1225 FORMAT(52H0++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++) GO TO 999 C 230 WRITE(PU,1230) 1230 FORMAT(45H0++++++ COVARIANCE MATRIX NOT COMPUTED ++++++) GO TO 999 C 240 I = ABS(IV(COVREQ)) IF (I .LE. 1) WRITE(PU,1241) 1241 FORMAT(48H0COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/) IF (I .EQ. 2) WRITE(PU,1242) 1242 FORMAT(27H0COVARIANCE = SCALE * H**-1/) IF (I .GE. 3) WRITE(PU,1243) 1243 FORMAT(36H0COVARIANCE = SCALE * (J**T * J)**-1/) II = COV1 - 1 IF (OL .LE. 0) GO TO 260 DO 250 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1250) I, (V(J), J = I1, II) 250 CONTINUE 1250 FORMAT(4H ROW,I3,2X,9E12.4/(9X,9E12.4)) GO TO 999 C 260 DO 270 I = 1, P I1 = II + 1 II = II + I WRITE(PU,1270) I, (V(J), J = I1, II) 270 CONTINUE 1270 FORMAT(4H ROW,I3,2X,5E12.4/(9X,5E12.4)) C 999 RETURN C *** LAST CARD OF ITSMRY FOLLOWS *** END *J4SAVE INTEGER FUNCTION J4SAVE(IWHICH,IVALUE,ISET) C C ABSTRACT C J4SAVE SAVES AND RECALLS SEVERAL GLOBAL VARIABLES NEEDED C BY THE LIBRARY ERROR HANDLING ROUTINES. C C DESCRIPTION OF PARAMETERS C --INPUT-- C IWHICH - INDEX OF ITEM DESIRED. C = 1 REFERS TO CURRENT ERROR NUMBER. C = 2 REFERS TO CURRENT ERROR CONTROL FLAG. C = 3 REFERS TO CURRENT UNIT NUMBER TO WHICH ERROR C MESSAGES ARE TO BE SENT. (0 MEANS USE STANDARD.) C = 4 REFERS TO THE MAXIMUM NUMBER OF TIMES ANY C MESSAGE IS TO BE PRINTED (AS SET BY XERMAX). C = 5 REFERS TO THE TOTAL NUMBER OF UNITS TO WHICH C EACH ERROR MESSAGE IS TO BE WRITTEN. C = 6 REFERS TO THE 2ND UNIT FOR ERROR MESSAGES C = 7 REFERS TO THE 3RD UNIT FOR ERROR MESSAGES C = 8 REFERS TO THE 4TH UNIT FOR ERROR MESSAGES C = 9 REFERS TO THE 5TH UNIT FOR ERROR MESSAGES C IVALUE - THE VALUE TO BE SET FOR THE IWHICH-TH PARAMETER, C IF ISET IS .TRUE. . C ISET - IF ISET=.TRUE., THE IWHICH-TH PARAMETER WILL BE C GIVEN THE VALUE, IVALUE. IF ISET=.FALSE., THE C IWHICH-TH PARAMETER WILL BE UNCHANGED, AND IVALUE C IS A DUMMY PARAMETER. C --OUTPUT-- C THE (OLD) VALUE OF THE IWHICH-TH PARAMETER WILL BE RETURNED C IN THE FUNCTION VALUE, J4SAVE. C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C ADAPTED FROM BELL LABORATORIES PORT LIBRARY ERROR HANDLER C LATEST REVISION --- 23 MAY 1979 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER IVALUE,IWHICH LOGICAL ISET C C LOCAL ARRAYS INTEGER IPARAM(9) C DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,1,0,10/ DATA IPARAM(5)/1/ DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ J4SAVE = IPARAM(IWHICH) IF (ISET) IPARAM(IWHICH) = IVALUE RETURN 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 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 *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 REAL + L(*),LIN(*) C C LOCAL SCALARS REAL + ONE,T,ZERO INTEGER + I,II,IM1,J0,J1,JJ,K,K0,NP1 C C *** PARAMETERS *** C C INTEGER N C REAL 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 REAL ONE, T, ZERO DATA ONE/1.0E0/, ZERO/0.0E0/ 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 *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 REAL + L(1),X(N),Y(N) C C LOCAL SCALARS REAL + XI,ZERO INTEGER + I,I0,II,IJ,IM1,J,NP1 C DATA ZERO/0.0E0/ 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 *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 REAL + L(1),X(N),Y(N) C C LOCAL SCALARS REAL + T,ZERO INTEGER + I,J,K C C EXTERNAL FUNCTIONS REAL + DOTPRD EXTERNAL DOTPRD C DATA ZERO/0.0E0/ 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 *LLCNT SUBROUTINE LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK, + NPRT, PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, + IVCV, LLHDR, IFIT, NMSUB, WEIGHT, SAVE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR LINEAR LEAST C SQUARES. 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 REAL + RSD INTEGER + IFIT,IVCV,IXM,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,M,N,NPAR, + NPRT LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL LLHDR C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + ACC,C,FC,IFP,NALL0,NDIGIT,NNZW,PAR1,PARI,PVI,RED,RESI, + RSDI,SDPVI,SDRESI,T,VCVI,WTI,WY,XMW LOGICAL + PAGE,WIDE C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + IPTOUT(4),ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYMSS,LLER,LLSMN,PRTCNT,SCOPY,SETRV,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACC C THE STARTING LOCATION IN THE WORK AREA FOR C THE NUMBER OF ACCURATE DIGITS. C INTEGER C C * C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER FC C THE STARTING LOCATION IN THE WORK AREA FOR C THE ORTHONORMALIZATION MATRIX. C INTEGER IERR C THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IFIT C THE INDICATOR VALUE DESIGNATING WHETHER THE FIT IS OF A C GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1). C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C SINGLE PRECISION AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IPTOUT(4) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C EXTERNAL LLHDR C THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. 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 CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. 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 REAL PAR(LPAR) C THE PARAMETERS TO BE ESTIMATED. C INTEGER PARI C THE STARTING LOCATION IN THE WORK AREA OF C THE PARAMETERS TO BE ESTIMATED. C INTEGER PAR1 C THE STARTING LOCATION IN THE WORK AREA FOR C THE PARAMETERS TO BE ESTIMATED OMMITTING THE LAST C INDEPENDENT VARIABLE. C REAL PV(LPV) C THE PREDICTED VALUES. C INTEGER PVI C THE STARTING LOCATION IN THE WORK AREA FOR C THE PREDICTED VALUES. C INTEGER RED C THE STARTING LOCATION IN THE WORK AREA FOR C THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER. C REAL RES(N) C THE RESIDUALS. C INTEGER RESI C THE STARTING LOCATION IN THE WORK AREA FOR C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C INTEGER RSDI C THE STARTING LOCATION IN THE WORK AREA FOR C THE RESIDUAL STANDARD DEVIATION. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C INTEGER SDPVI C THE STARTING LOCATION IN THE WORK AREA FOR C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C INTEGER SDRESI C THE STARTING LOCATION IN THE WORK AREA FOR C THE STANDARDIZED RESIDUALS. C INTEGER T C THE STARTING LOCATION IN THE WORK AREA FOR C THE TRIANGULAR MATRIX FROM THE DECOMPOSITION. C REAL VCV(IVCV,NPAR) C THE VARIANCE COVARIANCE MATRIX. C INTEGER VCVI C THE STARTING LOCATION IN THE WORK AREA FOR 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 REAL WT(LWT) C THE WEIGHTS. C INTEGER WTI C THE STARTING LOCATION IN THE WORK AREA FOR C THE WEIGHTS. C INTEGER WY C THE STARTING LOCATION IN THE WORK AREA FOR C THE VECTOR CONTAINING SQRT(WT)*Y. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C INTEGER XMW C THE STARTING LOCATION IN THE WORK AREA FOR C THE MATRIX CONTAINING XM * SQRT(WT). C REAL Y(N) C THE DEPENDENT VARIABLE. C C WIDE = .TRUE. PAGE = .FALSE. NDIGIT = 4 C IFP = 3 C C SET PRINT CONTROL VALUES C CALL PRTCNT(NPRT, NDIGIT, IPTOUT) C C CHECK FOR ERRORS C CALL LLER(NMSUB, IXM, IVCV, N, NPAR, LPAR, LDSTAK, WT, LWT, + WEIGHT, NNZW, IFIT, SAVE) IF (IERR.NE.0) RETURN C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C C SET UP SUBDIVISION OF WORK AREAS C WTI = STKGET(N,IFP) RESI = STKGET(N,IFP) RSDI = STKGET(1,IFP) PARI = STKGET(NPAR,IFP) PVI = STKGET(N,IFP) SDPVI = STKGET(N,IFP) SDRESI = STKGET(N,IFP) VCVI = STKGET(NPAR*NPAR,IFP) C WY = STKGET(N,IFP) XMW = STKGET(N*NPAR,IFP) RED = STKGET(NPAR,IFP) T = STKGET(NPAR*NPAR,IFP) PAR1 = STKGET(NPAR,IFP) ACC = STKGET(NPAR,IFP) C = STKGET(NPAR,IFP) C C EQUIVALENCED LOCATIONS WITHIN SCRAT C FC = XMW C C SET UP WEIGHTS VECTOR C IF (WEIGHT) THEN CALL SCOPY(N, WT, 1, RSTAK(WTI), 1) ELSE CALL SETRV(RSTAK(WTI), N, 1.0E0) END IF C CALL LLSMN(Y, XM, RSTAK(WTI), N, M, NPAR, IXM, RSTAK(RESI), + RSTAK(PARI), NNZW, RSTAK(RSDI), RSTAK(PVI), RSTAK(SDPVI), + RSTAK(SDRESI), IPTOUT, RSTAK(WY), RSTAK(XMW), RSTAK(VCVI), + RSTAK(FC), RSTAK(RED), RSTAK(T), RSTAK(PAR1), RSTAK(ACC), IFIT, + WEIGHT, RSTAK(C), LLHDR, PAGE, WIDE) C CALL SCOPY(N, RSTAK(RESI), 1, RES, 1) C IF (SAVE) THEN RSD = RSTAK(RSDI) CALL SCOPY(NPAR, RSTAK(PARI), 1, PAR, 1) CALL SCOPY(N, RSTAK(PVI), 1, PV, 1) CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1) CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1) CALL CPYMSS(NPAR, NPAR, RSTAK(VCVI), NPAR, VCV, IVCV) END IF CALL STKCLR(NALL0) C IF (IERR.EQ.3) IERR = 2 IF (IERR.EQ.4) IERR = 3 C RETURN C END *LLCNTG SUBROUTINE LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR GENERAL LINEAR LEAST C SQUARES. 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 REAL + RSD INTEGER + IVCV,IXM,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,N,NPAR,NPRT LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IFIT,M C C EXTERNAL SUBROUTINES EXTERNAL LLCNT,LLHDRG C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IFIT C THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A C GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1). C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C EXTERNAL LLHDRG C THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(LPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(LPV) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(LWT) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C IFIT = 3 M = NPAR C CALL LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + LLHDRG, IFIT, NMSUB, WEIGHT, SAVE) C RETURN C END *LLCNTP SUBROUTINE LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, + NPRT, PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, + IVCV, NMSUB, WEIGHT, SAVE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR POLYNOMIAL LINEAR LEAST C SQUARES. 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 REAL + RSD INTEGER + IVCV,LDSTAK,LPAR,LPV,LSDPV,LSDRES,LWT,N,NDEG,NPAR,NPRT LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IFIT,IXM,M C C EXTERNAL SUBROUTINES EXTERNAL LLCNT,LLHDRP C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IFIT C THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A C GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1). C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C EXTERNAL LLHDRP C THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEG C THE DEGREE OF THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(LPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(LPV) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(LWT) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(N,1) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C IFIT = 1 NPAR = NDEG + 1 M = 1 IXM = N C CALL LLCNT(Y, WT, LWT, XM, N, M, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + LLHDRP, IFIT, NMSUB, WEIGHT, SAVE) C RETURN C END *LLER SUBROUTINE LLER(NMSUB, IXM, IVCV, N, NPAR, LPAR, LDSTAK, WT, LNWT, + WEIGHT, NNZW, IFIT, SAVE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE LINEAR LEAST C SQUARES LLSTING 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 INTEGER + IFIT,IVCV,IXM,LDSTAK,LNWT,LPAR,N,NNZW,NPAR LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + WT(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,LDSMIN,NZW LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(10) CHARACTER + LIVCV(8)*1,LIXM(8)*1,LLDS(8)*1,LLPAR(8)*1,LN(8)*1, + LN1(8)*1,LNC(8)*1,LNDEG(8)*1,LNDEG1(8)*1,LNPAR(8)*1, + LONE(8)*1,LWT(8)*1,LZERO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERVWT,LDSCMP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(10) 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. 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 IFIT C THE INDICATOR VALUE DESIGNATING WHETHER THE LLS IS OF A C GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1). C INTEGER IVCV C THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK. C CHARACTER*1 LIVCV(8), LIXM(8), LLPAR(8), LLDS(8), LN(8), LNC(8), C * LNDEG(8), LNDEG1(8), LNPAR(8), LN1(8), LONE(8), LWT(8), C * LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LNWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NZW C THE NUMBER OF ZERO WEIGHTS. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(LNWT) C THE USER SUPPLIED WEIGHTS. 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 LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6), + LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LLPAR(1), LLPAR(2), LLPAR(3), LLPAR(4), LLPAR(5), LLPAR(6), + LLPAR(7), LLPAR(8) /'L','P','A','R',' ',' ',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNDEG(1), LNDEG(2), LNDEG(3), LNDEG(4), LNDEG(5), LNDEG(6), + LNDEG(7), LNDEG(8) /'N','D','E','G',' ',' ',' ',' '/ DATA LNDEG1(1), LNDEG1(2), LNDEG1(3), LNDEG1(4), LNDEG1(5), + LNDEG1(6), LNDEG1(7), LNDEG1(8) /'N','D','E','G','+','1', + ' ',' '/ DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5), + LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ', + ' '/ DATA LN1(1), LN1(2), LN1(3), LN1(4), LN1(5), LN1(6), + LN1(7), LN1(8) /'N','-','1',' ',' ',' ',' ',' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), + LONE(7), LONE(8) /'O','N','E',' ',' ',' ',' ',' '/ DATA LWT(1), LWT(2), LWT(3), LWT(4), LWT(5), LWT(6), LWT(7), + LWT(8) /'W','T',' ',' ',' ',' ',' ',' '/ 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 IERR = 0 HEAD = .TRUE. C DO 10 I=1,10 ERROR(I) = .FALSE. 10 CONTINUE C IF (IFIT.EQ.1) GO TO 30 C DO 20 I = 1, 8 LNC(I) = LNPAR(I) 20 CONTINUE GO TO 50 C 30 CONTINUE DO 40 I = 1, 8 LNC(I) = LNDEG1(I) 40 CONTINUE C 50 CONTINUE C CALL EISGE(NMSUB, LN, N, 1, 1, HEAD, ERROR(1), LN) C IF (IFIT.EQ.3) + CALL EISII(NMSUB, LNPAR, NPAR, 1, N, 1, HEAD, ERROR(2), LONE, + LN) IF (IFIT.EQ.1) + CALL EISII(NMSUB, LNDEG, NPAR-1, 0, N-1, 1, HEAD, ERROR(2), + LZERO, LN1) C CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(4), LN) C IF (SAVE .AND. (IFIT.EQ.1)) + CALL EISGE(NMSUB, LLPAR, LPAR, NPAR, 7, HEAD, ERROR(5), LNDEG1) C IF (SAVE) + CALL EISGE(NMSUB, LIVCV, IVCV, NPAR, 3, HEAD, ERROR(6), LNC) C IF (ERROR(1) .OR. ERROR(2) .OR. ERROR(3)) GO TO 70 C NNZW = N IF (WEIGHT) CALL ERVWT(NMSUB, LWT, WT, N, NPAR, HEAD, NNZW, + NZW, 2, ERROR(8), LNC) C CALL LDSCMP(15, 0, 0, 0, 0, 0, 'S', + 6*N + NPAR*(N+2*NPAR+5) + 1, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(9), LLDS) C DO 60 I=1,10 IF (ERROR(I)) GO TO 70 60 CONTINUE RETURN C 70 CONTINUE IERR = 1 RETURN C END *LLHDRG SUBROUTINE LLHDRG(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE UNRESTRICTED C LINEAR 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 - DECEMBER 29, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT,1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT,1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (32H+LINEAR LEAST SQUARES ESTIMATION, + ' WITH USER-SPECIFIED MODEL, CONTINUED') 1010 FORMAT ('+', 63('*')/ + 1X, 34H* LINEAR LEAST SQUARES ESTIMATION, + ' WITH USER-SPECIFIED MODEL *'/ 1X, 63('*')) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) END *LLHDRP SUBROUTINE LLHDRP(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE POLYNOMIAL LINEAR C LEAST SQUARES LLSTING 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 INTEGER + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT,1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT,1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (32H+LINEAR LEAST SQUARES ESTIMATION, + 33H WITH POLYNOMIAL MODEL, CONTINUED) 1010 FORMAT ('+', 59('*')/ + 1X, 34H* LINEAR LEAST SQUARES ESTIMATION, + 25H WITH POLYNOMIAL MODEL */ 1X, + 59('*')) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) END *LLS SUBROUTINE LLS(Y, XM, N, IXM, NPAR, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT C NO WEIGHTS SPECIFIED C NO STORAGE OTHER THAN RESIDUALS C FOUR PAGES AUTOMATIC PRINTOUT 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 + IXM,LDSTAK,N,NPAR C C ARRAY ARGUMENTS REAL + RES(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTG C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(1) C A DUMMY ARRAY FOR C THE PARAMETERS TO BE ESTIMATED. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARDIZED RESIDUALS. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(1) C A DUMMY ARRAY FOR C THE WEIGHTS. C REAL XM(IXM,NPAR) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S',' ',' ',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .FALSE. SAVE = .FALSE. NPRT = 1111 LPAR = 1 LPV = 1 LSDPV = 1 LSDRES = 1 IVCV = 1 LWT = 1 C CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 50H CALL LLS (Y, XM, N, IXM, NPAR, RES, LSDTAK)) END *LLSMN SUBROUTINE LLSMN(Y, X, WT, N, M, NPAR, IX, RES, PAR, NNZW, + RSD, PV, SDPV, SDRES, IPTOUT, WY, XW, VCV, FC, RED, + T, PAR1, ACC, IFIT, WEIGHT, C, LLHDR, PAGE, WIDE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN PROGRAM FOR THE LINEAR LEAST SQUARES FITTING C PROGRAMS 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 REAL + RSD INTEGER + IFIT,IX,M,N,NNZW,NPAR LOGICAL + PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + ACC(NPAR),C(NPAR),FC(N,NPAR),PAR(NPAR),PAR1(NPAR),PV(N), + RED(NPAR),RES(N),SDPV(N),SDRES(N),T(NPAR,NPAR), + VCV(NPAR,NPAR),WT(N),WY(N),X(IX,M),XW(N,NPAR),Y(N) INTEGER + IPTOUT(4) C C SUBROUTINE ARGUMENTS EXTERNAL LLHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + COND,DF,FPLM,FPLRS,FPSPM,PROBT,PROBT1,PX,R2,RATIO,RATIO1, + RSD1,RSS,RSS1,RVAR,RVAR1,SDC,SDC1,SM,TD,WTSQRT,WTSUM,WTYM,YSUM INTEGER + I,IDF,IDF1,IER,IPRT,IREFIT,ISUBHD,J,K,NC LOGICAL + CONST C C LOCAL ARRAYS REAL + DET(2) C C EXTERNAL FUNCTIONS REAL + CDFT,R1MACH EXTERNAL CDFT,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL ACCDIG,FITPT1,FITPT2,IPRINT,MGS,OANOVA,VCVOUT EXTERNAL STRCO,STRDI C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACC(NPAR) C THE NUMBER OF ACCURATE DIGITS. C REAL C(NPAR) C A WORK VECTOR. C REAL COND C THE CONDITION NUMBER OF THE DESIGN MATRIX. C LOGICAL CONST C AN INDICATOR VALUE DESIGNATING WHETHER THE FIRST COLUMN OF C THE DESIGN MATRIX IS ALL ONES FOR A CONSTANT. C REAL DET(2) C THE DETERMINENT. C REAL DF C THE DEGREES OF FREEDOM. C REAL FC(N,NPAR) C THE ORTHONORMALIZATION MATRIX. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL FPLRS C THE FLOATING POINT LARGEST RELATIVE SPACING. C REAL FPSPM C THE FLOATING POINT SMALLEST POSITIVE MAGNITUDE. C INTEGER I C AN INDEX. C INTEGER IDF C THE DEGREES OF FREEDOM C INTEGER IDF1 C THE DEGREES OF FREEDOM FOR THE FIT WITHOUT THE LAST INDEPENDENT C VARIABLE. C INTEGER IER C THE ERROR FLAG RETURNED BY THE INVERSION ROUTINES. C INTEGER IERR C THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IFIT C THE INDICATOR VALUE DESIGNATING WHETHER THE FIT IS OF A C GENERAL MODEL (IFIT=3) OR A POLYNOMIAL MODEL (IFIT=1). C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IPTOUT(4) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER IREFIT C AN INDICATOR USED TO DESIGNATE WHETHER THE FIT IS OF THE C FULL DESIGN MATRIX (IREFIT=0) OR IS OMITTING THE LAST C INDEPENDENT VARIABLE (IREFIT=1). C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IX C THE FIRST DIMENSION OF THE MATRIX X. C INTEGER J C AN INDEX. C INTEGER K C AN INDEX. C EXTERNAL LLHDR C THE NAME OF THE ROUTINE THAT PRODUCED THE HEADING. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NC C THE NUMBER OF PARAMETERS BEING FIT. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NPAR C THE NUMBER OF PARAMETERS. 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 REAL PAR(NPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PAR1(NPAR) C THE PARAMETERS TO BE ESTIMATED OMMITTING THE LAST C INDEPENDENT VARIABLE. C REAL PROBT C ... C REAL PROBT1 C ... C REAL PV(N) C THE PREDICTED VALUES. C REAL PX C A WORK VARIABLE. C REAL RATIO C THE RATIO OF THE PARAMETERS TO THEIR STANDARD DEVIATIONS. C REAL RATIO1 C THE RATIO OF THE PARAMETERS COMPUTED OMITTING THE LAST C INDEPENDENT VARIABLE TO THEIR STANDARD DEVIATIONS. C REAL RED(NPAR) C THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSD1 C THE RESIDUAL STANDARD DEVIATION FROM THE FIT OMITTING C THE LAST INDEPENDENT VARIABLE. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RSS1 C THE RESIDUAL SUM OF SQUARES FROM THE FIT OMITTING C THE LAST INDEPENDENT VARIABLE. C REAL RVAR C THE RESIDUAL VARIANCE. C REAL RVAR1 C THE RESIDUAL VARIANCE FROM THE FIT OMITTING C THE LAST INDEPENDENT VARIABLE. C REAL R2 C THE MULTIPLE CORRELATION PARAMETER. C REAL SDC C THE ESTIMATED STANDARD DEVIATIONS OF THE PARAMETERS. C REAL SDC1 C THE ESTIMATED STANDARD DEVIATIONS OF THE PARAMETERS OMITTING C THE LAST INDEPENDENT VARIABLE. C REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL SM C A WORK VARIABLE. C REAL T(NPAR,NPAR) C THE TRIANGULAR MATRIX FROM THE DECOMPOSITION. C REAL TD C A WORK VARIABLE. C REAL VCV(NPAR,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 REAL WT(N) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL WTSQRT C THE SQUARE ROOT OF THE WEIGHT. C REAL WTSUM C THE SUM OF THE WEIGHTS. C REAL WTYM C THE SUM OF THE WEIGHTED DEPENDENT VARIABLES. C REAL WY(N) C THE VECTOR CONTAINING SQRT(WT)*Y. C REAL X(IX,M) C THE INDEPENDENT VARIABLE. C REAL XW(N,NPAR) C THE MATRIX CONTAINING X * SQRT(WT). C REAL Y(N) C THE DEPENDENT VARIABLE. C REAL YSUM C THE SUM OF THE WEIGHTED DEPENDENT VARIABLES SQUARED. C CALL IPRINT(IPRT) C C INITIALIZE VARIABLES C FPLM = R1MACH(2) FPLRS = R1MACH(4) FPSPM = R1MACH(1) NC = NPAR IDF = NNZW - NC DF = IDF C R2 = 0.0 RVAR1 = 0.0 RSD1 = 0.0 J = 0 IDF1 = 0 CONST = .FALSE. C YSUM = 0.0E0 WTSUM = 0.0E0 DO 10 I=1,N IF (WT(I).LE.0.0E0) GO TO 10 YSUM = YSUM + WT(I)*Y(I)*Y(I) WTSUM = WTSUM + WT(I) 10 CONTINUE C C BEGIN FIT C IREFIT = -1 C C IF IREFIT IS EQUAL TO 1 FIT IS OMITTING THE LAST VARIABLE C 50 IREFIT = IREFIT + 1 C C COMPUTE WORKING VECTORS C WTYM = 0.0E0 I = 0 DO 70 K=1,N IF (WT(K).LE.0.0E0) GO TO 70 WTSQRT = SQRT(WT(K)) I = I + 1 PX = WTSQRT DO 60 J=1,NC IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(K,1) IF (IFIT.EQ.3) PX = X(K,J)*WTSQRT XW(I,J) = PX 60 CONTINUE C C COMPUTE WY ( WEIGHTS * Y VECTOR ) C WY(I) = Y(K)*WTSQRT WTYM = WTYM + WT(K)*Y(K) 70 CONTINUE WTYM = WTYM/WTSUM C C COMPUTE ESTIMATED VALUES OF PARAMETERS C IF (IREFIT.EQ.1) GO TO 80 IER = 0 CALL MGS(XW, WY, NNZW, NC, PAR, C, T(1,1), T, NPAR, N, IER) IF (IER.EQ.0) GO TO 90 IERR = 3 ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) WRITE (IPRT,1160) WRITE (IPRT,1150) RETURN 80 CONTINUE IER = 0 CALL MGS(XW, WY, NNZW, NC, PAR1, C, T(1,1), T, NPAR, N, IER) C C COMPUTE PREDICTED VALUES (PV) AND RESIDUALS (RES) C RESIDUAL SUM OF SQUARES (RSS) AND C RESIDUAL STANDARD DEVIATION (RSD) AND C SUM OF WEIGHTS (WTSUM) AND C RESIDUAL VARAINCE (RVAR) C 90 RSS = 0.0E0 RSS1 = 0.0E0 DO 120 I=1,N SM = 0.0E0 PX = 1.0E0 DO 100 J=1,NC IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(I,1) IF (IFIT.EQ.3) PX = X(I,J) IF (IREFIT.EQ.0) SM = SM + PAR(J)*PX IF (IREFIT.EQ.1) SM = SM + PAR1(J)*PX 100 CONTINUE IF (IREFIT.EQ.0) THEN PV(I) = SM RES(I) = Y(I) - PV(I) RSS = RSS + RES(I)*WT(I)*RES(I) ELSE RSS1 = RSS1 + (Y(I)-SM)*WT(I)*(Y(I)-SM) END IF 120 CONTINUE C IF (IREFIT.EQ.0) GO TO 130 RVAR1 = RSS1/(DF+1.0E0) RSD1 = SQRT(RVAR1) GO TO 380 130 RVAR = 0.0E0 IF (DF.GT.0.0E0) RVAR = RSS/DF RSD = SQRT(RVAR) C C COMPUTE MULTIPLE CORRELATION PARAMETER SQUARED (R2) C SM = 0.0E0 CONST = .TRUE. DO 140 I=1,N IF ((X(I,1).NE.1.0E0) .AND. (IFIT.EQ.3)) CONST = .FALSE. SM = SM + (Y(I)-WTYM)*WT(I)*(Y(I)-WTYM) 140 CONTINUE R2 = 1.0E0 IF (SM.GT.0.0E0) R2 = 1.0E0-RSS/SM C C CHECK FOR -EXACT- FIT C TD = 0.0E0 IF (DF.GT.0.0E0) TD = SQRT(RSS) IF (YSUM.GT.0.0E0) TD = TD/SQRT(YSUM) IF (TD.GT.10.0E0*FPLRS) GO TO 180 C IERR = 0 IF ((IPTOUT(1).EQ.0) .AND. (IPTOUT(2).EQ.0) .AND. (IPTOUT(3).EQ.0) + .AND. (IPTOUT(4).EQ.0)) GO TO 145 ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) WRITE (IPRT,1180) WRITE (IPRT,1020) (I,PAR(I),I=1,NPAR) C C ZERO OUT VCV MATRIX AND SDRES AND SDPV VECTORS C 145 CONTINUE DO 150 I=1,N SDPV(I) = 0.0E0 SDRES(I) = 0.0E0 150 CONTINUE DO 170 I=1,NPAR DO 160 J=1,NPAR VCV(I,J) = 0.0E0 160 CONTINUE 170 CONTINUE RETURN C 180 CONTINUE C C COMPUTE ORTHO NORMALIZATION C DO 200 I=1,NC T(I,I) = SQRT(T(I,1)) DO 190 J=I,NC IF (I.EQ.J) GO TO 190 T(I,J) = T(I,J)*T(I,I) 190 CONTINUE 200 CONTINUE C CALL STRCO(T, NPAR, NC, COND, C, 1) IF (COND.NE.0.0E0) THEN COND = 1.0E0/COND ELSE COND = FPLM END IF CALL STRDI(T, NPAR, NC, DET, 011, IER) C IF (IER.EQ.0) GO TO 210 IERR = 3 ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) WRITE (IPRT,1160) WRITE (IPRT,1120) RETURN 210 CONTINUE DO 240 I=1,N DO 230 J=1,NC SM = 0.0E0 PX = 1.0E0 DO 220 K=1,J IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1) IF (IFIT.EQ.3) PX = X(I,K) SM = SM + PX*T(K,J) 220 CONTINUE FC(I,J) = SM 230 CONTINUE 240 CONTINUE C C COMPUTE REDUCTION TO RSS DUE TO FITTING C DO 260 J=1,NC SM = 0.0E0 DO 250 I=1,N SM = SM + (FC(I,J))*WT(I)*Y(I) 250 CONTINUE RED(J) = (SM*SM) 260 CONTINUE C C COMPUTE ESTIMATED VARIANCE COVARIANCE MATRIX C DO 290 I=1,NC DO 280 J=I,NC SM = 0.0E0 DO 270 K=J,NC SM = SM + T(I,K)*T(J,K) 270 CONTINUE IF (SQRT(ABS(SM))*SQRT(RVAR).GE.SQRT(FPSPM)) THEN VCV(I,J) = SM*RVAR ELSE VCV(I,J) = 0.0E0 END IF VCV(J,I) = VCV(I,J) 280 CONTINUE 290 CONTINUE C C REFIT TO PREDICTED VALUES C I = 0 DO 310 K=1,N IF (WT(K).LE.0.0E0) GO TO 310 WTSQRT = SQRT(WT(K)) I = I + 1 PX = WTSQRT DO 300 J=1,NC IF (IFIT.EQ.1 .AND. J.GE.2) PX = PX*X(K,1) IF (IFIT.EQ.3) PX = X(K,J)*WTSQRT XW(I,J) = PX 300 CONTINUE WY(I) = PV(K)*WTSQRT 310 CONTINUE C IER = 0 CALL MGS(XW, WY, NNZW, NC, PAR1, C, T(1,1), T, NPAR, N, IER) C CALL ACCDIG(PAR, PAR1, ACC, NC) C C COMPUTE STANDARD DEVIATION OF PREDICTED VALUES (SDPV) C AND STANDARDIZED RESIDUALS (SDRES) C DO 360 I=1,N SM = 0.0E0 DO 330 J=1,NC SM = 0.0E0 PX = 1.0E0 DO 320 K=1,NC IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1) IF (IFIT.EQ.3) PX = X(I,K) SM = SM + PX*VCV(J,K) 320 CONTINUE XW(I,J) = SM 330 CONTINUE SM = 0.0E0 PX = 1.0E0 DO 340 K=1,NC IF (IFIT.EQ.1 .AND. K.GE.2) PX = PX*X(I,1) IF (IFIT.EQ.3) PX = X(I,K) SM = SM + XW(I,K)*PX 340 CONTINUE SM = MAX(0.0E0, SM) SDPV(I) = SQRT(SM) SDRES(I) = FPLM IF (WT(I).LE.0.0E0) GO TO 360 IF ((RVAR/WT(I)-SM).LE.0.0E0) IERR = 4 IF (RVAR/WT(I)-SM.GT.0.0E0) + SDRES(I) = (RES(I)/SQRT(RVAR/WT(I)-SM)) 360 CONTINUE C C CHECK FOR PRINTED OUTPUT C IF ((IPTOUT(1).EQ.0) .AND. (IPTOUT(2).EQ.0) .AND. + (IPTOUT(3).EQ.0) .AND. (IPTOUT(4).EQ.0)) RETURN C C BEGIN PRINTED OUTPUT C IF (IPTOUT(1).EQ.0) GO TO 370 C C PRINT FIRST PAGE OF OUTPUT C ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) CALL FITPT1(N, M, X, Y, PV, SDPV, RES, SDRES, WT, IX, NNZW, + WEIGHT, IPTOUT(1)) C C PRINT PLOTS C 370 CONTINUE IF (IPTOUT(2).EQ.0) GO TO 375 ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) CALL FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS) C 375 CONTINUE IF (IPTOUT(3).EQ.0) GO TO 376 C C PRINT ANALYSIS OF VARIANCE C ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) CALL OANOVA(YSUM, RED, NPAR, RVAR, NNZW, PAR1, IPRT) C 376 CONTINUE IF (IPTOUT(4).EQ.0) RETURN C IF (NPAR.EQ.1) GO TO 450 NC = NC - 1 IDF1 = NNZW - NC GO TO 50 380 CONTINUE DO 400 I=1,NC T(I,I) = SQRT(T(I,1)) DO 390 J=I,NC IF (I.EQ.J) GO TO 390 T(I,J) = T(I,J)*T(I,I) 390 CONTINUE 400 CONTINUE C CALL STRDI(T, NPAR, NC, DET, 011, IER) C IF (IER.EQ.0) GO TO 420 WRITE (IPRT,1140) DO 410 I=1,NC PAR1(I) = 0.0E0 T(I,I) = 0.0E0 410 CONTINUE GO TO 450 420 CONTINUE DO 440 I=1,NC SM = 0.0E0 DO 430 K=I,NC SM = SM + T(I,K)*T(I,K) 430 CONTINUE T(I,I) = SM 440 CONTINUE C C PRINT PAGE HEADINGS C 450 CONTINUE ISUBHD = 0 CALL LLHDR(PAGE, WIDE, ISUBHD) C C PRINT VARIANCE COVARIANCE MATRIX C CALL VCVOUT(NPAR, VCV, NPAR, .TRUE.) C WRITE (IPRT,1030) IF (NPAR.GT.1) WRITE (IPRT,1040) WRITE (IPRT,1050) IF (NPAR.GT.1) WRITE (IPRT,1060) WRITE (IPRT, 1170) IF (NPAR.GE.2) THEN DO 460 I=1,NC SDC = SQRT(VCV(I,I)) RATIO = FPLM PROBT = 0.0E0 IF (SDC.GT.0.0E0) RATIO = PAR(I)/SDC IF (SDC.GT.0.0E0) + PROBT = (1.0E0-CDFT(ABS(RATIO), NNZW-NPAR)) * 2.0E0 SDC1 = SQRT(T(I,I))*SQRT(RVAR1) RATIO1 = FPLM PROBT1 = 0.0E0 IF (SDC1.GT.0.0E0) RATIO1 = PAR1(I)/SDC1 IF (SDC1.GT.0.0E0) + PROBT1 = (1.0E0 - CDFT(ABS(RATIO1), NNZW-NPAR+1)) * 2.0E0 WRITE (IPRT,1070) I, PAR(I), SDC, RATIO, PROBT, ACC(I), + PAR1(I), SDC1, RATIO1, PROBT1 460 CONTINUE END IF SDC = SQRT(VCV(NPAR,NPAR)) RATIO = FPLM PROBT = 0.0E0 IF (SDC.GT.0.0E0) RATIO = PAR(NPAR)/SDC IF (SDC.GT.0.0E0) + PROBT = (1.0E0 - CDFT(ABS(RATIO), NNZW-NPAR)) * 2.0E0 WRITE (IPRT,1070) NPAR, PAR(NPAR), SDC, RATIO, PROBT, ACC(NPAR) IF (NPAR.EQ.1) WRITE (IPRT,1080) RSD IF (NPAR.GT.1) WRITE (IPRT,1080) RSD, RSD1 WRITE (IPRT,1090) NNZW, NPAR, IDF IF (NPAR.GT.1) WRITE (IPRT,1100) NNZW, NC, IDF1 IF (CONST) WRITE (IPRT,1010) R2 WRITE (IPRT,1000) COND WRITE (IPRT,1110) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7) 1010 FORMAT (/44H MULTIPLE CORRELATION COEFFICIENT SQUARED , F7.4) 1020 FORMAT (//46H THE VALUES COMPUTED FOR THE PARAMETERS ARE - /(5X, + 4HPAR(, I3, 4H) = , G15.7)) 1030 FORMAT (////1X, 25('-'), 1X, 18HESTIMATES FROM FIT, 1X, 24('-')) 1040 FORMAT ('+', 72X, 4('-'), 1X, + 48HESTIMATES FROM FIT OMITTING LAST PREDICTOR VALUE, 1X, + 4('-')) 1050 FORMAT (/2X, 19HESTIMATED PARAMETER, 7X, 9HSD OF PAR, 5X, + 8HT(PAR=0), 3X, 7HPROB(T), 2X, 8HACC DIG*) 1060 FORMAT ('+', 72X, 19HESTIMATED PARAMETER, 7X, 9HSD OF PAR, 5X, + 8HT(PAR=0), 3X, 7HPROB(T)) 1070 FORMAT (1X, I3, 2X, G16.9, 3X, G16.9, 2X, G10.4, 1X, F5.3, 2X, + F7.1, 9X, G16.9, 3X, G16.9, 2X, G10.4, 1X, F5.3) 1080 FORMAT (//1X, 30HRESIDUAL STANDARD DEVIATION , 9X, G15.7, 56X, + G15.7) 1090 FORMAT (1X, 27HBASED ON DEGREES OF FREEDOM, 7X, I4, 3H - , I2, + 3H = , I4) 1100 FORMAT ('+', 105X, I4, 3H - , I2, 3H = , I4) 1110 FORMAT (//52H * THE NUMBER OF CORRECTLY COMPUTED DIGITS IN EACH P, + 56HARAMETER USUALLY DIFFERS BY LESS THAN 1 FROM THE VALUE G, + 10HIVEN HERE.) 1120 FORMAT (/47H THE PROGRAM WAS UNABLE TO COMPUTE THE VARIANCE, + 19H-COVARIANCE MATRIX./ + 52H THE DESIGN MATRIX IS EITHER NEARLY SINGULAR OR VERY, + 17H ILL CONDITIONED./ + 29H CHECK YOUR INPUT FOR ERRORS.) 1140 FORMAT (54H0ESTIMATES FOR THE STANDARD DEVIATION OF THE ESTIMATED, + 55HPARAMETERS OMITTING THE LAST INDEPENDENT VARIABLE COULD/ + 59H NOT BE COMPUTED. THE ZEROS PRINTED FOR THE ESTIMATES OF T, + 50HHE PARAMETERS, THEIR STANDARD DEVIATIONS AND THEIR/ + 59H RATIOS FOR THE FIT OMITTING THE LAST VARIABLE ARE MEANINGL, + 4HESS.) 1150 FORMAT (/30H THE DESIGN MATRIX IS SINGULAR, + 29H TO WITHIN MACHINE PRECISION./ + 50H CHECK THE DESIGN MATRIX FOR A LINEAR RELATIONSHIP, + 29H BETWEEN SOME OF THE COLUMNS.) 1160 FORMAT (//1X, 11('*')/ 1X, 11H* ERROR */ 1X, 11('*')) 1170 FORMAT (' ') 1180 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS, + 35H EXACT TO WITHIN MACHINE PRECISION./ + 38H STATISTICAL ANALYSIS IS NOT POSSIBLE.) END *LLSP SUBROUTINE LLSP(Y, XM, N, NDEG, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT C NO WEIGHTS SPECIFIED C NO STORAGE OTHER THAN RESIDUALS C FOUR PAGES AUTOMATIC PRINTOUT 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 + LDSTAK,N,NDEG C C ARRAY ARGUMENTS REAL + RES(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPAR,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTP C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEG C THE DEGREE OF THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(1) C A DUMMY ARRAY FOR C THE PARAMETERS TO BE ESTIMATED. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARDIZED RESIDUALS. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(1) C A DUMMY ARRAY FOR C THE WEIGHTS. C REAL XM(N,1) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','P',' ',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .FALSE. SAVE = .FALSE. NPRT = 1111 LPAR = 1 LPV = 1 LSDPV = 1 LSDRES = 1 IVCV = 1 LWT = 1 C CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 45H CALL LLSP (Y, X, N, NDEG, RES, LSDTAK)) END *LLSPS SUBROUTINE LLSPS(Y, XM, N, NDEG, RES, LDSTAK, + NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT C NO WEIGHTS SPECIFIED C FULL STORAGE C USER CONTROL OF AUTOMATIC PRINTOUT 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 REAL + RSD INTEGER + IVCV,LDSTAK,LPAR,N,NDEG,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LPV,LSDPV,LSDRES,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTP C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEG C THE DEGREE OF THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(LPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(N) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(1) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(N,1) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','P','S',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .FALSE. SAVE = .TRUE. LPV = N LSDPV = N LSDRES = N LWT = 1 C CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL LLSPS (Y, X, N, NDEG, RES, LSDTAK,'/ + ' + NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV,'/ + ' + SDRES, VCV, IVCV)') END *LLSPW SUBROUTINE LLSPW(Y, WT, XM, N, NDEG, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT C USER SUPPLIED WEIGHTS SPECIFIED C NO STORAGE OTHER THAN RESIDUALS C FOUR PAGES AUTOMATIC PRINTOUT 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 + LDSTAK,N,NDEG C C ARRAY ARGUMENTS REAL + RES(*),WT(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPAR,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTP C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEG C THE DEGREE OF THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(1) C A DUMMY ARRAY FOR C THE PARAMETERS TO BE ESTIMATED. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARDIZED RESIDUALS. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C A DUMMY ARRAY FOR C THE WEIGHTS. C REAL XM(N,1) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','P','W',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .TRUE. SAVE = .FALSE. NPRT = 1111 LPAR = 1 LPV = 1 LSDPV = 1 LSDRES = 1 IVCV = 1 LWT = N C CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 50H CALL LLSPW (Y, WT, X, N, NDEG, RES, LSDTAK)) END *LLSPWS SUBROUTINE LLSPWS(Y, WT, XM, N, NDEG, RES, LDSTAK, + NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR POLYNOMIAL MODEL LEAST SQUARES FIT C USER SUPPLIED WEIGHTS SPECIFIED C FULL STORAGE C USER CONTROL OF AUTOMATIC PRINTOUT 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 REAL + RSD INTEGER + IVCV,LDSTAK,LPAR,N,NDEG,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LPV,LSDPV,LSDRES,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTP C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NDEG C THE DEGREE OF THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(LPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(N) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(N) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(N,1) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','P','W','S'/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .TRUE. SAVE = .TRUE. LPV = N LSDPV = N LSDRES = N LWT = N C CALL LLCNTP(Y, WT, LWT, XM, N, NDEG, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL LLSPWS (Y, WT, X, N, NDEG, RES, LSDTAK,'/ + ' + NPRT, LPAR, PAR, NPAR, RSD, PV, SDPV,'/ + ' + SDRES, VCV, IVCV)') END *LLSS SUBROUTINE LLSS(Y, XM, N, IXM, NPAR, RES, LDSTAK, + NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT C NO WEIGHTS SPECIFIED C FULL STORAGE C USER CONTROL OF AUTOMATIC PRINTOUT 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 REAL + RSD INTEGER + IVCV,IXM,LDSTAK,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LPAR,LPV,LSDPV,LSDRES,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTG C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(NPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(N) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(1) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(IXM,NPAR) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','S',' ',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .FALSE. SAVE = .TRUE. LPAR = NPAR LPV = N LSDPV = N LSDRES = N LWT = 1 C CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL LLSS (Y, XM, N, IXM, NPAR, RES, LSDTAK,'/ + ' + NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)') END *LLSW SUBROUTINE LLSW(Y, WT, XM, N, IXM, NPAR, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT C USER SUPPLIED WEIGHTS SPECIFIED C NO STORAGE OTHER THAN RESIDUALS C FOUR PAGES AUTOMATIC PRINTOUT 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 + IXM,LDSTAK,N,NPAR C C ARRAY ARGUMENTS REAL + RES(*),WT(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LPAR,LPV,LSDPV,LSDRES,LWT,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PAR(1),PV(1),SDPV(1),SDRES(1),VCV(1,1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTG C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(1) C A DUMMY ARRAY FOR C THE PARAMETERS TO BE ESTIMATED. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARDIZED RESIDUALS. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C A DUMMY ARRAY FOR C THE WEIGHTS. C REAL XM(IXM,NPAR) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','W',' ',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .TRUE. SAVE = .FALSE. NPRT = 1111 LPAR = 1 LPV = 1 LSDPV = 1 LSDRES = 1 IVCV = 1 LWT = N C CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL LLSW (Y, WT, XM, N, IXM, NPAR, RES, LSDTAK)') END *LLSWS SUBROUTINE LLSWS(Y, WT, XM, N, IXM, NPAR, RES, LDSTAK, + NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C CALL FOR GENERAL LINEAR MODEL LEAST SQUARES FIT C USER SUPPLIED WEIGHTS SPECIFIED C FULL STORAGE C USER CONTROL OF AUTOMATIC PRINTOUT 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 REAL + RSD INTEGER + IVCV,IXM,LDSTAK,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SDPV(*),SDRES(*),VCV(*),WT(*),XM(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LPAR,LPV,LSDPV,LSDRES,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LLCNTG C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 DESIGNATING WHETHER ANY ERRORS WERE C DETECTED IN THE PARAMETER LIST. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED. C IF IERR .EQ. 1, ERRORS WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE FIRST DIMENSION OF THE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE MATRIX XM. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPAR C THE ACTUAL LENGTH OF THE VECTOR P. C INTEGER LPV C THE ACTUAL LENGTH OF THE VECTOR PV. C INTEGER LSDPV C THE ACTUAL LENGTH OF THE VECTOR SDPV. C INTEGER LSDRES C THE ACTUAL LENGTH OF THE VECTOR SDRES. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NPRT C THE INDICATOR VARIABLE USED TO DESIGNATE THE AMOUNT OF C PRINTED OUTPUT. C REAL PAR(NPAR) C THE PARAMETERS TO BE ESTIMATED. C REAL PV(N) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C LOGICAL SAVE C THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN C THE RESIDUALS ARE TO VE SAVED (TRUE) OR NOT (FALSE). C REAL SDPV(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL WT(N) C THE WEIGHTS (A DUMMY VECTOR IN THE UNWEIGHTED CASE). C REAL XM(IXM,NPAR) C THE INDEPENDENT VARIABLE. C REAL Y(N) C THE DEPENDENT VARIABLE. C C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'L','L','S','W','S',' '/ C C SET PARAMETERS NECESSARY FOR THE COMPUTATIONS C WEIGHT = .TRUE. SAVE = .TRUE. LPAR = NPAR LPV = N LSDPV = N LSDRES = N LWT = N C CALL LLCNTG(Y, WT, LWT, XM, N, IXM, NPAR, RES, LDSTAK, NPRT, + PAR, LPAR, RSD, PV, LPV, SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, + NMSUB, WEIGHT, SAVE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL LLSWS (Y, WT, XM, N, IXM, NPAR, RES, LSDTAK,'/ + ' + NPRT, PAR, RSD, PV, SDPV, SDRES, VCV, IVCV)') 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 REAL + D(P),G(P),QTR(P),R(1),STEP(P),V(21),W(1) INTEGER + IPIVOT(P) C C LOCAL SCALARS REAL + 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 REAL + 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 REAL 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 REAL 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 REAL 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 REAL DOTPRD, V2NORM C C *** SUBSCRIPTS FOR V *** C C INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC, C 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR 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.0E0/, EIGHT/8.0E0/, HALF/0.5E0/, NEGONE/-1.0E0/, + ONE/1.0E0/, P001/1.0E-3/, THREE/3.0E0/, TTOL/2.5E0/, + ZERO/0.0E0/ 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.0E0 PSIFAC = 0.0E0 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 *LOGLMT SUBROUTINE LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMROW, ISTEP, DELY, + YWIDTH, NLABLY, YDMN, YDMX) C C LATEST REVISION - 03/15/90 (JRD) C C ADJUST PLOT LIMITS FOR LOG PLOTS, AND COMPUTE LOG AXIS LABELS 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 REAL + DELY,YDMN,YDMX,YMN,YMX,YWIDTH INTEGER + ILOGY,ISTEP,NLABLY,NUMROW C C ARRAY ARGUMENTS REAL + YLABEL(20) C C LOCAL SCALARS REAL + YNLOG,YXLOG INTEGER + IYN,IYNLOG,IYX,IYXLOG,J,K C C INTRINSIC FUNCTIONS INTRINSIC LOG10,MIN,MOD,NINT,REAL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELY C INTEGER ILOGY, ISTEP, IYN, IYNLOG, IYX, IYXLOG, J, K C INTEGER NLABLY, NUMROW C REAL YLABEL(20) C THE Y-AXIS LABLES. C REAL YDMN, YDMX C THE Y-AXIS DATA LIMITS ACTUALLY USED. C REAL YMN, YMX C THE Y-AXIS PLOT LIMITS ACTUALLY USED. C REAL YNLOG, YWIDTH, YXLOG C IF (ILOGY.EQ.0) THEN C YDMN = YMN YDMX = YMX C C DETERMINE THE VALUE OF A DIVISION C DELY=YMX-YMN YWIDTH=DELY/(NUMROW-1) C C COMPUTE EVENLY SPACED LABELS FOR NON-LOG AXIS C NLABLY = 0 DO 10 J = 1, NUMROW, ISTEP NLABLY = NLABLY + 1 YLABEL(NLABLY) = YMX+(1-J)*YWIDTH 10 CONTINUE IF (MOD(NUMROW,ISTEP).EQ.1) YLABEL(NLABLY) = YMN IF (YMX.EQ.(-YMN) .AND. MOD(NLABLY,2).EQ.1) THEN YLABEL(NLABLY/2+1) = 0.0 END IF ELSE C YDMN = LOG10(YMN) YDMX = LOG10(YMX) C C ADJUST AXIS LIMITS FOR LOG AXIS IF NECESSARY C YXLOG=LOG10(YMX) IYXLOG=YXLOG IF (YMX.LT.1.0E0) IYXLOG=IYXLOG-1 YNLOG=LOG10(YMN) IF ((YXLOG-YNLOG).LE.0.92082E0) THEN C C RANGE IS LESS THAN .9 DECADES C IYNLOG=YNLOG IF (YMN.LT.1.0E0) IYNLOG=IYNLOG-1 IF (IYXLOG.LE.IYNLOG) THEN C C VALUES FALL IN THE SAME DECADE C YNLOG=IYNLOG YXLOG=YNLOG+1.0E0 IYXLOG=YXLOG ELSE C C VALUES FALL INTO TWO DECADES C IYN=NINT(YMN/(10.0E0**IYNLOG)) YNLOG=MIN(LOG10(IYN*(10.0E0**IYNLOG)),YNLOG) YXLOG=YNLOG+1.0E0 IYXLOG=YXLOG END IF END IF YMX=YXLOG YMN=YNLOG C C DETERMINE THE VALUE OF A DIVISION C DELY=YMX-YMN YWIDTH=DELY/(NUMROW-1) C C COMPUTE AXIS LABELS C YLABEL(1)=10.0E0**YXLOG IYX=YLABEL(1)/(10.0E0**IYXLOG) K=2 IF (YXLOG-YNLOG.GT.3.0E0) K=5 IF (YXLOG-YNLOG.GT.6.0E0) K=10 C NLABLY = 1 C IF (YXLOG-YNLOG.LE.12.0E0) THEN C C SET NICE LABELS C IF (K.EQ.10) IYX=1 IF (IYX.NE.1.AND.(IYX-((IYX/K)*K)).NE.0) IYX=((IYX/K)*K) IF (IYX.LE.1) THEN IYX=10 IYXLOG=IYXLOG-1 END IF IF (YLABEL(1)-IYX*(10.0E0**IYXLOG).GT.0.0E0 .AND. + YXLOG-(YXLOG-YNLOG)/(2.0E0*(NUMROW-1)) .GT. + LOG10(REAL(IYX))+IYXLOG) IYX=IYX+K IYX=IYX-K IF (IYX.LE.0) THEN IYX=10 IYXLOG=IYXLOG-1 END IF DO 155 J=2,20 NLABLY=NLABLY+1 YLABEL(NLABLY)=IYX*(10.0E0**IYXLOG) IF (YLABEL(NLABLY).LE.10.0E0**YNLOG) GO TO 156 IYX=IYX-K IF (IYX.GT.0) GO TO 155 IYX=10 IYXLOG=IYXLOG-1 155 CONTINUE 156 YLABEL(NLABLY)=10.0E0**YNLOG ELSE C C COMPUTE EVENLY SPACED LABELS C DO 160 J = ISTEP, NUMROW, ISTEP NLABLY = NLABLY + 1 YLABEL(NLABLY) = 10.0E0**(YMX+(1.0E0-J)*YWIDTH) 160 CONTINUE END IF END IF C RETURN END *LOPASS SUBROUTINE LOPASS (Y, N, FC, K, HLP, YF, NYF) 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 REAL + FC INTEGER + K,N,NYF C C ARRAY ARGUMENTS REAL + HLP(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT 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,IPRINT,LPFLT C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. 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.0E0, 0.5E0, 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 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C CALL LPFLT (FC, K, HLP) C CALL FLTSL (Y, N, K, HLP, YF, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 46H CALL LOPASS (Y, N, FC, K, HLP, YF, NYF)) END *LPCOEF SUBROUTINE LPCOEF (FC, K, HLP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES THE K-TERM LEAST SQUARES C APPROXIMATION TO AN -IDEAL- LOW PASS 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 REAL + FC INTEGER + K C C ARRAY ARGUMENTS REAL + HLP(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,ERR02,ERR03,ERR04,HEAD C C LOCAL ARRAYS CHARACTER + LFC(8)*1,LK(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISII,ERIODD,ERSII,ERSLFS,IPRINT,LPFLT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL 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 REAL HLP(K) C THE ARRAY IN WHICH THE -IDEAL- LOW 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) C THE ARRAY CONTAINING THE NAMES OF THE VARIABLES FC AND K. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'L', 'P', 'C', 'O', 'E', 'F'/ 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', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL ERSII(NMSUB, LFC, FC, 0.0E0, 0.5E0, 2, HEAD, ERR01, LFC, LFC) C CALL EISII(NMSUB, LK, K, 1, K, 2, HEAD, ERR02, LK, LK) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03) C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10 C CALL ERSLFS(NMSUB, FC, K, HEAD, ERR04) C IF (.NOT. ERR04) GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C CALL LPFLT (FC, K, HLP) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 31H CALL LPCOEF (FC, K, HLP)) 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 REAL + FC INTEGER + K C C ARRAY ARGUMENTS REAL + HLP(K) C C LOCAL SCALARS REAL + 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 REAL ARG, CON C VARIABLES USED IN THE COMPUTATION OF THE LOW PASS FILTER C COEFFICIENTS. C REAL FC C THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER. C REAL 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 REAL PI C THE VALUE OF PI. C REAL SUM C A VALUE USED FOR SUMMING. C CALL GETPI(PI) C KMID = (K + 1) / 2 C HLP(KMID) = 1.0E0 C IF (K .EQ. 1) RETURN C HLP(KMID) = 2.0E0 * FC CON = 2.0E0 * 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.0E0 * 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 *LSQRT SUBROUTINE LSQRT(N1, N, L, A, IRC) 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 REAL + A(1),L(1) C C LOCAL SCALARS REAL + 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 REAL 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 REAL T, TD, ZERO C C/ DATA ZERO/0.0E0/ 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 LSQRT *** END *LSTLAG INTEGER FUNCTION LSTLAG (NLPPA, LAGMAX, LACOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE FINDS THE LAG VALUE OF THE LAST AUTOCOVARIANCE C COMPUTED BEFORE ONE COULD NOT BE COMPUTED DUE TO MISSING DATA. C C WRITTEN BY - JANET R. DONALDSON 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 + LACOV,LAGMAX C C ARRAY ARGUMENTS INTEGER + NLPPA(LACOV) C C LOCAL SCALARS INTEGER + LAG C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAG C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCORRELATION. C INTEGER NLPPA(LACOV) C THE ARRAY CONTAINING THE NUMBERS OF LAGGED PRODUCT PAIRS C USED TO COMPUTE THE ACVF AT EACH LAG. C C FIND THE LAST AUTOCORRELATION TO BE COMPUTED BEFORE C ONE COULD NOT BE COMPUTED DUE TO MISSING DATA C LSTLAG = -1 IF (NLPPA(1) .LE. 0) RETURN DO 20 LAG = 1, LAGMAX IF (NLPPA(LAG + 1) .GE. 1) GO TO 20 LSTLAG = LAG - 1 RETURN 20 CONTINUE LSTLAG = LAGMAX 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 REAL + VEC(N) INTEGER + MASK(LMASK) C C LOCAL SCALARS INTEGER + I,IMASK,IMAX,IMIN,INDEX,IPRT,J,JMAX,NPERL C C LOCAL ARRAYS INTEGER + INDW(10) C C EXTERNAL FUNCTIONS INTEGER + INPERL EXTERNAL INPERL C C EXTERNAL SUBROUTINES 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 REAL VEC(N) C THE VECTOR OF VALUES TO BE PRINTED. C CALL IPRINT(IPRT) C NPERL = INPERL(0) C NOTE - INPERL(0) IS ASSUMED TO BE AT MOST 10.0E0 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(IPRT, 1010) (INDW(INDEX), INDEX = 1, JMAX) WRITE(IPRT, 1020) (VEC(INDEX), INDEX = IMIN, IMAX) 30 CONTINUE C RETURN C 40 WRITE (IPRT, 1030) RETURN C C FORMAT STATEMENTS C 1010 FORMAT(10X, 5HINDEX, I5, 6I15) 1020 FORMAT(10X, 5HVALUE, 7(1X, G14.7)/) 1030 FORMAT (/47H ERROR IN STARPAC. LSTVEC TRIED TO ACCESS MORE, + 29H ELEMENTS THAN EXIST IN MASK.) C END *LSTVEC SUBROUTINE LSTVEC(N, VEC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE INDICES AND ELEMENT VALUES C OF THE VECTOR VEC. 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 + N C C ARRAY ARGUMENTS REAL + VEC(N) C C LOCAL SCALARS INTEGER + I,IMAX,IMIN,INDEX,IPRT,NPERL C C EXTERNAL FUNCTIONS INTEGER + INPERL EXTERNAL INPERL C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER IMAX, IMIN C THE LARGEST AND SMALLEST INDEX VALUE TO BE PRINTED ON EACH C LINE. C INTEGER INDEX C THE INDEX VALUE TO BE PRINTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. 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 REAL VEC(N) C THE VECTOR OF VALUES TO BE PRINTED. C CALL IPRINT(IPRT) C NPERL = INPERL(0) C DO 10 I = 1, N, NPERL IMIN = I IMAX = MIN(I+NPERL-1, N) WRITE(IPRT, 1010) (INDEX, INDEX = IMIN, IMAX) WRITE(IPRT, 1020) (VEC(INDEX), INDEX = IMIN, IMAX) 10 CONTINUE C RETURN C C FORMAT STATEMENTS C 1010 FORMAT(10X, 5HINDEX, I5, 6I15) 1020 FORMAT(10X, 5HVALUE, 7(1X, G14.7)/) C END *LSVMIN REAL 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 REAL + L(1),X(P),Y(P) C C LOCAL SCALARS REAL + 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 REAL + V2NORM EXTERNAL V2NORM C C INTRINSIC FUNCTIONS INTRINSIC ABS,MOD C C *** PARAMETER DECLARATIONS *** C C INTEGER P C REAL 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 REAL B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS C C *** CONSTANTS *** C C REAL HALF, ONE, R9973, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL V2NORM C REAL V2NORM C DATA IX/2/ DATA HALF/0.5E0/, ONE/1.0E0/, R9973/9973.0E0/, ZERO/0.0E0/ 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 *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 REAL + A(*),L(*) C C LOCAL SCALARS REAL + LII,LJ INTEGER + I,I1,II,IIM1,J,K,M C C INTEGER N C REAL 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 REAL LII, LJ 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 *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 REAL + J(N,P),URPARM(*),X(P) INTEGER + UIPARM(*) C C SUBROUTINE ARGUMENTS EXTERNAL UFPARM C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN C J(1,1) = 2.0E0*X(1) + X(2) J(1,2) = 2.0E0*X(2) + X(1) J(2,1) = COS(X(1)) J(2,2) = 0.0E0 J(3,1) = 0.0E0 J(3,2) = -SIN(X(2)) 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 REAL + R(N),URPARM(*),X(P) INTEGER + UIPARM(*) C C SUBROUTINE ARGUMENTS EXTERNAL UFPARM C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN 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 *MAFLT SUBROUTINE MAFLT (Y, N, K, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS A SIMPLE MOVING AVERAGE FILTERING C OPERATION ON AN INPUT SERIES Y, RETURNING THE FILTERED SERIES C IN YF. 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,N,NYF C C ARRAY ARGUMENTS REAL + Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + HMA INTEGER + IPRT LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS CHARACTER + LK(8)*1,LN(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERIODD,FLTMA,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03 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 REAL HMA C THE VALUE OF EACH OF THE SIMPLE MOVING AVERAGE LINEAR FILTER C COEFFICIENTS. 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. C CHARACTER*1 LK(8), LN(8), LONE(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'A', 'F', 'L', 'T', ' '/ 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', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7), + LONE(8) / ' ', ' ', 'O', 'N', 'E', ' ', ' ', ' '/ 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 EISII(NMSUB, LK, K, 1, N, 1, HEAD, ERR02, LONE, LN) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03) C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C C COMPUTE THE SIMPLE MOVING AVERAGE COEFFICIENTS C HMA = K HMA = 1.0E0/HMA C CALL FLTMA (Y, N, K, HMA, YF, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MAFLT (Y, N, K, YF, NYF)') END *MATPRF SUBROUTINE MATPRF(X, Y, NC, MODE, CODE, LENGTH, MASK, LMASK) C C LATEST REVISION - 03/15/90 (JRD) C C THISROUTINE 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 REAL + X(LENGTH),Y(LENGTH) INTEGER + MASK(LMASK) C C LOCAL SCALARS REAL + SQXII,SQYII INTEGER + I,I0,II,IK,IMASK,IPRT,J,JMASK,K,KI,KK,KM,KMAX,KN,L,NF, + NLINE C C LOCAL ARRAYS REAL + XLINE(10),YLINE(10) INTEGER + INDW(10) C C EXTERNAL FUNCTIONS INTEGER + INPERL EXTERNAL INPERL C C EXTERNAL SUBROUTINES 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 REAL SQXII, SQYII C THE SQUARE ROOT OF THE (I,I)TH ELEMENT OF X AND Y. C REAL X(LENGTH) C INPUT SYMMETRIC ARRAY STORED ROW WISE C REAL XLINE(10) C THE CURRENT VALUES BEING PRINTED FROM ARRAY X. C REAL Y(LENGTH) C ARRAY TO BE PRINTED ON THE SECOND LEVEL IF CODE=2 C REAL YLINE(10) C THE CURRENT VALUES BEING PRINTED FROM ARRAY Y. C C BODY OF ROUTINE C 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 (IPRT,1000) (INDW(K),K=1,KMAX) WRITE (IPRT,1030) 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.0E0 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 (IPRT,1010) IMASK, (XLINE(K),K=1,NLINE) IF (CODE.EQ.2) WRITE (IPRT,1020) (YLINE(K),K=1,NLINE) IF (CODE.EQ.2) WRITE (IPRT,1030) 80 CONTINUE 90 CONTINUE RETURN C 100 WRITE (IPRT,1040) RETURN C C FORMAT STATEMENTS C C 1000 FORMAT (/' ', 7HCOLUMN , 7(I9, 8X)) 1010 FORMAT (' ', I6, 1X, 7(3X, G14.7)) 1020 FORMAT (' ', 5X, 7(3X, G14.7)) 1030 FORMAT (' ') 1040 FORMAT (/47H ERROR IN STARPAC. MATPRF TRIES TO ACCESS MORE, + 29H ELEMENTS THAN EXIST IN MASK.) END *MATPRT SUBROUTINE MATPRT (X, Y, NC, IPRT, MODE, CODE, IRDIM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE TAKES A SQUARE MATRIX AND PRINTS EITHER ITS C LOWER TRIANGULAR PART OR THE FULL MATRIX WITH OR WITHOUT DOUBLE C PRINTING. C C WRITTEN BY - LINDA L. MITCHELL C STATISTICAL ENGINEERING LAB/BOULDER C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + CODE,IPRT,IRDIM,MODE,NC C C ARRAY ARGUMENTS REAL + X(IRDIM,NC),Y(IRDIM,NC) C C LOCAL SCALARS REAL + TEMP INTEGER + I,IWIDTH,J,K,KM,KN,L,NF C C INTRINSIC FUNCTIONS INTRINSIC MIN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CODE C IF 1 -SINGLE PRINTED LINE, X ONLY (Y IS DUMMY ARG) C 2 -DOUBLE PRINTED LINE, BOTH X AND Y C INTEGER I C ROW NUMBER C INTEGER IPRT C THE OUTPUT UNIT NUMBER C INTEGER IRDIM C ROW INDEX OF X C INTEGER IWIDTH C THE WIDTH OF THE OUTPUT DEVICE. C INTEGER J C FIRST COLUMN IN THE SET TO BE PRINTED C INTEGER K C COLUMN NUMBER IN THE POSSIBLE SET OF NF 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 KN C LAST COLUMN TO PRINT WHEN PRINTING LOWER TRIANGLE C INTEGER L C FIRST ROW TO PRINT FOR THIS SET C INTEGER MODE C IF 0, LOWER TRIANGULAR PART PRINTED C 1, FULL MATRIX PRINTED C 2, LOWER TRIANGULAR PART IS PRINTED WITH C SQUARE ROOTS OF 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 REAL TEMP C A TEMPORARY LOCATION C REAL X(IRDIM,NC) C NC BY NC INPUT MATRIX C REAL Y(IRDIM,NC) C MATRIX TO BE PRINTED ON THE SECOND LEVEL IF CODE=2 C IWIDTH = 132 NF = MIN(7, (IWIDTH - 7)/17) L = 1 DO 20 J=1,NC, NF KN = MIN(NC, J+NF-1) WRITE(IPRT,1000) (K,K=J,KN) WRITE(IPRT,1030) IF ((MODE.EQ.00) .OR. (MODE.EQ.2)) L = J DO 10 I=L,NC TEMP = X(I,I) KM = KN IF ((MODE.EQ.0) .OR. (MODE.EQ.2)) + KM = J + MIN(I-L, NF-1) IF ((MODE.EQ.2) .AND. ((I.GE.J) .AND. (I.LE.KM))) + X(I,I) = SQRT(X(I,I)) WRITE(IPRT,1010) I, (X(I,K),K=J,KM) IF (CODE.EQ.2) WRITE(IPRT,1020) (Y(I,K),K=J,KM) IF (CODE.EQ.2) WRITE(IPRT,1030) X(I,I) = TEMP 10 CONTINUE 20 CONTINUE RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/4X, 7HCOLUMN , 7(I9, 8X)) 1010 FORMAT (4X, I6, 1X, 7(3X, G14.8)) 1020 FORMAT (9X, 7(3X, G14.8)) 1030 FORMAT (4X) END *MDFLT SUBROUTINE MDFLT (PER, NF, NK, KMD, PERF, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR APPLYING MODIFIED C DANIEL FILTERS TO A SYMMETRIC SERIES. C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,NF,NK C C ARRAY ARGUMENTS REAL + PER(*),PERF(*) INTEGER + KMD(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + SYM INTEGER + I,IPRT,L,LDSMIN,NALL0,WORK LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LKMD(8)*1,LLDS(8)*1,LNF(8)*1,LNK(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EIVEO,FLTMD,IPRINT,LDSCMP,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES 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 LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED. C INTEGER IPRT C THE LOGICAL UNIT NUMBER USED FOR OUTPUT. C INTEGER KMD(NK) C THE ARRAY OF FILTER LENGTHS. C CHARACTER*1 LKMD(8), LLDS(8), LNK(8), LNF(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING STACK ALLOCATIONS C INTEGER NF C THE NUMBER OF POINTS IN THE SERIES TO BE FILTERED. C INTEGER NK C THE NUMBER OF FILTERS TO BE APPLIED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C REAL PER(NF) C THE INPUT SERIES TO BE FILTERED. C REAL PERF(NF) C THE FILTERED SERIES. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SYM C AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SERIES C IS SYMMETRIC (SYM = 1.0E0) OR NOT (SYM = -1.0E0). C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR THE WORK VECTOR. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'D', 'F', 'L', 'T', ' '/ DATA + LKMD(1), LKMD(2), LKMD(3), LKMD(4), LKMD(5), + LKMD(6), LKMD(7), LKMD(8) /'K','M','D',' ',' ',' ',' ',' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), + LNF(6), LNF(7), LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/ DATA + LNK(1), LNK(2), LNK(3), LNK(4), LNK(5), + LNK(6), LNK(7), LNK(8) /'N','K',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LNF, NF, 17, 1, HEAD, ERR01, LNF) C CALL EISGE(NMSUB, LNK, NK, 1, 1, HEAD, ERR02, LNK) C IF (.NOT.ERR02) CALL EIVEO(NMSUB, LKMD, KMD, NK, .TRUE., HEAD) C IF (ERR01) GO TO 10 C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NF, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR03, LLDS) C IF ((.NOT.ERR02) .AND. (.NOT.ERR03)) GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C C SUBDIVIDE THE WORK AREA C WORK = STKGET(NF, 3) C C DESIGNATE THE SERIES IS SYMMETRIC C SYM = 1.0E0 C DO 30 I = 1, NF PERF(I) = PER(I) 30 CONTINUE C DO 40 L = 1, NK CALL FLTMD(PERF, RSTAK(WORK), NF, KMD(L), SYM) 40 CONTINUE C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MDFLT (PER, NF, NK, KMD, PERF, LDSTAK)') END *MDL1 SUBROUTINE MDL1(PAR, NPAR, XM, N, M, IXM, PV) C C LATEST REVISION - 03/15/90 (JRD) C C MODEL FUNCTION FOR NLS EXERCISER 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 REAL + PAR(NPAR),PV(N),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL PAR(NPAR) C MODEL PARAMETERS C INTEGER I C ROW INDEX C INTEGER IXM C ACTUAL FIRST DIMENSION OF XM C INTEGER M C NUMBER OF VARIABLES C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NPAR C NUMBER OF PARAMETERS C REAL PV(N) C PREDICTED VALUES C REAL XM(IXM,M) C INDEPENDENT VARIABLES C DO 10 I=1,N PV(I) = PAR(1)*XM(I,1)**PAR(2) 10 CONTINUE RETURN END *MDL2 SUBROUTINE MDL2(PAR, NPAR, XM, N, M, IXM, PV) C C LATEST REVISION - 03/15/90 (JRD) C C MODEL FUNCTION FOR NLS EXERCISER 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 REAL + PAR(NPAR),PV(N),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C ROW INDEX C INTEGER IXM C ACTUAL FIRST DIMENSION OF XM C INTEGER M C NUMBER OF VARIABLES C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NPAR C NUMBER OF PARAMETERS C REAL PAR(NPAR) C MODEL PARAMETERS C REAL PV(N) C PREDICTED VALUES C REAL XM(IXM,M) C INDEPENDENT VARIABLES C DO 10 I=1,N PV(I) = PAR(1)*XM(I,1) + PAR(2)*XM(I,2) + PAR(3)*XM(I,3)**3 10 CONTINUE RETURN END *MDL3 SUBROUTINE MDL3(PAR, NPAR, XM, N, M, IXM, PV) C C LATEST REVISION - 03/15/90 (JRD) C C MODEL FUNCTION FOR NLS EXERCISER 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 REAL + PAR(NPAR),PV(N),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C ROW INDEX C INTEGER IXM C ACTUAL FIRST DIMENSION OF XM C INTEGER M C NUMBER OF VARIABLES C INTEGER N C NUMBER OF OBSERVATIONS C INTEGER NPAR C NUMBER OF PARAMETERS C REAL PAR(NPAR) C MODEL PARAMETERS C REAL PV(N) C PREDICTED VALUES C REAL XM(IXM,M) C INDEPENDENT VARIABLES C DO 10 I=1,N PV(I) = PAR(1)*XM(I,1) + PAR(2)*XM(I,2) + PAR(3)*XM(I,3) + + PAR(4)*XM(I,4) + PAR(5)*XM(I,5) 10 CONTINUE RETURN END *MDL4 SUBROUTINE MDL4 (PAR, NPAR, XM, N, M, IXM, PV) C C LATEST REVISION - 03/15/90 (JRD) C C MODEL ROUTINE FOR STEP SIZE AND DERIVATIVE CHECKING 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 + IXM,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(NPAR),PV(N),XM(IXM,M) C C LOCAL SCALARS INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC EXP 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 M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS OF DATA. C INTEGER NPAR C THE NUMBER OF UNKNOWN COEFFICIENTS IN THE MODEL. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C COEFFICIENTS ARE STORED. C REAL PV(N) C THE PREDICTED VALUES FROM THE FIT. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C DO 10 I = 1, N PV(I) = PAR(1) + PAR(3)*EXP(-((XM(I,1)-PAR(2))**2)/PAR(4)) 10 CONTINUE C RETURN C 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 REAL + 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 REAL + PMU INTEGER + I,I1 C C LOCAL ARRAYS REAL + 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 REAL 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 REAL PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C REAL RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C REAL RSTAK(12) C THE REAL 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 REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. 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 *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 REAL + PMU INTEGER + IFLAG,MBO,N,N1,N2,NFAC,NPAR,NPARDF C C ARRAY ARGUMENTS REAL + PAR(NPAR),PARAR(*),PARDF(*),PARMA(*),RESTS(N1:N2),T(*), + TEMP(*),Y(N) INTEGER + MSPECT(NFAC,4) C C LOCAL SCALARS REAL + FPLPM,RESMAX,WTEST INTEGER + I,IMOD,IMOD1,IPAR,IPQ,ISTART,J,K,L,MAXORD,MBO1,NP,NPARAR, + NPARMA LOGICAL + PARLE1 C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,MOD,SIGN,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PARAR(MBO) C THE AUTOREGRESSIVE PARAMETERS C REAL 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 REAL PARMA(MBO) C THE MOVING AVERAGE PARAMETERS C REAL PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C REAL RESMAX C THE LARGEST POSSIBLE RESIDUAL WHICH WILL STILL AVOID OVERFLOW. C REAL RESTS(N1:N2) C THE PREDICTED VALUE OF THE FIT. C REAL T(2*MBO) C A TEMPORARY WORK VECTOR. C REAL TEMP(MBO) C A TEMPORARY WORK VECTOR C REAL WTEST C THE TEST VALUE USED TO DETERMINE IF THE DIFFERENCED SERIES C BACK FORECAST IS EFFECTIVELY ZERO OR NOT. C REAL Y(N) C THE DEPENDENT VARIABLE. C FPLPM = R1MACH(2) C C ZERO THE PARAMETER ARRAYS PARAR AND PARMA C DO 10 I=1,MBO T(I) = 0.0E0 TEMP(I) = 0.0E0 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.0E0 TEMP(K) = 0.0E0 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.0E0) 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.0E0 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.0E0 .AND. T(IMOD1).NE.0.0E0) THEN IF (LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT. + LOG(FPLPM) + .AND. + (SIGN(1.0E0,T(IMOD)).NE. + SIGN(1.0E0,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.0E0 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 *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 REAL + 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 REAL + PMU C C LOCAL ARRAYS REAL + 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 REAL 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 REAL PMU C THE VALUE OF MU, I.E., THE TREND OR MEAN. C REAL RESTS(NRESTS) C THE RESIDUALS FROM THE ARIMA MODEL. C REAL RSTAK(12) C THE REAL 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 REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. 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 RETURN END *MGS SUBROUTINE MGS(A, B, N, NP, X, C, D, R, IR, IA, IER) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE SOLUTION X TO THE LINEAR SYSTEM OF C EQUATIONS AX=B, USING THE METHOD OF MODIFIED GRAM-SCHMIDT. C THE MATRIX A IS DECOMPOSED INTO THREE MATRICES C Q AN ORTHOGONAL MATRIX C D A DIAGONAL MATRIX AND C R AN UPPER TRIANGULAR MATRIX C THE SOLUTION VECTOR X IS THE VECTOR WHICH SOLVES THE SYSTEM C OF EQUATIONS RX = C C X, A, AND B ARE NOT PRESERVED ON OUTPUT C C ADAPTED FROM OMNITAB II BY - C JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IA,IER,IR,N,NP C C ARRAY ARGUMENTS REAL + A(IA,NP),B(N),C(NP),D(NP),R(IR,NP),X(NP) C C LOCAL SCALARS REAL + SM1,SM2 INTEGER + I,J,JJ,K,NPJJMJ C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL A(IA,NP) C THE COEFFICIENTS MATRIX (NOT PRESERVED ON OUTPUT) C REAL B(N) C THE CONSTANT COLUMN MATRIX OF THE SYSTEM (NOT PRESERVED C ON OUTPUT) C REAL C(NP) C THE MATRIX C DESCRIBED ABOVE C REAL D(NP) C THE DIAGONAL ELEMENTS OF THE MATRIX D DESCRIBED ABOVE C INTEGER I C * C INTEGER IA C THE ROW DIMENSION OF A. C INTEGER IER C * C INTEGER IR C THE ROW DIMENSION OF R. C INTEGER J C * C INTEGER JJ C * C INTEGER K C * C INTEGER N C THE NUMBER OF OBSERVATIONS C INTEGER NP C THE NUMBER OF PARAMETERS C INTEGER NPJJMJ C * C REAL R(IR,NP) C THE UPPER ELEMENTS OF THE MATRIX R DESCRIBED ABOVE C REAL SM1 C * C REAL SM2 C * C REAL X(NP) C THE SOLUTION MATRIX C C IER = 0 C SM1 = 0.0E0 SM2 = 0.0E0 DO 10 I=1,N SM1 = A(I,1)*A(I,1) + SM1 SM2 = A(I,1)*B(I) + SM2 10 CONTINUE IF (SM1.EQ.0.0E0) GO TO 100 D(1) = SM1 C(1) = SM2/SM1 IF (NP.EQ.1) GO TO 70 DO 60 K=2,NP DO 40 J=K,NP SM1 = 0.0E0 DO 20 I=1,N SM1 = A(I,K-1)*A(I,J) + SM1 20 CONTINUE R(K-1,J) = SM1/D(K-1) DO 30 I=1,N A(I,J) = A(I,J) - A(I,K-1)*R(K-1,J) 30 CONTINUE 40 CONTINUE SM1 = 0.0E0 SM2 = 0.0E0 DO 50 I=1,N B(I) = B(I) - A(I,K-1)*C(K-1) SM1 = A(I,K)*A(I,K) + SM1 SM2 = A(I,K)*B(I) + SM2 50 CONTINUE IF (SM1.EQ.0.0E0) GO TO 100 D(K) = SM1 C(K) = SM2/SM1 60 CONTINUE C C COMPLETE BACKSOLVE C 70 X(NP) = C(NP) IF (NP.EQ.1) RETURN DO 90 I=2,NP K = NP + 1 - I JJ = K + 1 SM1 = 0.0E0 DO 80 J=JJ,NP NPJJMJ = NP + JJ - J SM1 = R(K,NPJJMJ)*X(NPJJMJ) + SM1 80 CONTINUE X(K) = C(K) - SM1 90 CONTINUE RETURN 100 IER = 1 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 INTEGER + I,IPRT,J C C EXTERNAL SUBROUTINES 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 C CALL IPRINT(IPRT) C C PRINT MODEL SPECIFICATION C WRITE(IPRT, 1002) (I, (MSPECT(I,J),J=1,4), I=1,NFAC) C RETURN C C FORMAT STATEMENTS C 1002 FORMAT(// + ' MODEL SPECIFICATION'// + ' FACTOR (P D Q) S'// + (7X, I6, 6X, 4I6)) END *MPPC SUBROUTINE MPPC(YM, X, N, M, IYM, ILOG, ISIZE, NOUT, YLB, YUB, + XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,ISIZE,IYM,M,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XMISS INTEGER + IPRT,ISCHCK,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', 'C', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C XMISS = 1.0E0 MULTI = .TRUE. ISCHCK = 2 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPPC (YM, X, N, M, IYM, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *MPP SUBROUTINE MPP(YM, X, N, M, IYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IYM,M,N C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,LISYM,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C XMISS = 1.0E0 MULTI = .TRUE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 2 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPP (YM, X, N, M, IYM)') END *MPPL SUBROUTINE MPPL(YM, X, N, M, IYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,IYM,M,N C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,LISYM,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', 'L', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C XMISS = 1.0E0 MULTI = .TRUE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 2 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YM, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPPL (YM, X, N, M, IYM, ILOG)') END *MPPMC SUBROUTINE MPPMC(YM, YMMISS, X, XMISS, N, M, IYM, ILOG, ISIZE, + NOUT, YLB, YUB, XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING C OBSERVATIONS (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,ISIZE,IYM,M,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', 'M', 'C', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C MULTI = .TRUE. ISCHCK = 2 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPPMC (YM, YMMISS, X, XMISS, N, M, IYM, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *MPPM SUBROUTINE MPPM(YM, YMMISS, X, XMISS, N, M, IYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING C OBSERVATIONS (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + IYM,M,N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,LISYM,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', 'M', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C MULTI = .TRUE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 2 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPPM (YM, YMMISS, X, XMISS, N, M, IYM)') END *MPPML SUBROUTINE MPPML(YM, YMMISS, X, XMISS, N, M, IYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH MULTIPLE Y-AXIS VALUES AND WITH MISSING C OBSERVATIONS (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + ILOG,IYM,M,N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,LISYM,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'P', 'P', 'M', 'L', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C MULTI = .TRUE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 2 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MPPML (YM, YMMISS, X, XMISS, N, M, IYM, ILOG)') END *MSGX SUBROUTINE MSGX(IER, IPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE RETURNED AND EXPECTED VALUES FOR THE C ERROR FLAG IERR C C WRITTEN BY - C LINDA MITCHELL C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IER,IPRT C C SCALARS IN COMMON INTEGER + IERR C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIBLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IER C EXPECTED VALUE OF ERROR FLAG IERR C INTEGER IERR C RETURNED ERROR FLAG FOUND IN THE COMMON ERRCHK C INTEGER IPRT C LOGICAL OUTPUT DEVICE C C C PRINT MESSAGE WRITE (IPRT,1000) IER, IERR C IF (IER.NE.IERR) WRITE (IPRT,1010) C RETURN C C FORMAT STATEMENT C 1000 FORMAT(/28H EXPECTED VALUE FOR IERR IS , I1/15H RETURNED VALUE, + 12H FOR IERR IS, I2) 1010 FORMAT(48H POSSIBLE ERROR, UNEXPECTED VALUE FOR ERROR FLAG) 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 REAL + C(MBO),T(2*MBO),TEMP(MBO) C C LOCAL SCALARS INTEGER + I,J,JI,K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL T(2*MBO) C A TEMPORARY WORK VECTOR. C REAL TEMP(MBO) C A TEMPORARY WORK VECTOR 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.0E0 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 *MVCHK LOGICAL FUNCTION MVCHK (X, XMISS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CHECKS WHETHER X = XMISS (MVCHK = TRUE) OR NOT C (MVCHK = FALSE) IN A MANNER WHICH WILL PREVENT VERY LARGE OR C VERY SMALL MISSING VALUE CODES FROM CAUSING AN OVERFLOW. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + X,XMISS C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL X C THE VALUE TO BE CHECKED. C REAL XMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IS MISSING. IF X = XMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C IF ((X .GT. 0.0E0 .AND. XMISS .LT. 0.0E0) .OR. + (X .LT. 0.0E0 .AND. XMISS .GT. 0.0E0)) GO TO 10 C IF (ABS(X) .EQ. ABS(XMISS)) GO TO 20 C 10 MVCHK = .FALSE. RETURN C 20 MVCHK = .TRUE. RETURN C END *MVPC SUBROUTINE MVPC(YM, N, M, IYM, NS, ILOG, ISIZE, + YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MULTIPLE Y-AXIS VALUES (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + ILOG,ISIZE,IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IBAR,IPRT,IRLIN,ISCHCK,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', 'C', ' ', ' '/ C C SET DEFAULT VALUES C MULTI = .TRUE. IRLIN = -1 IBAR = -1 ISCHCK = 2 MISS = .FALSE. LISYM = 1 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVPC (YM, N, M, IYM, NS, ILOG,'/ + ' + ISIZE, YLB, YUB, XLB, XINC)') END *MVP SUBROUTINE MVP(YM, N, M, IYM, NS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MULTIPLE Y-AXIS VALUES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', ' ', ' ', ' '/ C C DEFINE CONSTANTS C C SET DEFAULT VALUES C MULTI = .TRUE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 2 ISIZE = -1 MISS = .FALSE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVP (YM, N, M, IYM, NS)') END *MVPL SUBROUTINE MVPL(YM, N, M, IYM, NS, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MULTIPLE Y-AXIS VALUES (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', 'L', ' ', ' '/ C C SET DEFAULT VALUES C MULTI = .TRUE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 2 ISIZE = -1 MISS = .FALSE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVPL (YM, N, M, IYM, NS, ILOG)') END SUBROUTINE MVPMC(YM, YMMISS, N, M, IYM, NS, ILOG, ISIZE, + YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + ILOG,ISIZE,IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IBAR,IPRT,IRLIN,ISCHCK,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', 'M', 'C', ' '/ C C SET DEFAULT VALUES C MULTI = .TRUE. IRLIN = -1 IBAR = -1 ISCHCK = 2 MISS = .TRUE. LISYM = 1 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVPMC (YM, YMMISS, N, M, IYM, NS, ILOG,'/ + ' + ISIZE, YLB, YUB, XLB, XINC)') END SUBROUTINE MVPM(YM, YMMISS, N, M, IYM, NS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES C (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', 'M', ' ', ' '/ C C SET DEFAULT VALUES C MULTI = .TRUE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 2 ISIZE = -1 MISS = .TRUE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVPM (YM, YMMISS, N, M, IYM, NS)') END *MVPML SUBROUTINE MVPML(YM, YMMISS, N, M, IYM, NS, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND MULTIPLE Y-AXIS VALUES C (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,IYM,M,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,LISYM LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'M', 'V', 'P', 'M', 'L', ' '/ C C SET DEFAULT VALUES C MULTI = .TRUE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 2 ISIZE = -1 MISS = .TRUE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL MVPML (YM, YMMISS, N, M, IYM, NS, ILOG)') 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 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 *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 REAL + D(P),J(NN,P),R(N),V(*),X(P) INTEGER + IV(*) C C LOCAL SCALARS REAL + 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 REAL + DOTPRD,R1MACH,V2NORM LOGICAL + STOPX EXTERNAL DOTPRD,R1MACH,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 REAL 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 REAL E, RDOF1, STTSST, T, T1 C C *** CONSTANTS *** C C REAL 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 REAL DOTPRD, R1MACH, 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 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.5E0/, NEGONE/-1.0E0/, ONE/1.0E0/, ZERO/0.0E0/ 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(R1MACH(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 *NL2SNO SUBROUTINE NL2SNO(N, P, X, CALCR, IV, V, UIPARM, URPARM, UFPARM) C C LATEST REVISION - 03/15/90 (JRD) C C *** LIKE NL2SOL, BUT WITHOUT CALCJ -- MINIMIZE NONLINEAR SUM OF *** C *** SQUARES USING FINITE-DIFFERENCE JACOBIAN APPROXIMATIONS *** C *** (NL2SOL VERSION 2.2) *** C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,P C C ARRAY ARGUMENTS REAL + URPARM(1),V(1),X(P) INTEGER + IV(1),UIPARM(1) C C SUBROUTINE ARGUMENTS EXTERNAL CALCR,UFPARM C C LOCAL SCALARS REAL + H,HFAC,HLIM,NEGPT5,ONE,XK,ZERO INTEGER + COVPRT,COVREQ,D,D1,DK,DLTFDJ,DTYPE,I,J,J1,J1K,K,NF,NFCALL, + NFGCAL,R,R1,RN,TOOBIG LOGICAL + STRTED C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C EXTERNAL SUBROUTINES EXTERNAL DFAULT,ITSMRY,NL2ITR,VSCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX C C INTEGER N, P, IV(1), UIPARM(1) C REAL X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) C EXTERNAL CALCR, UFPARM C C----------------------------- DISCUSSION ---------------------------- C C THE PARAMETERS FOR NL2SNO ARE THE SAME AS THOSE FOR NL2SOL C (WHICH SEE), EXCEPT THAT CALCJ IS OMITTED. INSTEAD OF CALLING C CALCJ TO OBTAIN THE JACOBIAN MATRIX OF R AT X, NL2SNO COMPUTES C AN APPROXIMATION TO IT BY FINITE (FORWARD) DIFFERENCES -- SEE C V(DLTFDJ) BELOW. NL2SNO USES FUNCTION VALUES ONLY WHEN COMPUT- C THE COVARIANCE MATRIX (RATHER THAN THE FUNCTIONS AND GRADIENTS C THAT NL2SOL MAY USE). TO DO SO, NL2SNO SETS IV(COVREQ) TO -1 IF C IV(COVPRT) = 1 WITH IV(COVREQ) = 0 AND TO MINUS ITS ABSOLUTE C VALUE OTHERWISE. THUS V(DELTA0) IS NEVER REFERENCED AND ONLY C V(DLTFDC) MATTERS -- SEE NL2SOL FOR A DESCRIPTION OF V(DLTFDC). C THE NUMBER OF EXTRA CALLS ON CALCR USED IN COMPUTING THE JACO- C BIAN APPROXIMATION ARE NOT INCLUDED IN THE FUNCTION EVALUATION C COUNT IV(NFCALL) AND ARE NOT OTHERWISE REPORTED. C C V(DLTFDJ)... V(36) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C FINITE-DIFFERENCE JACOBIAN MATRIX. FOR DIFFERENCES IN- C VOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDJ) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG, I.E., IF CALCR SETS NF TO 0, THEN C SMALLER STEPS ARE TRIED UNTIL THE STEP SIZE IS SHRUNK BE- C LOW 1000 * MACHEP, WHERE MACHEP IS THE UNIT ROUNDOFF. C DEFAULT = MACHEP**0.5. 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 TRANS. C MATH. SOFTWARE. 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+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++ C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL DFAULT, ITSMRY, NL2ITR, RMDCON, VSCOPY C REAL RMDCON C C DFAULT... SUPPLIES DEFAULT PARAMETER VALUES. C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS. C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR. C C LOGICAL STRTED C INTEGER DK, D1, I, J1, J1K, K, NF, RN, R1 C REAL H, HFAC, HLIM, NEGPT5, ONE, XK, ZERO C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER COVPRT, COVREQ, D, DLTFDJ, DTYPE, J, NFCALL, NFGCAL, R, C 1 TOOBIG C DATA HFAC/1.0E3/, HLIM/0.0E0/, NEGPT5/-0.5E0/, + ONE/1.0E0/, ZERO/0.0E0/ C C *** IV SUBSCRIPT VALUES *** C DATA COVPRT/14/, COVREQ/15/, D/27/, DTYPE/16/, J/33/, + NFCALL/6/, NFGCAL/7/, R/50/, TOOBIG/2/ C C *** V SUBSCRIPT VALUES *** C DATA DLTFDJ/36/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 RN = J1 - 1 IF (IV(1) .EQ. 0) CALL DFAULT(IV, V) IV(COVREQ) = -ABS(IV(COVREQ)) IF (IV(COVPRT) .NE. 0 .AND. IV(COVREQ) .EQ. 0) IV(COVREQ) = -1 STRTED = .TRUE. IF (IV(1) .NE. 12) GO TO 80 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C *** INITIALIZE SCALE VECTOR D TO ONES FOR COMPUTING C *** INITIAL JACOBIAN. IF (IV(DTYPE) .GT. 0) CALL VSCOPY(P, V(D1), ONE) C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 90 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 80 C C *** COMPUTE FINITE-DIFFERENCE JACOBIAN *** C 30 J1K = J1 DK = D1 DO 70 K = 1, P XK = X(K) H = V(DLTFDJ) * MAX(ABS(XK), ONE/V(DK)) DK = DK + 1 40 X(K) = XK + H NF = IV(NFGCAL) CALL CALCR (N, P, X, NF, V(J1K), UIPARM, URPARM, UFPARM) IF (NF .GT. 0) GO TO 50 IF (HLIM .EQ. ZERO) HLIM = HFAC * RMDCON(3) C *** HLIM = HFAC TIMES THE UNIT ROUNDOFF *** H = NEGPT5 * H IF (ABS(H) .GE. HLIM) GO TO 40 IV(1) = 15 GO TO 90 50 X(K) = XK DO 60 I = R1, RN V(J1K) = (V(J1K) - V(I)) / H J1K = J1K + 1 60 CONTINUE 70 CONTINUE C STRTED = .TRUE. C 80 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 90 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SNO FOLLOWS *** END *NL2SOL SUBROUTINE NL2SOL(N, P, X, CALCR, CALCJ, IV, V, UIPARM, URPARM, + UFPARM) C C *** MINIMIZE NONLINEAR SUM OF SQUARES USING ANALYTIC JACOBIAN *** C *** (NL2SOL VERSION 2.2) *** C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,P C C ARRAY ARGUMENTS REAL + URPARM(*),V(*),X(P) INTEGER + IV(*),UIPARM(*) C C SUBROUTINE ARGUMENTS EXTERNAL CALCJ,CALCR,UFPARM C C LOCAL SCALARS INTEGER + D,D1,J,J1,NF,NFCALL,NFGCAL,R,R1,TOOBIG LOGICAL + STRTED C C EXTERNAL SUBROUTINES EXTERNAL ITSMRY,NL2ITR C C C INTEGER N, P, IV(1), UIPARM(1) C REAL X(P), V(1), URPARM(1) C DIMENSION IV(60+P), V(93 + N*P + 3*N + P*(3*P+33)/2) C DIMENSION UIPARM(*), URPARM(*) C EXTERNAL CALCR, CALCJ, UFPARM C C *** PURPOSE *** C C GIVEN A P-VECTOR X OF PARAMETERS, CALCR COMPUTES AN N-VECTOR C R = R(X) OF RESIDUALS CORRESPONDING TO X. (R(X) PROBABLY ARISES C FROM A NONLINEAR MODEL INVOLVING P PARAMETERS AND N OBSERVATIONS.) C THIS ROUTINE INTERACTS WITH NL2ITR TO SEEK A PARAMETER VECTOR X C THAT MINIMIZES THE SUM OF THE SQUARES OF (THE COMPONENTS OF) R(X), C I.E., THAT MINIMIZES THE SUM-OF-SQUARES FUNCTION C F(X) = (R(X)**T) * R(X) / 2. R(X) IS ASSUMED TO BE A TWICE CON- C TINUOUSLY DIFFERENTIABLE FUNCTION OF X. C C-------------------------- PARAMETER USAGE -------------------------- C C N........ (INPUT) THE NUMBER OF OBSERVATIONS, I.E., THE NUMBER OF C COMPONENTS IN R(X). N MUST BE .GE. P. C P........ (INPUT) THE NUMBER OF PARAMETERS (COMPONENTS IN X). P MUST C BE POSITIVE. C X........ (INPUT/OUTPUT). ON INPUT, X IS AN INITIAL GUESS AT THE C DESIRED PARAMETER ESTIMATE. ON OUTPUT, X CONTAINS C THE BEST PARAMETER ESTIMATE FOUND. C CALCR.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES R(X). CALCR C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. C IT IS INVOKED BY C CALL CALCR(N,P,X,NF,R,UIPARM,URPARM,UFPARM) C WHEN CALCR IS CALLED, NF IS THE INVOCATION COUNT C FOR CALCR. IT IS INCLUDED FOR POSSIBLE USE WITH C CALCJ. IF X IS OUT OF BOUNDS (E.G. IF IT WOULD C CAUSE OVERFLOW IN COMPUTING R(X)), THEN CALCR SHOULD C SET NF TO 0. THIS WILL CAUSE A SHORTER STEP TO BE C ATTEMPTED. THE OTHER PARAMETERS ARE AS DESCRIBED C ABOVE AND BELOW. CALCR SHOULD NOT CHANGE N, P, OR X. C CALCJ.... (INPUT) A SUBROUTINE WHICH, GIVEN X, COMPUTES THE JACOBIAN C MATRIX J OF R AT X, I.E., THE N BY P MATRIX WHOSE C (I,K) ENTRY IS THE PARTIAL DERIVATIVE OF THE I-TH C COMPONENT OF R WITH RESPECT TO X(K). CALCJ MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. IT IS C INVOKED BY C CALL CALCJ(N,P,X,NF,J,UIPARM,URPARM,UFPARM) C NF IS THE INVOCATION COUNT FOR CALCR AT THE TIME C R(X) WAS EVALUATED. THE X PASSED TO CALCJ IS C USUALLY THE ONE PASSED TO CALCR ON EITHER ITS MOST C RECENT INVOCATION OR THE ONE PRIOR TO IT. IF CALCR C SAVES INTERMEDIATE RESULTS FOR USE BY CALCJ, THEN IT C IS POSSIBLE TO TELL FROM NF WHETHER THEY ARE VALID C FOR THE CURRENT X (OR WHICH COPY IS VALID IF TWO C COPIES ARE KEPT). IF J CANNOT BE COMPUTED AT X, C THEN CALCJ SHOULD SET NF TO 0. IN THIS CASE, NL2SOL C WILL RETURN WITH IV(1) = 15. THE OTHER PARAMETERS C TO CALCJ ARE AS DESCRIBED ABOVE AND BELOW. CALCJ C SHOULD NOT CHANGE N, P, OR X. C IV....... (INPUT/OUTPUT) AN INTEGER VALUE ARRAY OF LENGTH AT LEAST C 60 + P THAT HELPS CONTROL THE NL2SOL ALGORITHM AND C THAT IS USED TO STORE VARIOUS INTERMEDIATE QUANTI- C TIES. OF PARTICULAR INTEREST ARE THE INITIALIZATION/ C RETURN CODE IV(1) AND THE ENTRIES IN IV THAT CONTROL C PRINTING AND LIMIT THE NUMBER OF ITERATIONS AND FUNC- C TION EVALUATIONS. SEE THE SECTION ON IV INPUT C VALUES BELOW. C V........ (INPUT/OUTPUT) A FLOATING-POINT VALUE ARRAY OF LENGTH AT C LEAST 93 + N*P + 3*N + P*(3*P+33) THAT HELPS CON- C TROL THE NL2SOL ALGORITHM AND THAT IS USED TO STORE C VARIOUS INTERMEDIATE QUANTITIES. OF PARTICULAR IN- C TEREST ARE THE ENTRIES IN V THAT LIMIT THE LENGTH OF C THE FIRST STEP ATTEMPTED (LMAX0), SPECIFY CONVER- C GENCE TOLERANCES (AFCTOL, RFCTOL, XCTOL, XFTOL), C AND HELP CHOOSE THE STEP SIZE USED IN COMPUTING THE C COVARIANCE MATRIX (DELTA0). SEE THE SECTION ON C (SELECTED) V INPUT VALUES BELOW. C UIPARM... (INPUT) USER INTEGER PARAMETER ARRAY PASSED WITHOUT CHANGE C TO CALCR AND CALCJ. C URPARM... (INPUT) USER FLOATING-POINT PARAMETER ARRAY PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C UFPARM... (INPUT) USER EXTERNAL SUBROUTINE OR FUNCTION PASSED WITHOUT C CHANGE TO CALCR AND CALCJ. C C *** IV INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C IV(1)... ON INPUT, IV(1) SHOULD HAVE A VALUE BETWEEN 0 AND 12...... C 0 AND 12 MEAN THIS IS A FRESH START. 0 MEANS THAT C DFAULT(IV, V) IS TO BE CALLED TO PROVIDE ALL DEFAULT C VALUES TO IV AND V. 12 (THE VALUE THAT DFAULT ASSIGNS TO C IV(1)) MEANS THE CALLER HAS ALREADY CALLED DFAULT(IV, V) C AND HAS POSSIBLY CHANGED SOME IV AND/OR V ENTRIES TO NON- C DEFAULT VALUES. DEFAULT = 12. C IV(COVPRT)... IV(14) = 1 MEANS PRINT A COVARIANCE MATRIX AT THE SOLU- C TION. (THIS MATRIX IS COMPUTED JUST BEFORE A RETURN WITH C IV(1) = 3, 4, 5, 6.) C IV(COVPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(COVREQ)... IV(15) = NONZERO MEANS COMPUTE A COVARIANCE MATRIX C JUST BEFORE A RETURN WITH IV(1) = 3, 4, 5, 6. IN C THIS CASE, AN APPROXIMATE COVARIANCE MATRIX IS OBTAINED C IN ONE OF SEVERAL WAYS. LET K = ABS(IV(COVREQ)) AND LET C SCALE = 2*F(X)/MAX(1,N-P), WHERE 2*F(X) IS THE RESIDUAL C SUM OF SQUARES. IF K = 1 OR 2, THEN A FINITE-DIFFERENCE C HESSIAN APPROXIMATION H IS OBTAINED. IF H IS POSITIVE C DEFINITE (OR, FOR K = 3, IF THE JACOBIAN MATRIX J AT X C IS NONSINGULAR), THEN ONE OF THE FOLLOWING IS COMPUTED... C K = 1.... SCALE * H**-1 * (J**T * J) * H**-1. C K = 2.... SCALE * H**-1. C K = 3.... SCALE * (J**T * J)**-1. C (J**T IS THE TRANSPOSE OF J, WHILE **-1 MEANS INVERSE.) C IF IV(COVREQ) IS POSITIVE, THEN BOTH FUNCTION AND GRAD- C IENT VALUES (CALLS ON CALCR AND CALCJ) ARE USED IN COM- C PUTING H (WITH STEP SIZES DETERMINED USING V(DELTA0) -- C SEE BELOW), WHILE IF IV(COVREQ) IS NEGATIVE, THEN ONLY C FUNCTION VALUES (CALLS ON CALCR) ARE USED (WITH STEP C SIZES DETERMINED USING V(DLTFDC) -- SEE BELOW). IF C IV(COVREQ) = 0, THEN NO ATTEMPT IS MADE TO COMPUTE A CO- C VARIANCE MATRIX (UNLESS IV(COVPRT) = 1, IN WHICH CASE C IV(COVREQ) = 1 IS ASSUMED). SEE IV(COVMAT) BELOW. C DEFAULT = 1. C IV(DTYPE).... IV(16) TELLS HOW THE SCALE VECTOR D (SEE REF. 1) SHOULD C BE CHOSEN. IV(DTYPE) .GE. 1 MEANS CHOOSE D AS DESCRIBED C BELOW WITH V(DFAC). IV(DTYPE) .LE. 0 MEANS THE CALLER C HAS CHOSEN D AND HAS STORED IT IN V STARTING AT C V(94 + 2*N + P*(3*P + 31)/2). DEFAULT = 1. C IV(INITS).... IV(25) TELLS HOW THE S MATRIX (SEE REF. 1) SHOULD BE C INITIALIZED. 0 MEANS INITIALIZE S TO 0 (AND START WITH C THE GAUSS-NEWTON MODEL). 1 AND 2 MEAN THAT THE CALLER C HAS STORED THE LOWER TRIANGLE OF THE INITIAL S ROWWISE IN C V STARTING AT V(87+2*P). IV(INITS) = 1 MEANS START WITH C THE GAUSS-NEWTON MODEL, WHILE IV(INITS) = 2 MEANS START C WITH THE AUGMENTED MODEL (SEE REF. 1). DEFAULT = 0. C IV(MXFCAL)... IV(17) GIVES THE MAXIMUM NUMBER OF FUNCTION EVALUATIONS C (CALLS ON CALCR, EXCLUDING THOSE USED TO COMPUTE THE CO- C VARIANCE MATRIX) ALLOWED. IF THIS NUMBER DOES NOT SUF- C FICE, THEN NL2SOL RETURNS WITH IV(1) = 9. DEFAULT = 200. C IV(MXITER)... IV(18) GIVES THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C IT ALSO INDIRECTLY LIMITS THE NUMBER OF GRADIENT EVALUA- C TIONS (CALLS ON CALCJ, EXCLUDING THOSE USED TO COMPUTE C THE COVARIANCE MATRIX) TO IV(MXITER) + 1. IF IV(MXITER) C ITERATIONS DO NOT SUFFICE, THEN NL2SOL RETURNS WITH C IV(1) = 10. DEFAULT = 150. C IV(OUTLEV)... IV(19) CONTROLS THE NUMBER AND LENGTH OF ITERATION SUM- C MARY LINES PRINTED (BY ITSMRY). IV(OUTLEV) = 0 MEANS DO C NOT PRINT ANY SUMMARY LINES. OTHERWISE, PRINT A SUMMARY C LINE AFTER EACH ABS(IV(OUTLEV)) ITERATIONS. IF IV(OUTLEV) C IS POSITIVE, THEN SUMMARY LINES OF LENGTH 117 (PLUS CARRI- C AGE CONTROL) ARE PRINTED, INCLUDING THE FOLLOWING... THE C ITERATION AND FUNCTION EVALUATION COUNTS, CURRENT FUNC- C TION VALUE (V(F) = HALF THE SUM OF SQUARES), RELATIVE C DIFFERENCE IN FUNCTION VALUES ACHIEVED BY THE LATEST STEP C (I.E., RELDF = (F0-V(F))/F0, WHERE F0 IS THE FUNCTION C VALUE FROM THE PREVIOUS ITERATION), THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR THE STEP JUST TAKEN (I.E., C PRELDF = V(PREDUC) / F0, WHERE V(PREDUC) IS DESCRIBED C BELOW), THE SCALED RELATIVE CHANGE IN X (SEE V(RELDX) C BELOW), THE MODELS USED IN THE CURRENT ITERATION (G = C GAUSS-NEWTON, S=AUGMENTED), THE MARQUARDT PARAMETER C STPPAR USED IN COMPUTING THE LAST STEP, THE SIZING FACTOR C USED IN UPDATING S, THE 2-NORM OF THE SCALE VECTOR D C TIMES THE STEP JUST TAKEN (SEE REF. 1), AND NPRELDF, I.E., C V(NREDUC)/F0, WHERE V(NREDUC) IS DESCRIBED BELOW -- IF C NPRELDF IS POSITIVE, THEN IT IS THE RELATIVE FUNCTION C REDUCTION PREDICTED FOR A NEWTON STEP (ONE WITH C STPPAR = 0). IF NPRELDF IS ZERO, EITHER THE GRADIENT C VANISHES (AS DOES PRELDF) OR ELSE THE AUGMENTED MODEL C IS BEING USED AND ITS HESSIAN IS INDEFINITE (WITH PRELDF C POSITIVE). IF NPRELDF IS NEGATIVE, THEN IT IS THE NEGA- C OF THE RELATIVE FUNCTION REDUCTION PREDICTED FOR A STEP C COMPUTED WITH STEP BOUND V(LMAX0) FOR USE IN TESTING FOR C SINGULAR CONVERGENCE. C IF IV(OUTLEV) IS NEGATIVE, THEN LINES OF MAXIMUM C LENGTH 79 (OR 55 IS IV(COVPRT) = 0) ARE PRINTED, INCLUD- C ING ONLY THE FIRST 6 ITEMS LISTED ABOVE (THROUGH RELDX). C DEFAULT = 1. C IV(PARPRT)... IV(20) = 1 MEANS PRINT ANY NONDEFAULT V VALUES ON A C FRESH START OR ANY CHANGED V VALUES ON A RESTART. C IV(PARPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(PRUNIT)... IV(21) IS THE OUTPUT UNIT NUMBER ON WHICH ALL PRINTING C IS DONE. IV(PRUNIT) = 0 MEANS SUPPRESS ALL PRINTING. C (SETTING IV(PRUNIT) TO 0 IS THE ONLY WAY TO SUPPRESS THE C ONE-LINE TERMINATION REASON MESSAGE PRINTED BY ITSMRY.) C DEFAULT = STANDARD OUTPUT UNIT (UNIT 6 ON MOST SYSTEMS). C IV(SOLPRT)... IV(22) = 1 MEANS PRINT OUT THE VALUE OF X RETURNED (AS C WELL AS THE CORRESPONDING GRADIENT AND SCALE VECTOR D). C IV(SOLPRT) = 0 MEANS SKIP THIS PRINTING. DEFAULT = 1. C IV(STATPR)... IV(23) = 1 MEANS PRINT SUMMARY STATISTICS UPON RETURN- C ING. THESE CONSIST OF THE FUNCTION VALUE (HALF THE SUM C OF SQUARES) AT X, V(RELDX) (SEE BELOW), THE NUMBER OF C FUNCTION AND GRADIENT EVALUATIONS (CALLS ON CALCR AND C CALCJ RESPECTIVELY, EXCLUDING ANY CALLS USED TO COMPUTE C THE COVARIANCE), THE RELATIVE FUNCTION REDUCTIONS PREDICT- C ED FOR THE LAST STEP TAKEN AND FOR A NEWTON STEP (OR PER- C HAPS A STEP BOUNDED BY V(LMAX0) -- SEE THE DESCRIPTIONS C OF PRELDF AND NPRELDF UNDER IV(OUTLEV) ABOVE), AND (IF AN C ATTEMPT WAS MADE TO COMPUTE THE COVARIANCE) THE NUMBER OF C CALLS ON CALCR AND CALCJ USED IN TRYING TO COMPUTE THE C COVARIANCE. IV(STATPR) = 0 MEANS SKIP THIS PRINTING. C DEFAULT = 1. C IV(X0PRT).... IV(24) = 1 MEANS PRINT THE INITIAL X AND SCALE VECTOR D C (ON A FRESH START ONLY). IV(X0PRT) = 0 MEANS SKIP THIS C PRINTING. DEFAULT = 1. C C *** (SELECTED) IV OUTPUT VALUES *** C C IV(1)........ ON OUTPUT, IV(1) IS A RETURN CODE.... C 3 = X-CONVERGENCE. THE SCALED RELATIVE DIFFERENCE BE- C TWEEN THE CURRENT PARAMETER VECTOR X AND A LOCALLY C OPTIMAL PARAMETER VECTOR IS VERY LIKELY AT MOST C V(XCTOL). C 4 = RELATIVE FUNCTION CONVERGENCE. THE RELATIVE DIFFER- C ENCE BETWEEN THE CURRENT FUNCTION VALUE AND ITS LO- C CALLY OPTIMAL VALUE IS VERY LIKELY AT MOST V(RFCTOL). C 5 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE (I.E., THE C CONDITIONS FOR IV(1) = 3 AND IV(1) = 4 BOTH HOLD). C 6 = ABSOLUTE FUNCTION CONVERGENCE. THE CURRENT FUNCTION C VALUE IS AT MOST V(AFCTOL) IN ABSOLUTE VALUE. C 7 = SINGULAR CONVERGENCE. THE HESSIAN NEAR THE CURRENT C ITERATE APPEARS TO BE SINGULAR OR NEARLY SO, AND A C STEP OF LENGTH AT MOST V(LMAX0) IS UNLIKELY TO YIELD C A RELATIVE FUNCTION DECREASE OF MORE THAN V(RFCTOL). C 8 = FALSE CONVERGENCE. THE ITERATES APPEAR TO BE CONVERG- C ING TO A NONCRITICAL POINT. THIS MAY MEAN THAT THE C CONVERGENCE TOLERANCES (V(AFCTOL), V(RFCTOL), C V(XCTOL)) ARE TOO SMALL FOR THE ACCURACY TO WHICH C THE FUNCTION AND GRADIENT ARE BEING COMPUTED, THAT C THERE IS AN ERROR IN COMPUTING THE GRADIENT, OR THAT C THE FUNCTION OR GRADIENT IS DISCONTINUOUS NEAR X. C 9 = FUNCTION EVALUATION LIMIT REACHED WITHOUT OTHER CON- C VERGENCE (SEE IV(MXFCAL)). C 10 = ITERATION LIMIT REACHED WITHOUT OTHER CONVERGENCE C (SEE IV(MXITER)). C 11 = STOPX RETURNED .TRUE. (EXTERNAL INTERUPT). SEE THE C USAGE NOTES BELOW. C 13 = F(X) CANNOT BE COMPUTED AT THE INITIAL X. C 14 = BAD PARAMETERS PASSED TO ASSESS (WHICH SHOULD NOT C OCCUR). C 15 = THE JACOBIAN COULD NOT BE COMPUTED AT X (SEE CALCJ C ABOVE). C 16 = N OR P (OR PARAMETER NN TO NL2ITR) OUT OF RANGE -- C P .LE. 0 OR N .LT. P OR NN .LT. N. C 17 = RESTART ATTEMPTED WITH N OR P (OR PAR. NN TO NL2ITR) C CHANGED. C 18 = IV(INITS) IS OUT OF RANGE. C 19...45 = V(IV(1)-18) IS OUT OF RANGE. C 50 = IV(1) WAS OUT OF RANGE. C 87...(86+P) = JTOL(IV(1)-86) (I.E., V(IV(1)) IS NOT C POSITIVE (SEE V(DFAC) BELOW). C IV(COVMAT)... IV(26) TELLS WHETHER A COVARIANCE MATRIX WAS COMPUTED. C IF (IV(COVMAT) IS POSITIVE, THEN THE LOWER TRIANGLE OF C THE COVARIANCE MATRIX IS STORED ROWWISE IN V STARTING AT C V(IV(COVMAT)). IF IV(COVMAT) = 0, THEN NO ATTEMPT WAS C MADE TO COMPUTE THE COVARIANCE. IF IV(COVMAT) = -1, C THEN THE FINITE-DIFFERENCE HESSIAN WAS INDEFINITE. AND C AND IF IV(COVMAT) = -2, THEN A SUCCESSFUL FINITE-DIFFER- C ENCING STEP COULD NOT BE FOUND FOR SOME COMPONENT OF X C (I.E., CALCR SET NF TO 0 FOR EACH OF TWO TRIAL STEPS). C NOTE THAT IV(COVMAT) IS RESET TO 0 AFTER EACH SUCCESSFUL C STEP, SO IF SUCH A STEP IS TAKEN AFTER A RESTART, THEN C THE COVARIANCE MATRIX WILL BE RECOMPUTED. C IV(D)........ IV(27) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C SCALE VECTOR D. C IV(G)........ IV(28) IS THE STARTING SUBSCRIPT IN V OF THE CURRENT C LEAST-SQUARES GRADIENT VECTOR (J**T)*R. C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCR (I.E., C FUNCTION EVALUATIONS, INCLUDING THOSE USED IN COMPUTING C THE COVARIANCE). C IV(NFCOV).... IV(40) IS THE NUMBER OF CALLS MADE ON CALCR WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NGCALL)... IV(30) IS THE NUMBER OF GRADIENT EVALUATIONS (CALLS ON C CALCJ) SO FAR DONE (INCLUDING THOSE USED FOR COMPUTING C THE COVARIANCE). C IV(NGCOV).... IV(41) IS THE NUMBER OF CALLS MADE ON CALCJ WHEN C TRYING TO COMPUTE COVARIANCE MATRICES. C IV(NITER).... IV(31) IS THE NUMBER OF ITERATIONS PERFORMED. C IV(R)........ IV(50) IS THE STARTING SUBSCRIPT IN V OF THE RESIDUAL C VECTOR R CORRESPONDING TO X. C C *** (SELECTED) V INPUT VALUES (FROM SUBROUTINE DFAULT) *** C C V(AFCTOL)... V(31) IS THE ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. C IF NL2SOL FINDS A POINT WHERE THE FUNCTION VALUE (HALF C THE SUM OF SQUARES) IS LESS THAN V(AFCTOL), AND IF NL2SOL C DOES NOT RETURN WITH IV(1) = 3, 4, OR 5, THEN IT RETURNS C WITH IV(1) = 6. DEFAULT = MAX(10**-20, MACHEP**2), WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(DELTA0)... V(44) IS A FACTOR USED IN CHOOSING THE FINITE-DIFFERENCE C STEP SIZE USED IN COMPUTING THE COVARIANCE MATRIX WHEN C IV(COVREQ) = 1 OR 2. FOR COMPONENT I, STEP SIZE C V(DELTA0) * MAX(ABS(X(I)), 1/D(I)) * SIGN(X(I)) C IS USED, WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). C (IF THIS STEP RESULTS IN CALCR SETTING NF TO 0, THEN -0.5 C TIMES THIS STEP IS ALSO TRIED.) DEFAULT = MACHEP**0.5, C WHERE MACHEP IS THE UNIT ROUNDOFF. C V(DFAC)..... V(41) AND THE D0 AND JTOL ARRAYS (SEE V(D0INIT) AND C V(JTINIT)) ARE USED IN UPDATING THE SCALE VECTOR D WHEN C IV(DTYPE) .GT. 0. (D IS INITIALIZED ACCORDING TO C V(DINIT).) LET D1(I) = C MAX(SQRT(JCNORM(I)**2 + MAX(S(I,I),0)), V(DFAC)*D(I)), C WHERE JCNORM(I) IS THE 2-NORM OF THE I-TH COLUMN OF THE C CURRENT JACOBIAN MATRIX AND S IS THE S MATRIX OF REF. 1. C IF IV(DTYPE) = 1, THEN D(I) IS SET TO D1(I) UNLESS C D1(I) .LT. JTOL(I), IN WHICH CASE D(I) IS SET TO C MAX(D0(I), JTOL(I)). C IF IV(DTYPE) .GE. 2, THEN D IS UPDATED DURING THE FIRST C ITERATION AS FOR IV(DTYPE) = 1 (AFTER ANY INITIALIZATION C DUE TO V(DINIT)) AND IS LEFT UNCHANGED THEREAFTER. C DEFAULT = 0.6. C V(DINIT).... V(38), IF NONNEGATIVE, IS THE VALUE TO WHICH THE SCALE C VECTOR D IS INITIALIZED. DEFAULT = 0. C V(DLTFDC)... V(40) HELPS CHOOSE THE STEP SIZE USED WHEN COMPUTING THE C COVARIANCE MATRIX WHEN IV(COVREQ) = -1 OR -2. FOR C DIFFERENCES INVOLVING X(I), THE STEP SIZE FIRST TRIED IS C V(DLTFDC) * MAX(ABS(X(I)), 1/D(I)), C WHERE D IS THE CURRENT SCALE VECTOR (SEE REF. 1). (IF C THIS STEP IS TOO BIG THE FIRST TIME IT IS TRIED, I.E., IF C CALCR SETS NF TO 0, THEN -0.5 TIMES THIS STEP IS ALSO C TRIED.) DEFAULT = MACHEP**(1/3), WHERE MACHEP IS THE C UNIT ROUNDOFF. C V(D0INIT)... V(37), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE D0 VECTOR (SEE V(DFAC)) ARE INITIALIZED. IF C V(DFAC) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED D0 IN V STARTING AT V(P+87). DEFAULT = 1.0. C V(JTINIT)... V(39), IF POSITIVE, IS THE VALUE TO WHICH ALL COMPONENTS C OF THE JTOL ARRAY (SEE V(DFAC)) ARE INITIALIZED. IF C V(JTINIT) = 0, THEN IT IS ASSUMED THAT THE CALLER HAS C STORED JTOL IN V STARTING AT V(87). DEFAULT = 10**-6. C V(LMAX0).... V(35) GIVES THE MAXIMUM 2-NORM ALLOWED FOR D TIMES THE C VERY FIRST STEP THAT NL2SOL ATTEMPTS. IT IS ALSO USED C IN TESTING FOR SINGULAR CONVERGENCE -- IF THE FUNCTION C REDUCTION PREDICTED FOR A STEP OF LENGTH BOUNDED BY C V(LMAX0) IS AT MOST V(RFCTOL) * ABS(F0), WHERE F0 IS C THE FUNCTION VALUE AT THE START OF THE CURRENT ITERATION, C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, OR 6, C THEN IT RETURNS WITH IV(1) = 7. DEFAULT = 100. C V(RFCTOL)... V(32) IS THE RELATIVE FUNCTION CONVERGENCE TOLERANCE. C IF THE CURRENT MODEL PREDICTS A MAXIMUM POSSIBLE FUNCTION C REDUCTION (SEE V(NREDUC)) OF AT MOST V(RFCTOL)*ABS(F0) AT C THE START OF THE CURRENT ITERATION, WHERE F0 IS THE C THEN CURRENT FUNCTION VALUE, AND IF THE LAST STEP ATTEMPT- C ED ACHIEVED NO MORE THAN TWICE THE PREDICTED FUNCTION C DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 4 (OR 5). C DEFAULT = MAX(10**-10, MACHEP**(2/3)), WHERE MACHEP IS C THE UNIT ROUNDOFF. C V(TUNER1)... V(26) HELPS DECIDE WHEN TO CHECK FOR FALSE CONVERGENCE C AND TO CONSIDER SWITCHING MODELS. THIS IS DONE IF THE C ACTUAL FUNCTION DECREASE FROM THE CURRENT STEP IS NO MORE C THAN V(TUNER1) TIMES ITS PREDICTED VALUE. DEFAULT = 0.1. C V(XCTOL).... V(33) IS THE X-CONVERGENCE TOLERANCE. IF A NEWTON STEP C (SEE V(NREDUC)) IS TRIED THAT HAS V(RELDX) .LE. V(XCTOL) C AND IF THIS STEP YIELDS AT MOST TWICE THE PREDICTED FUNC- C TION DECREASE, THEN NL2SOL RETURNS WITH IV(1) = 3 (OR 5). C (SEE THE DESCRIPTION OF V(RELDX) BELOW.) C DEFAULT = MACHEP**0.5, WHERE MACHEP IS THE UNIT ROUNDOFF. C V(XFTOL).... V(34) IS THE FALSE CONVERGENCE TOLERANCE. IF A STEP IS C TRIED THAT GIVES NO MORE THAN V(TUNER1) TIMES THE PREDICT- C ED FUNCTION DECREASE AND THAT HAS V(RELDX) .LE. V(XFTOL), C AND IF NL2SOL DOES NOT RETURN WITH IV(1) = 3, 4, 5, 6, OR C 7, THEN IT RETURNS WITH IV(1) = 8. (SEE THE DESCRIPTION C OF V(RELDX) BELOW.) DEFAULT = 100*MACHEP, WHERE C MACHEP IS THE UNIT ROUNDOFF. C V(*)........ DFAULT SUPPLIES TO V A NUMBER OF TUNING CONSTANTS, WITH C WHICH IT SHOULD ORDINARILY BE UNNECESSARY TO TINKER. SEE C VERSION 2.2 OF THE NL2SOL USAGE SUMMARY (WHICH IS AN C APPENDIX TO REF. 1). C C *** (SELECTED) V OUTPUT VALUES *** C C V(DGNORM)... V(1) IS THE 2-NORM OF (D**-1)*G, WHERE G IS THE MOST RE- C CENTLY COMPUTED GRADIENT AND D IS THE CORRESPONDING SCALE C VECTOR. C V(DSTNRM)... V(2) IS THE 2-NORM OF D*STEP, WHERE STEP IS THE MOST RE- C CENTLY COMPUTED STEP AND D IS THE CURRENT SCALE VECTOR. C V(F)........ V(10) IS THE CURRENT FUNCTION VALUE (HALF THE SUM OF C SQUARES). C V(F0)....... V(13) IS THE FUNCTION VALUE AT THE START OF THE CURRENT C ITERATION. C V(NREDUC)... V(6), IF POSITIVE, IS THE MAXIMUM FUNCTION REDUCTION C POSSIBLE ACCORDING TO THE CURRENT MODEL, I.E., THE FUNC- C TION REDUCTION PREDICTED FOR A NEWTON STEP (I.E., C STEP = -H**-1 * G, WHERE G = (J**T) * R IS THE CURRENT C GRADIENT AND H IS THE CURRENT HESSIAN APPROXIMATION -- C H = (J**T)*J FOR THE GAUSS-NEWTON MODEL AND C H = (J**T)*J + S FOR THE AUGMENTED MODEL). C V(NREDUC) = ZERO MEANS H IS NOT POSITIVE DEFINITE. C IF V(NREDUC) IS NEGATIVE, THEN IT IS THE NEGATIVE OF C THE FUNCTION REDUCTION PREDICTED FOR A STEP COMPUTED WITH C A STEP BOUND OF V(LMAX0) FOR USE IN TESTING FOR SINGULAR C CONVERGENCE. C V(PREDUC)... V(7) IS THE FUNCTION REDUCTION PREDICTED (BY THE CURRENT C QUADRATIC MODEL) FOR THE CURRENT STEP. THIS (DIVIDED BY C V(F0)) IS USED IN TESTING FOR RELATIVE FUNCTION C CONVERGENCE. C V(RELDX).... V(17) IS THE SCALED RELATIVE CHANGE IN X CAUSED BY THE C CURRENT STEP, COMPUTED AS C MAX(ABS(D(I)*(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 WHERE X = X0 + STEP. C C------------------------------- NOTES ------------------------------- C C *** ALGORITHM NOTES *** C C SEE REF. 1 FOR A DESCRIPTION OF THE ALGORITHM USED. C ON PROBLEMS WHICH ARE NATURALLY WELL SCALED, BETTER PERFORM- C ANCE MAY BE OBTAINED BY SETTING V(D0INIT) = 1.0 AND IV(DTYPE) = 0, C WHICH WILL CAUSE THE SCALE VECTOR D TO BE SET TO ALL ONES. C C *** USAGE NOTES *** C C AFTER A RETURN WITH IV(1) .LE. 11, IT IS POSSIBLE TO RESTART, C I.E., TO CHANGE SOME OF THE IV AND V INPUT VALUES DESCRIBED ABOVE C AND CONTINUE THE ALGORITHM FROM THE POINT WHERE IT WAS INTERRUPT- C ED. IV(1) SHOULD NOT BE CHANGED, NOR SHOULD ANY ENTRIES OF IV C AND V OTHER THAN THE INPUT VALUES (THOSE SUPPLIED BY DFAULT). C THOSE WHO DO NOT WISH TO WRITE A CALCJ WHICH COMPUTES THE JA- C COBIAN MATRIX ANALYTICALLY SHOULD CALL NL2SNO RATHER THAN NL2SOL. C NL2SNO USES FINITE DIFFERENCES TO COMPUTE AN APPROXIMATE JACOBIAN. C THOSE WHO WOULD PREFER TO PROVIDE R AND J (THE RESIDUAL AND C JACOBIAN) BY REVERSE COMMUNICATION RATHER THAN BY WRITING SUBROU- C TINES CALCR AND CALCJ MAY CALL ON NL2ITR DIRECTLY. SEE THE COM- C MENTS AT THE BEGINNING OF NL2ITR. C THOSE WHO USE NL2SOL INTERACTIVELY MAY WISH TO SUPPLY THEIR C OWN STOPX FUNCTION, WHICH SHOULD RETURN .TRUE. IF THE BREAK KEY C HAS BEEN PRESSED SINCE STOPX WAS LAST INVOKED. THIS MAKES IT POS- C SIBLE TO EXTERNALLY INTERRUPT NL2SOL (WHICH WILL RETURN WITH C IV(1) = 11 IF STOPX RETURNS .TRUE.). C STORAGE FOR J IS ALLOCATED AT THE END OF V. THUS THE CALLER C MAY MAKE V LONGER THAN SPECIFIED ABOVE AND MAY ALLOW CALCJ TO USE C ELEMENTS OF J BEYOND THE FIRST N*P AS SCRATCH STORAGE. C C *** PORTABILITY NOTES *** C C THE NL2SOL DISTRIBUTION TAPE CONTAINS BOTH SINGLE- AND DOUBLE- C PRECISION VERSIONS OF THE NL2SOL SOURCE CODE, SO IT SHOULD BE UN- C NECESSARY TO CHANGE PRECISIONS. C ONLY THE FUNCTIONS IMDCON AND RMDCON CONTAIN MACHINE-DEPENDENT C CONSTANTS. TO CHANGE FROM ONE MACHINE TO ANOTHER, IT SHOULD C SUFFICE TO CHANGE THE (FEW) RELEVANT LINES IN THESE FUNCTIONS. 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 TRANS. C MATH. SOFTWARE. C C *** GENERAL *** C C CODED BY DAVID M. GAY (WINTER 1979 - WINTER 1980). 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---------------------------- DECLARATIONS --------------------------- C C EXTERNAL ITSMRY, NL2ITR C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X. C NL2ITR... REVERSE-COMMUNICATION ROUTINE THAT CARRIES OUT NL2SOL ALGO- C RITHM. C C LOGICAL STRTED C INTEGER D1, J1, NF, R1 C C *** SUBSCRIPTS FOR IV AND V *** C C INTEGER D, J, NFCALL, NFGCAL, R, TOOBIG C C *** IV SUBSCRIPT VALUES *** C DATA NFCALL/6/, NFGCAL/7/, TOOBIG/2/ C C *** V SUBSCRIPT VALUES *** C DATA D/27/, J/33/, R/50/ C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C D1 = 94 + 2*N + P*(3*P + 31)/2 IV(D) = D1 R1 = D1 + P IV(R) = R1 J1 = R1 + N IV(J) = J1 STRTED = .TRUE. IF (IV(1) .NE. 0 .AND. IV(1) .NE. 12) GO TO 40 STRTED = .FALSE. IV(NFCALL) = 1 IV(NFGCAL) = 1 C 10 NF = IV(NFCALL) CALL CALCR(N, P, X, NF, V(R1), UIPARM, URPARM, UFPARM) IF (STRTED) GO TO 20 IF (NF .GT. 0) GO TO 30 IV(1) = 13 GO TO 60 C 20 IF (NF .LE. 0) IV(TOOBIG) = 1 GO TO 40 C 30 CALL CALCJ(N, P, X, IV(NFGCAL), V(J1), UIPARM, URPARM, UFPARM) IF (IV(NFGCAL) .EQ. 0) GO TO 50 STRTED = .TRUE. C 40 CALL NL2ITR(V(D1), IV, V(J1), N, N, P, V(R1), V, X) IF (IV(1) - 2) 10, 30, 999 C 50 IV(1) = 15 60 CALL ITSMRY(V(D1), IV, P, V, X) C 999 RETURN C *** LAST CARD OF NL2SOL FOLLOWS *** END *NL2X SUBROUTINE NL2X C *** TEST NL2SOL AND NL2SNO ON MADSEN EXAMPLE *** C C VARIABLE DECLARATIONS C C LOCAL ARRAYS REAL + URPARM(1),V(147),X(2) INTEGER + IV(62),UIPARM(1) C C EXTERNAL SUBROUTINES EXTERNAL MADJ,MADR,NL2SNO,NL2SOL,UFPARM C X(1) = 3.0E0 X(2) = 1.0E0 IV(1) = 0 CALL NL2SOL(3, 2, X, MADR, MADJ, IV, V, UIPARM, URPARM, UFPARM) IV(1) = 12 X(1) = 3.0E0 X(2) = 1.0E0 CALL NL2SNO(3, 2, X, MADR, IV, V, UIPARM, URPARM, UFPARM) RETURN 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 REAL + COND,RSD,RSS,RSSHLF,YSS INTEGER + IDF,LVCVL,LWT,N,NNZW,NPAR,NPARE LOGICAL + EXACT,WEIGHT C C ARRAY ARGUMENTS REAL + 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 REAL + FAC,FPLM,RVAR,SM,TJ,WTI,WTSUM,YWTSM,YWTYSM INTEGER + I,J,JK,K C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL FITEXT C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COND C THE CONDITION NUMBER OF D. C REAL 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 REAL FAC C A FACTOR USED TO CORRECT FOR ZERO WEIGHTED OBSERVATIONS IN C THE VARIANCE COVARIANCE COMPUTATION. C REAL 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 REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL RD(N) C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RSSHLF C HALF THE RESIDUAL SUM OF SQUARES. C REAL RVAR C THE RESIDUAL VARIANCE. C REAL SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDREST(N) C THE STANDARDIZED RESIDUALS. C REAL SM C A VARIABLE USED FOR SUMMATION. C REAL TJ C ... C REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL WTI C THE ACTUAL WEIGHT USED FOR THE ITH OBSERVATION. C REAL WTSUM C THE SUM OF THE WEIGHTS. C REAL Y(N) C THE DEPENDENT VARIABLE. C REAL YSS C THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE. C REAL YWTSM C THE SUM OF THE VALUES Y(I)*WT(I), I=1,N. C REAL YWTYSM C THE SUM OF THE VALUES Y(I)*WT(I)*WT(I), I=1,N. C FPLM = R1MACH(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.0E0*RSSHLF RVAR = 0.0E0 IF (IDF.GE.1) RVAR = RSS/IDF RSD = SQRT(RVAR) YWTSM = 0.0E0 YWTYSM = 0.0E0 WTSUM = 0.0E0 DO 20 I=1,N WTI = 1.0E0 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.0E0) C CALL FITEXT(RSS, YSS, EXACT) C COND = FPLM IF (RD(NPARE).NE.0.0E0) 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.0E0 DO 60 J=1,NPARE TJ = 0.0E0 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.0E0) SM = 0.0E0 SDPVT(I) = SQRT(SM) C SDREST(I) = FPLM WTI = 1.0E0 IF (WEIGHT) WTI = WT(I) IF (WTI.EQ.0.0E0) GO TO 90 C IF (RVAR/WTI-SM.LE.0.0E0) 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 *NLCNTA SUBROUTINE NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, + RES, LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, + SCALE, LSCALE, DELTA, IVCVOP, NPRT, RSD, PV, LPV, SDPV, LSDPV, + SDRES, LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC (USER-SUPPLIED) DERIVATIVES. 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IDRVCK,IVCV,IVCVOP,IXM,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV, + LSDRES,LWT,M,MIT,N,NNZW,NPAR,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),WT(*), + XM(*),Y(*) INTEGER + IFIXED(*) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + ISUBHD,LDSMIN,LSTP,NDIGIT,NETA,NROW,NTAU LOGICAL + APRXDV,HLFRPT,PAGE,PRTFXD,WIDE C C LOCAL ARRAYS REAL + STP(1) INTEGER + IPTOUT(5) C C EXTERNAL FUNCTIONS INTEGER + ICNTI EXTERNAL ICNTI C C EXTERNAL SUBROUTINES EXTERNAL DCKCNT,LDSCMP,NLCNT,NLDRVA,NLER,NLHDRA,PRTCNT,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 IDRVCK C THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE C TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. C INTEGER IPTOUT(5) C THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IVCV C THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV. C INTEGER IVCVOP C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE C IVCVOP LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED C IVCVOP EQ 1 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 IVCVOP 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 IVCVOP EQ 3 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 IVCVOP EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP GE 7 INDICATES THE DEFAULT OPTION WILL BE USED C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. 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 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 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 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 EXTERNAL NLDRVA C THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES. C EXTERNAL NLHDRA C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTAU C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICALLY APPROXIMATED DERIVATIVES AND THE USER SUPPLIED C DRVITIVES. 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE 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 REAL PV(LPV) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(LSCALE) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL STP(1) C THE DUMMY STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C HLFRPT = .FALSE. APRXDV = .FALSE. PRTFXD = .TRUE. STP(1) = 0.0E0 LSTP = 1 NETA = 0 NTAU = 0 NROW = 0 C WIDE = .TRUE. PAGE = .FALSE. C NDIGIT = 5 C C SET UP FOR ERROR CHECKING C IERR = 0 IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) THEN NPARE = ICNTI(IFIXED,NPAR,0) ELSE NPARE = NPAR END IF C CALL LDSCMP(6, 0, 60+2*NPAR, 0, 0, 0, 'S', + 94+N*(3+NPAR)+NPARE*(3*NPARE+35)/2, LDSMIN) C CALL NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM, + IFIXED, LIFIXD, NPAR, NPARE, + LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW) C IF (IERR.NE.0) RETURN C CALL STKSET(LDSTAK, 4) C C SET PRINT CONTROL VALUES C CALL PRTCNT(NPRT, NDIGIT, IPTOUT) C IF (IDRVCK.EQ.0) GO TO 10 C C CHECK DERIVATIVES, IF DESIRED C ISUBHD = 1 CALL DCKCNT(XM, N, M, IXM, MDL, DRV, PAR, NPAR, NETA, NTAU, + SCALE, LSCALE, NROW, IPTOUT(1), NLHDRA, PAGE, WIDE, ISUBHD, + HLFRPT, PRTFXD, IFIXED, LIFIXD) C C CHECK FOR DEFINITE ERROR IN DERIVATIVES C IF (IERR.LE.2) GO TO 10 IERR = 1 RETURN C 10 CONTINUE C IERR = 0 C CALL NLCNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRVA, APRXDV, DRV, + PAR, NPAR, RES, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, + SCALE, LSCALE, DELTA, IVCVOP, RSD, PV, LPV, SDPV, LSDPV, + SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, NPARE, NLHDRA, + PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT) C RETURN C END *NLCNT SUBROUTINE NLCNT(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) 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,IXM,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,M, + MIT,N,NDIGIT,NNZW,NPAR,NPARE LOGICAL + APRXDV,HLFRPT,PAGE,SAVE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + WT(*),XM(*),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, + RWORK,SDPVI,SDRESI,VCVL C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYASF,CPYVII,NLMN,SCOPY,SETIV,STKCLR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 REAL 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 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 REAL 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 REAL 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 REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER RWORK C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE REAL 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 REAL SCALE(LSCALE) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL 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 REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C INTEGER SDRESI C THE STARTING LOCATION IN RWORK OF THE C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL STP(LSTP) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C NALL0 = STKST(1) C IFP = 3 C IERR = 0 C C SUBDIVIDE WORK AREA FOR LEAST SQUARES ANALYSIS C IIWORK = NPARE + 60 IRWORK = 94 + 2*N + NPARE*(3*NPARE+33)/2 C IFIXD = STKGET(NPAR,2) IWORK = STKGET(IIWORK,2) C D = STKGET(N*NPAR,IFP) PARE = STKGET(NPARE,IFP) PVI = STKGET(N,IFP) 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 NLMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, MDL, NLDRV, + APRXDV, DRV, ISTAK(IFIXD), PAR, RSTAK(PARE), NPAR, RES, PAGE, + WIDE, HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, + DELTA, IVAPRX, IPTOUT, NDIGIT, RSD, RSTAK(PVI), SDPVI, + SDRESI, VCVL, LVCVL, RSTAK(D), ISTAK(IWORK), IIWORK, + RSTAK(RWORK), IRWORK, NLHDR, NPARE) C IF (.NOT.SAVE) GO TO 10 C SDPVI = RWORK + SDPVI - 1 SDRESI = RWORK + SDRESI - 1 VCVL = RWORK + VCVL - 1 C CALL SCOPY(N, RSTAK(PVI), 1, PV, 1) CALL SCOPY(N, RSTAK(SDPVI), 1, SDPV, 1) CALL SCOPY(N, RSTAK(SDRESI), 1, SDRES, 1) CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV) C 10 CALL STKCLR(NALL0) C RETURN C END *NLCNTN SUBROUTINE NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVCVOP, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, 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 - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IVCV,IVCVOP,IXM,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV,LSDRES, + LSTP,LWT,M,MIT,N,NNZW,NPAR,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + WT(*),XM(*),Y(*) INTEGER + IFIXED(*) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + EXMPT INTEGER + IFP,IS,ISUBHD,LDSMIN,NALL0,NDIGIT,NETA,STPI LOGICAL + APRXDV,HLFRPT,PAGE,PRTFXD,WIDE C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + IPTOUT(5),ISTAK(12) C C EXTERNAL FUNCTIONS INTEGER + ICNTI,STKGET,STKST EXTERNAL ICNTI,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL DRV,LDSCMP,NLCNT,NLDRVN,NLER,NLHDRN,PRTCNT,SCOPY,STKCLR, + STKSET,STPCNT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL 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 REAL 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 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 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. 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 INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IVCV C THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV. C INTEGER IVCVOP C AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED C TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE C IVCVOP LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED C IVCVOP EQ 1 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 IVCVOP 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 IVCVOP EQ 3 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 IVCVOP EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(HESSIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C USING ONLY THE MODEL SUBROUTINE C IVCVOP GE 7 INDICATES THE DEFAULT OPTION WILL BE USED C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. 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 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 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 INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C EXTERNAL NLDRVN C THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES. C EXTERNAL NLHDRN C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE 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 REAL PV(LPV) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C REAL RSTAK(12) C THE REAL 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 REAL SCALE(LSCALE) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(LSDPV) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDRES(LSDRES) C THE STANDARDIZED RESIDUALS. C REAL 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 REAL 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 REAL STP(LSTP) C THE STEP SIZE ARRAY. C INTEGER STPI C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET VARIOUS PROGRAM VALUES C HLFRPT = .FALSE. APRXDV = .TRUE. PRTFXD = .TRUE. EXMPT = -1.0E0 NETA = 0 C WIDE = .TRUE. PAGE = .FALSE. C NDIGIT = 5 C C SET UP FOR ERROR CHECKING C IERR = 0 IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) THEN NPARE = ICNTI(IFIXED,NPAR,0) ELSE NPARE = NPAR END IF C IF (STP(1).LE.0.0E0) THEN IS = 1 ELSE IS = 0 END IF C CALL LDSCMP(14, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE), 0, 0, 0, + 'S', + MAX(IS*(9*N+MAX(N,NPAR)),94+N*(3+NPAR)+NPARE*(3*NPARE+37)/2), + LDSMIN) C CALL NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM, + IFIXED, LIFIXD, NPAR, NPARE, + LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW) 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 = 3 C STPI = STKGET(NPAR,IFP) C C COPY SUPPLIED STEP SIZES TO WORK SPACE C CALL SCOPY(LSTP, STP, 1, RSTAK(STPI), 1) C IF (IERR.NE.0) GO TO 10 C C SELECT STEP SIZES, IF DESIRED C ISUBHD = 1 C IF (STP(1).LE.0.0E0) CALL STPCNT(XM, N, M, IXM, MDL, PAR, NPAR, + RSTAK(STPI), EXMPT, NETA, SCALE, LSCALE, IPTOUT(1), NLHDRN, + PAGE, WIDE, ISUBHD, HLFRPT, PRTFXD, IFIXED, LIFIXD) C CALL NLCNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRVN, APRXDV, DRV, + PAR, NPAR, RES, IFIXED, LIFIXD, RSTAK(STPI), NPAR, MIT, + STOPSS, STOPP, SCALE, LSCALE, DELTA, IVCVOP, RSD, PV, LPV, + SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, + NPARE, NLHDRN, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT) C 10 CONTINUE C CALL STKCLR(NALL0) C RETURN C END *NLDRVA SUBROUTINE NLDRVA (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, + IXM, PV, D, WEIGHT, WT, LWT, STP, LSTP, SCL, LSCL) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE ANALYTIC DERIVATIVE MATRIX (JACOBIAN) C USING USER-SUPPLIED ROUTINE DERIV. 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,LSTP,LWT,M,N,NPAR LOGICAL + DONE,WEIGHT C C ARRAY ARGUMENTS REAL + D(N,NPAR),PAR(NPAR),PV(N),SCL(LSCL),STP(LSTP),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 REAL + WTSQRT INTEGER + I,J,JPK C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL D(N,NPAR) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. 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 INDEXING VARIABLE. 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER JPK C THE INDEX OF THE PACKED PARAMETERS. C INTEGER LSCL C THE ACTUAL LENGTH OF THE VECTOR SCL. C INTEGER LSTP C THE ACTUAL LENGTH OF THE VECTOR STP. C INTEGER LWT C THE ACTUAL LENGTH OF THE 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES C REAL SCL(LSCL) C THE SCALE VALUES. C REAL STP(LSTP) C THE SELECTED RELATIVE STEP SIZES. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL WTSQRT C THE SQUARE ROOT OF THE ITH WEIGHT. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++ C C COMPUTE JACOBIAN C CALL DRV(PAR, NPAR, XM, N, M, IXM, D) C JPK = 0 C DO 20 J=1,NPAR IF (IFIXD(J).NE.0) GO TO 20 JPK = JPK + 1 DO 10 I=1,N WTSQRT = 1.0E0 IF (WEIGHT .AND. (.NOT.DONE)) WTSQRT = SQRT(WT(I)) D(I,JPK) = -WTSQRT*D(I,J) 10 CONTINUE 20 CONTINUE C RETURN C 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 REAL + 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 REAL + PJ,STPJ,WTSQRT INTEGER + I,J,JPK C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,SIGN,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PJ C A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER. C REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL SCL(LSCL) C THE SCALE VALUES. C REAL STPT(LSTPT) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL WTSQRT C THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE. 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.0E0) THEN IF (PAR(J).NE.0.0E0) THEN STPJ = STPT(J)*SIGN(1.0E0,PAR(J))*ABS(PAR(J)) ELSE STPJ = STPT(J) END IF ELSE STPJ = STPT(J)* + SIGN(1.0E0,PAR(J))*MAX(ABS(PAR(J)),1.0E0/ + 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.0E0 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 *NLER SUBROUTINE NLER (NMSUB, WEIGHT, WT, LWT, N, M, IXM, + IFIXED, LIFIXD, NPAR, NPARE, + LDSTAK, LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, NNZW) 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 - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IVCV,IXM,LDSMIN,LDSTAK,LIFIXD,LSCALE,LSTP,LWT,M,N,NNZW, + NPAR,NPARE LOGICAL + SAVE,WEIGHT C C ARRAY ARGUMENTS REAL + SCALE(*),STP(*),WT(*) INTEGER + IFIXED(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NFIX,NNFIX,NV,NZW LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(20) CHARACTER + LIFIX(8)*1,LIVCV(8)*1,LIXM(8)*1,LLDS(8)*1,LM(8)*1, + LN(8)*1,LNPAR(8)*1,LNPARE(8)*1,LONE(8)*1,LSCL(8)*1, + LSTEP(8)*1,LWGT(8)*1,LZERO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EIVEQ,ERVGT,ERVWT C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 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 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 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. IF C IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED. IF C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. C INTEGER IVCV C THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. 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 C + LIFIX(8), LIVCV(8), LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8), C + LNPARE(8), LONE(8), LSCL(8), LSTEP(8), LWGT(8), LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LSCALE C THE ACTUAL LENGTH OF THE VECTOR SCALE. C INTEGER LSTP C THE ACTUAL LENGTH OF THE VECTOR STP. C INTEGER LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C INTEGER NPARE C THE NUMBER OF PARAMETERS TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NZW C THE NUMBER OF ZERO WEIGHTS. 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL STP(LSTP) C THE STEP SIZE ARRAY. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C C C SET UP NAME ARRAYS C DATA LIFIX(1), LIFIX(2), LIFIX(3), LIFIX(4), LIFIX(5), + LIFIX(6), LIFIX(7), LIFIX(8) /'I','F','I','X','E','D',' ',' '/ DATA LIVCV(1), LIVCV(2), LIVCV(3), LIVCV(4), LIVCV(5), + LIVCV(6), LIVCV(7), LIVCV(8) /'I','V','C','V',' ',' ',' ',' '/ DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6), + LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M', + ' ',' ',' ',' ',' ',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ 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) /'O','N','E',' ',' ',' ',' ',' '/ 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 LWGT(1), LWGT(2), LWGT(3), LWGT(4), LWGT(5), + LWGT(6), LWGT(7), LWGT(8) /'W','T',' ',' ',' ',' ',' ',' '/ 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. NNZW = N C CALL EISGE(NMSUB, LNPAR, NPAR, 1, 2, HEAD, ERROR(1), LONE) IF (ERROR(1)) THEN ERROR(7) = .TRUE. ELSE IF (IFIXED(1).LT.0) THEN CALL EISGE(NMSUB, LN, N, NPAR, 2, HEAD, ERROR(7), LNPAR) IF (WEIGHT) THEN CALL ERVWT(NMSUB, LWGT, WT, LWT, NPAR, HEAD, NNZW, + NZW, 2, ERROR(3), LNPAR) END IF ELSE CALL EIVEQ(NMSUB, LIFIX, IFIXED, NPAR, 0, 1, HEAD, NNFIX, + NFIX, 1, ERROR(2), LZERO, LONE) IF (.NOT.ERROR(2)) THEN CALL EISGE(NMSUB, LN, N, NPARE, 2, HEAD, ERROR(7), LNPARE) IF (WEIGHT) THEN CALL ERVWT(NMSUB, LWGT, WT, LWT, NPARE, HEAD, NNZW, + NZW, 2, ERROR(3), LNPARE) END IF END IF END IF END IF C CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERROR(4), LONE) C IF (.NOT.ERROR(7)) + CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(5), LN) C C IF (.NOT.ERROR(1)) THEN IF ((.NOT.ERROR(2)) .AND. (.NOT.ERROR(7))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6), + LLDS) C CALL ERVGT(NMSUB, LSTEP, STP, LSTP, 0.0E0, 0, HEAD, 6, NV, + ERROR(8), LZERO) C CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV, + ERROR(12), LZERO) C IF (SAVE) + CALL EISGE(NMSUB, LIVCV, IVCV, NPARE, 3, HEAD, ERROR(15), + LNPARE) END IF C C DO 20 I=1,20 IF (ERROR(I)) GO TO 30 20 CONTINUE RETURN C 30 CONTINUE IERR = 1 RETURN C 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 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 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 *NLFIN SUBROUTINE NLFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, + PAR, NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RSSHLF, RSD, + PV, SDPV, SDRES, RD, VCVL, LVCVL, D, NLHDR, IVCVPT, ISKULL) 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 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 REAL + RSD,RSSHLF INTEGER + IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE LOGICAL + PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + D(N,NPAR),PAR(NPAR),PV(N),RD(NPARE),RES(N),SDPV(N),SDRES(N), + VCVL(LVCVL),WT(LWT),XM(IXM,M),Y(N) INTEGER + IFIXD(NPAR),IPTOUT(NDIGIT),ISKULL(10) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + COND,RSS,YSS INTEGER + IDF LOGICAL + EXACT,PRTFSM C C EXTERNAL SUBROUTINES EXTERNAL NLCMP,NLOUT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COND C THE CONDITION NUMBER OF D. C REAL D(N,NPAR) C THE 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 INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. 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) HAVE BEEN HELD FIXED. C IF IFIXED(I).EQ.0, THEN PAR(I) HAVE BEEN 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(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) C IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS C INVERSE(HESSIAN) C IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS C INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN) C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. 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 N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. 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 PRTFSM C THE VARIABLE USED TO INDICATE WHETHER ANY OF THE SUMMARY C INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE). C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RD(NPARE) C THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R C FACTORIZATION OF D. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSSHLF C HALF THE RESIDUAL SUM OF SQUARES. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL VCVL(LVCVL) C THE LOWER HALF OF THE 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C REAL YSS C THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y. C 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, PV, SDPV, SDRES, 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 NLOUT(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, + IFIXD, PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, + RSS, RSD, YSS, EXACT, PV, SDPV, SDRES, VCVL, LVCVL, IVCVPT, + ISKULL, NLHDR, WIDE) RETURN C END *NLHDRA SUBROUTINE NLHDRA(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 THAT USE ANALYTIC C (USER-SUPPLIED) DERIVATIVES. 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 + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (35H+NONLINEAR LEAST SQUARES ESTIMATION, + 42H WITH USER-SUPPLIED DERIVATIVES, CONTINUED) 1010 FORMAT ('+', 71(1H*)/ + 1X, 37H* NONLINEAR LEAST SQUARES ESTIMATION, + 34H WITH USER-SUPPLIED DERIVATIVES */ 1X, 71(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) END *NLHDRN SUBROUTINE NLHDRN(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 THAT USE NUMERICAL C 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 - OCTOBER 3, 1983 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (35H+NONLINEAR LEAST SQUARES ESTIMATION, + 53H WITH NUMERICALLY APPROXIMATED DERIVATIVES, CONTINUED) 1010 FORMAT ('+', 82(1H*)/ + 1X, 37H* NONLINEAR LEAST SQUARES ESTIMATION, + 45H WITH NUMERICALLY APPROXIMATED DERIVATIVES */ 1X, 82(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) 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 REAL + DELTA,STOPP,STOPSS INTEGER + IIWORK,IRWORK,IVAPRX,IVCVPT,LSCALE,MIT,N,NPAR,NPARE,SCL LOGICAL + APRXDV C C ARRAY ARGUMENTS REAL + 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 REAL + 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 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 REAL 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.0E0 C INIDCATES NO, AND THE VALUE RWORK(DINIT) = -1.0E0 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 REAL 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL 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 REAL RWORK(IRWORK) C THE REAL WORK VECTOR USED BY THE NL2 SUBROUTINES. C REAL 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 REAL 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 REAL 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 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.0E0) .AND. (STOPP.LE.1.0E0)) + 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.0E0) 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.0E0) RWORK(SCLJ) = 1.0E0 IF (PAR(J).NE.0.0E0) RWORK(SCLJ) = 1.0E0/ABS(PAR(J)) 30 CONTINUE C GO TO 60 C 40 IWORK(DTYPE) = 0 RWORK(DINIT) = -1.0E0 SCLJ = SCL - 1 DO 50 J=1,NPAR IF (IFIXD(J).NE.0) GO TO 50 SCLJ = SCLJ + 1 RWORK(SCLJ) = 1.0E0/MAX(ABS(SCALE(J)),ABS(PAR(J))) 50 CONTINUE C 60 IF (DELTA.LE.0.0E0) RWORK(LMAX0) = 100.0E0 IF (DELTA.GT.0.0E0) 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 *NLISM SUBROUTINE NLISM (NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, + WEIGHT, IFIXD, PAR, SCALE, IWORK, IIWORK, RWORK, IRWORK, RES, + APRXDV, STP, LSTP, 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. 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,IRWORK,LSTP,M,N,NNZW,NPAR,NPARE LOGICAL + APRXDV,HLFRPT,PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),RES(N),RWORK(IRWORK),SCALE(NPAR),STP(LSTP) INTEGER + IFIXD(NPAR),IWORK(IIWORK) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C LOCAL SCALARS REAL + RSD,RSS INTEGER + I,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL C C EXTERNAL FUNCTIONS REAL + SNRM2 EXTERNAL SNRM2 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC REAL,SQRT 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 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 INDEX VARIABLE 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 REAL WORK VECTOR RWORK. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IWORK(IIWORK) C THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES. 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 LSTP C THE ACTUAL LENGTH OF THE VECTOR STP. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. 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 COVARIANCE C 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 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 UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPARE C NUMBER OF PARAMETERS ESTIMATED BY ROUTINE. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. 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 REAL RES(N) C THE RESIDUALS FROM THE FIT. C INTEGER RFCTOL C THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE C TOLERANCE. C REAL RSD C THE RESIDUAL STANDARD DEVIATION AT THE INITIAL PARAMETER VALUES C REAL RSS C THE RESIDUAL SUM OF SQUARES AT THE INITIAL PARAMETER VALUES C REAL RWORK(IRWORK) C THE REAL WORK VECTOR USED BY THE NL2 SUBROUTINES. C REAL SCALE(NPAR) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C REAL STP(LSTP) C THE SELECTED RELATIVE STEP SIZES. 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 FULL WIDTH (TRUE) OR NOT (FALSE). C INTEGER XCTOL C THE LOCATION IN RSTAK/DSTAK OF THE P CONVERGENCE TOLERANCE. C C IWORK SUBSCRIPT VALUES C DATA MXFCAL/17/, MXITER/18/ C C RWORK SUBSCRIPT VALUES C DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/ C CALL IPRINT(IPRT) C IF (.NOT.HLFRPT) THEN C ISUBHD = 1 CALL NLHDR(PAGE, WIDE, ISUBHD) C IF (APRXDV) THEN WRITE (IPRT, 1260) ELSE WRITE (IPRT, 1270) END IF C DO 40 I = 1, NPAR IF (IFIXD(I).EQ.0) THEN IF (SCALE(1).GT.0.0E0) THEN IF (APRXDV) THEN WRITE (IPRT, 1410) I, PAR(I), SCALE(I), STP(I) ELSE WRITE (IPRT, 1410) I, PAR(I), SCALE(I) END IF ELSE IF (APRXDV) THEN WRITE (IPRT, 1310) I, PAR(I), STP(I) ELSE WRITE (IPRT, 1310) I, PAR(I) END IF END IF ELSE IF (APRXDV) THEN WRITE (IPRT, 1510) I, PAR(I) ELSE WRITE (IPRT, 1610) I, PAR(I) END IF END IF 40 CONTINUE C WRITE (IPRT, 1160) N C END IF C IF (WEIGHT) WRITE (IPRT, 1170) NNZW WRITE (IPRT, 1180) M WRITE(IPRT, 1070) IWORK(MXITER) WRITE(IPRT, 1090) IWORK(MXFCAL) WRITE(IPRT, 1080) WRITE(IPRT, 1100) RWORK(RFCTOL) WRITE(IPRT, 1110) RWORK(XCTOL) WRITE(IPRT, 1120) RWORK(LMAX0) C RSD = SNRM2(N, RES, 1) RSS = RSD * RSD IF (NNZW-NPARE.GE.1) RSD = RSD /SQRT(REAL(NNZW-NPARE)) WRITE (IPRT, 1200) RSS WRITE (IPRT, 1210) RSD C RETURN C C FORMAT STATEMENTS C 1070 FORMAT (/37H MAXIMUM NUMBER OF ITERATIONS ALLOWED, 32X, 5H(MIT), + 1X, I5) 1080 FORMAT(/44H CONVERGENCE CRITERION FOR TEST BASED ON THE/) 1090 FORMAT(/41H MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS, + 8H ALLOWED, 26X, I5) 1100 FORMAT (5X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL, + 15H SUM OF SQUARES, 7X, 8H(STOPSS), 1X, G11.4) 1110 FORMAT(5X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS, + 13X, 7H(STOPP), 1X, G11.4) 1120 FORMAT(//41H MAXIMUM CHANGE ALLOWED IN THE PARAMETERS, + 23H AT THE FIRST ITERATION, 3X, 7H(DELTA), 1X, G11.4) 1160 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5) 1170 FORMAT (/41H NUMBER OF NON ZERO WEIGHTED OBSERVATIONS, 27X, + 6H(NNZW), 1X, I5) 1180 FORMAT (/32H NUMBER OF INDEPENDENT VARIABLES, 39X, 3H(M), 1X, I5) 1200 FORMAT (/44H RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER, + 7H VALUES, 24X, G11.4) 1210 FORMAT (/48H RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER, + 7H VALUES, 14X, 5H(RSD), 1X, G11.4) 1260 FORMAT (//50X, 13HSTEP SIZE FOR/ + 50X, 13HAPPROXIMATING/ + 7X, 24HPARAMETER STARTING VALUE, 6X, 5HSCALE, 10X, + 10HDERIVATIVE/ + 1X, 5HINDEX, 2X, 5HFIXED, 6X, 5H(PAR), 12X, 7H(SCALE), 11X, + 5H(STP)/) 1270 FORMAT (//6X, 25HPARAMETER STARTING VALUES, 5X, 5HSCALE/ + 1X, 5HINDEX, 2X, 5HFIXED, 6X, 5H(PAR), 11X, 7H(SCALE)/) 1310 FORMAT (1X, I3, 5X, ' NO', G17.8, 7X, 7HDEFAULT, 3X, G17.8) 1410 FORMAT (1X, I3, 5X, ' NO', 3G17.8) 1510 FORMAT (1X, I3, 5X, 'YES', G17.8, 9X, '---', 14X, '---') 1610 FORMAT (1X, I3, 5X, 'YES', G17.8, 9X, '---') 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 REAL + PARE(NPAR),RWORK(IRWORK) INTEGER + IFIXD(NPAR),IWORK(IIWORK) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C LOCAL SCALARS REAL + RSD,RSS,RSSC,RSSPC INTEGER + DST0,F,F0,FDIF,ICASE,IPRT,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 IPRINT,LSTVCF C C INTRINSIC FUNCTIONS INTRINSIC MOD,REAL,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 REAL 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 REAL 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 REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL RSSC C THE CHANGE IN THE RESIDUAL SUM OF SQUARES CAUSED BY THIS C ITERATION. C REAL RSSPC C THE PREDICTED CHANGE IN THE RESIDUAL SUM OF SQUARES AT THIS C ITERATION. C REAL RWORK(IRWORK) C THE REAL 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 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 CALL IPRINT(IPRT) 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 (IPRT,1000) IWORK(NITER) C C COMPUTE STATISTICS TO BE PRINTED C RSS = 2.0E0*RWORK(F) RSD = SQRT(RSS) IF (NNZW-NPARE.GE.1) RSD = RSD/SQRT(REAL(NNZW-NPARE)) C RSSC = 0.0E0 IF (RWORK(F0).GT.0.0E0) RSSC = RWORK(FDIF)/RWORK(F0) C RSSPC = 0.0E0 IF (RWORK(F0).GT.0.0E0) 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.0E0*RWORK(PREDUC)) GO TO 10 IF (RWORK(DST0).LT.0.0E0) GO TO 10 IF (RWORK(NREDUC).GE.0.0E0) ISCHKD(1) = LETTRY IF (RWORK(STPPAR).EQ.0.0E0) ISCHKD(2) = LETTRY 10 CONTINUE C WRITE (IPRT,1010) IWORK(NFCALL), RSD, RSS, RSSC, RSSPC, + ISCHKD(1), RWORK(RELDX), ISCHKD(2) IF (NPARE.LT.NPAR) WRITE (IPRT,1020) IF (NPARE.GE.NPAR) WRITE (IPRT,1150) 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 WRITE (IPRT,1030) RETURN C C ***** RESIDUAL SUM OF SQUARES CONVERGENCE ***** C 30 WRITE (IPRT,1040) RETURN C C ***** PARAMETER AND RESIDUAL SUM OF SQUARES CONVERGENCE **** C 40 WRITE (IPRT,1050) RETURN C C ***** RESIDUAL SUM OF SQUARES IS EXACTLY ZERO ***** C 50 WRITE (IPRT,1060) RETURN C C ***** SINGULAR CONVERGENCE ***** C 60 WRITE (IPRT,1070) RETURN C C ***** FALSE CONVERGENCE ***** C 70 WRITE (IPRT,1080) RETURN C C ***** LIMIT ON NUM. OF CALLS TO THE MODEL SUBROUTINE REACHED ***** C 80 WRITE (IPRT,1090) RETURN C C ***** ITERATION LIMIT REACHED ***** C 90 WRITE (IPRT,1100) RETURN C C ***** STOPX ***** C 100 WRITE (IPRT,1110) RETURN C C ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ***** C 110 WRITE (IPRT,1120) RETURN C C ***** BAD PARAMETERS TO ASSESS ***** C 120 WRITE (IPRT,1130) RETURN C C ***** J COULD NOT BE COMPUTED ***** C 130 WRITE (IPRT,1140) RETURN C 140 RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//17H ITERATION NUMBER, I5/1X, 22('-')) 1010 FORMAT (5X, 5HMODEL, 53X, 10HFORECASTED/5X, 5HCALLS, 9X, 3HRSD, + 13X, 3HRSS, 8X, 12HREL CHNG RSS, 4X, 12HREL CHNG RSS, 4X, + 12HREL CHNG PAR/62X, 5HVALUE, 3X, 4HCHKD, 4X, 5HVALUE, 3X, + 4HCHKD/3X, I7, 3(2X, G14.4), 2(G12.4, 3X, A1)) 1020 FORMAT (/5X, 25H CURRENT PARAMETER VALUES, 19H (ONLY UNFIXED PARA, + 18HMETERS ARE LISTED)) 1030 FORMAT (/34H ***** PARAMETER CONVERGENCE *****) 1040 FORMAT (/48H ***** RESIDUAL SUM OF SQUARES CONVERGENCE *****) 1050 FORMAT (/44H ***** PARAMETER AND RESIDUAL SUM OF SQUARES, + 18H CONVERGENCE *****) 1060 FORMAT (/50H ***** THE RESIDUAL SUM OF SQUARES IS EXACTLY ZERO, + 6H *****) 1070 FORMAT (/33H ***** SINGULAR CONVERGENCE *****) 1080 FORMAT (/30H ***** FALSE CONVERGENCE *****) 1090 FORMAT (/44H ***** LIMIT ON NUMBER OF CALLS TO THE MODEL, + 25H SUBROUTINE REACHED *****) 1100 FORMAT (/36H ***** ITERATION LIMIT REACHED *****) 1110 FORMAT (/18H ***** STOPX *****) 1120 FORMAT (/53H ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ****, + 1H*) 1130 FORMAT (/37H ***** BAD PARAMETERS TO ASSESS *****) 1140 FORMAT (/52H ***** DERIVATIVE MATRIX COULD NOT BE COMPUTED *****) 1150 FORMAT (/5X, 25H CURRENT PARAMETER VALUES) END *NLMN SUBROUTINE NLMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, MDL, + NLDRV, APRXDV, DRV, IFIXD, PAR, PARE, NPAR, RES, PAGE, WIDE, + HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, DELTA, + IVAPRX, IPTOUT, NDIGIT, RSD, PV, SDPVI, SDRESI, VCVL, LVCVL, D, + IWORK, IIWORK, RWORK, IRWORK, NLHDR, NPARE) 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IIWORK,IRWORK,IVAPRX,IXM,LSCALE,LSTP,LVCVL,LWT,M,MIT,N, + NDIGIT,NNZW,NPAR,NPARE,SDPVI,SDRESI,VCVL LOGICAL + APRXDV,HLFRPT,PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + D(N,NPAR),PAR(NPAR),PARE(NPAR),PV(N),RES(N),RWORK(IRWORK), + SCALE(LSCALE),STP(LSTP),WT(LWT),XM(IXM,M),Y(N) INTEGER + IFIXD(NPAR),IPTOUT(NDIGIT),IWORK(IIWORK) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL,NLDRV,NLHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + WTSQRT 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 NL2ITR,NLERR,NLFIN,NLINIT,NLISM,NLITRP,NLSUPK C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 REAL D(N,NPAR) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C REAL 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 REAL 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 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 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 NLDRV C THE NAME OF THE ROUTINE WHICH CALCULATED 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 OPTIMIZED. 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 REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL 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 REAL PV(N) C THE PREDICTED VALUES. 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 REAL RES(N) C THE RESIDUALS FROM THE FIT. C INTEGER RSAVE C THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK C THE ARRAY RSAVE. C REAL 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 REAL RWORK(IRWORK) C THE REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL WTSQRT C THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. 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 (N, 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 C COMPUTE RESIDUALS C 10 CALL MDL(PAR, NPAR, XM, N, M, IXM, PV) C DO 20 I=1,N WTSQRT = 1.0E0 IF (WEIGHT) WTSQRT = SQRT(WT(I)) RES(I) = WTSQRT*(Y(I)-PV(I)) 20 CONTINUE C C PRINT INITIAL SUMMARY C IF (.NOT.PRTSMY) GO TO 30 CALL NLISM(NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, WEIGHT, + IFIXD, PAR, SCALE, IWORK, IIWORK, RWORK, IRWORK, RES, 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 MDL(PAR, NPAR, XM, N, M, IXM, PV) C CALL NLDRV (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, IXM, + PV, 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, N, N, NPARE, RES, 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 C EQUIVALENCE LOCATIONS WITHIN RWORK. C 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 CALL NLFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, PAR, + NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RWORK(RSSHLF), + RSD, PV, RWORK(SDPVI), RWORK(SDRESI), RWORK(RDI), RWORK(VCVL), + LVCVL, D, NLHDR, IVCVPT, ISKULL) C RETURN C END *NLOUT SUBROUTINE NLOUT(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, + PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, RSS, + RSD, YSS, EXACT, PV, SDPV, SDRES, VCVL, LVCVL, IVCVPT, ISKULL, + NLHDR, WIDE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE FINAL SUMMARY OUTPUT FROM THE C NONLINEAR LEAST SQUARES SUBOUTINES. 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 REAL + COND,RSD,RSS,YSS INTEGER + IDF,IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE LOGICAL + EXACT,PAGE,WEIGHT,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCVL(LVCVL),WT(LWT), + XM(IXM,M),Y(N) INTEGER + IFIXD(NPAR),IPTOUT(NDIGIT),ISKULL(10) C C SUBROUTINE ARGUMENTS EXTERNAL NLHDR C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + FPLM,PLL,PUL,RATIO,SDPAR,T INTEGER + I,IPK,IPK2,IPRT,ISUBHD C C EXTERNAL FUNCTIONS REAL + PPFT,R1MACH EXTERNAL PPFT,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL FITPT1,FITPT2,IPRINT,NLSKL,VCVOTF C C INTRINSIC FUNCTIONS INTRINSIC MAX,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL COND C THE CONDITION NUMBER OF D. C LOGICAL EXACT C AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT C WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE). C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM IN THE FIT. 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 IPK C AN INDEX. C INTEGER IPK2 C THE INDEX OF THE "DIAGONAL" ELEMENT OF THE VCV C MATRIX. C INTEGER IPRT C THE LOGICAL UNIT 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 ISUBHD C AN INTEGER 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LVCVL C THE LENGTH OF THE VECTOR CONTANING 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 N C THE NUMBER OF OBSERVATIONS. C INTEGER NDIGIT C THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE. 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 REAL PAR(NPAR) C THE PARAMETER ESTIMATES. C LOGICAL PAGE C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT C IS TO BEGIN ON A NEW PAGE. C REAL PLL, PUL C THE LOWER AND UPPER CONFIDENCE LIMITS FOR A GIVEN PARAMETER. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RATIO C THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. C REAL RSS C THE RESIDUAL SUM OF SQUARES. C REAL SDPAR C THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL T C THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C REAL VCVL(LVCVL) C THE LOWER HALF OF THE 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 REAL WT(LWT) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C REAL YSS C THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y. C C FPLM = R1MACH(2) C 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, NLHDR) C C PRINT PRIMARY REPORT C IF ((IERR.EQ.0) .AND. (IPTOUT(3).EQ.0)) GO TO 10 ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) CALL FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, NNZW, + WEIGHT, MAX(1, IPTOUT(3))) C C PRINT STANDARDIZED RESIDUAL PLOTS C 10 IF (IPTOUT(4).EQ.0) GO TO 20 ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) C CALL FITPT2 (SDRES, PV, WT, N, NNZW, WEIGHT, RES, RSS) C C PRINT THE COVARIANCE AND CORRELATION MATRIX C 20 IF ((IERR.EQ.0) .AND. (IPTOUT(5).EQ.0)) RETURN ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) 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 WRITE (IPRT,1000) WRITE (IPRT,1010) C T = PPFT(0.975E0,IDF) IPK = 0 DO 50 I=1,NPAR C IF (IFIXD(I).EQ.0) GO TO 40 C WRITE (IPRT,1030) I, PAR(I) GO TO 50 C 40 IPK = IPK + 1 IPK2 = IPK*(IPK-1)/2 + IPK RATIO = FPLM SDPAR = SQRT(VCVL(IPK2)) IF (SDPAR.GT.0.0E0) RATIO = PAR(I)/SDPAR PLL = PAR(I) - T*SDPAR PUL = PAR(I) + T*SDPAR WRITE (IPRT,1020) I, PAR(I), SDPAR, RATIO, PLL, PUL 50 CONTINUE WRITE (IPRT,1040) RSS, RSD, NNZW, NPARE, IDF WRITE (IPRT,1050) COND C IF (RSS.GT.YSS) WRITE (IPRT,1060) C RETURN C C PRINT OUT ERROR HEADING C 60 CALL NLSKL(ISKULL, PAGE, WIDE, NLHDR) C IF (IERR.LE.2) RETURN C C PRINT SECONDARY REPORT C 70 CONTINUE ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) IF (IERR.NE.0) WRITE (IPRT,1080) WRITE (IPRT,1000) WRITE (IPRT,1100) DO 80 I=1,NPAR IF (IFIXD(I).EQ.0) WRITE (IPRT,1110) I, PAR(I) IF (IFIXD(I).NE.0) WRITE (IPRT,1120) I, PAR(I) 80 CONTINUE WRITE (IPRT,1040) RSS, RSD, NNZW, NPARE, IDF IF (IERR.NE.3) WRITE (IPRT,1050) COND C IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) WRITE + (IPRT,1070) IF ((IERR.EQ.0) .AND. EXACT) WRITE (IPRT,1090) C IF (IERR.NE.0) GO TO 100 C DO 90 I=1,N SDRES(I) = 0.0E0 SDPV(I) = 0.0E0 90 CONTINUE C RETURN C 100 CONTINUE C DO 110 I=1,N SDRES(I) = FPLM SDPV(I) = FPLM 110 CONTINUE C C PRINT OUT ERROR EXIT STATISTICS C CALL FITPT1(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, NNZW, + WEIGHT, MAX(IPTOUT(3),1)) C C C WIPE OUT SDRES VECTOR C DO 120 I=1,N SDRES(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 1000 FORMAT (///33H ESTIMATES FROM LEAST SQUARES FIT/1X, 33('-')) 1010 FORMAT (//69X, 11HAPPROXIMATE/61X, 28H95 PERCENT CONFIDENCE LIMITS + /1X, 5HINDEX, 2X, 5HFIXED, 3X, 9HPARAMETER, 8X, 9HSD OF PAR, + 7X, 5HRATIO, 12X, 5HLOWER, 12X, 5HUPPER/) 1020 FORMAT (1X, I3, 5X, 3H NO, 2G17.8, 2X, G10.4, 2G17.8) 1030 FORMAT (1X, I3, 5X, 3HYES, G17.8, 10X, 3H---, 8X, 3H---, 15X, + 3H---, 14X, 3H---) 1040 FORMAT (//31H RESIDUAL SUM OF SQUARES , 8X, G15.7//6H RESID, + 25HUAL STANDARD DEVIATION , 8X, G15.7/19H BASED ON DEGREES O, + 9HF FREEDOM, 5X, I4, 3H - , I3, 3H = , I4) 1050 FORMAT (/29H APPROXIMATE CONDITION NUMBER, 10X, G15.7) 1060 FORMAT (52H THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES, + 20H FIT IS GREATER THAN/35H THE SUM OF SQUARES ABOUT THE MEAN , + 19HY OBSERVATION. THE, 14H MODEL IS LESS/17H REPRESENTATIVE O, + 39HF THE DATA THAN A SIMPLE AVERAGE. DATA, 15H AND MODEL SHOU, + 2HLD/48H BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.) 1070 FORMAT (/49H THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO., + 54H STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.) 1080 FORMAT (//40H THE FOLLOWING SUMMARY SHOULD BE USED TO, 8H ANALYZE, + 30H THE ABOVE MENTIONED PROBLEMS.) 1090 FORMAT (/50H THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS, + 35H EXACT TO WITHIN MACHINE PRECISION./20H STATISTICAL ANALYSI, + 33HS OF THE RESULTS IS NOT POSSIBLE.) 1100 FORMAT (//1X, 5HINDEX, 2X, 5HFIXED, 3X, 9HPARAMETER) 1110 FORMAT (1X, I3, 5X, 3H NO, G17.8) 1120 FORMAT (1X, I3, 5X, 3HYES, G17.8) END *NLSC SUBROUTINE NLSC(Y, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK, + IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES 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 - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + DELTA,STOPP,STOPSS INTEGER + IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),SCALE(*),STP(*),XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW, + NPARE LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(NPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(NPAR) C THE STEP SIZE ARRAY. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','C',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .FALSE. C WT(1) = 1.0E0 LIFIXD = NPAR LPV = 1 LSCALE = NPAR LSTP = NPAR LSDPV = 1 LSDRES = 1 LWT = 1 IVCV = 1 C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSC (Y, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, STP, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT)') END *NLSDC SUBROUTINE NLSDC(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE, DELTA, + IVAPRX, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES WITH USER C SUPPLIED CONTROL PARAMETERS. 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 REAL + DELTA,STOPP,STOPSS INTEGER + IDRVCK,IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),SCALE(*),XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW,NPARE LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SDPV(1),SDRES(1),VCV(1,1),WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE C CHECKED OR NOT. 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 IFIXED(NPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL VCV(1,1) C THE STARTING LOCATION IN RSTAK/DSTAK OF C THE COVARIANCE MATRIX. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','D','C',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .FALSE. C WT(1) = 1.0E0 LIFIXD = NPAR LPV = 1 LSCALE = NPAR LSDPV = 1 LSDRES = 1 LWT = 1 IVCV = 1 C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSDC (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT)') END *NLSD SUBROUTINE NLSD(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES (SHORT CALL). 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 + IXM,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),XM(*),Y(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IDRVCK,IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES, + LWT,MIT,NNZW,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SCALE(1),SDPV(1),SDRES(1),VCV(1,1),WT(1) INTEGER + IFIXED(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE C CHECKED OR NOT. 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 IFIXED(1) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(1) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','D',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .FALSE. C WT(1) = 1.0E0 IDRVCK = 1 MIT = -1 STOPSS = -1.0E0 STOPP = -1.0E0 SCALE(1) = -1.0E0 DELTA = -1.0E0 NPRT = -1 IFIXED(1) = -1 IVAPRX = 0 LIFIXD = 1 LPV = 1 LSCALE = 1 LSDPV = 1 LSDRES = 1 LWT = 1 IVCV = 1 C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSD (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK)') END *NLSDS SUBROUTINE NLSDS(Y, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, IDRVCK, 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 NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES WITH USER C SUPPLIED CONTROL PARAMETERS, AND WITH COMPUTED VALUES RETURNED C TO THE USER. 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IDRVCK,IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),XM(*), + Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE C CHECKED OR NOT. 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 IFIXED(NPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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 CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL VCV(IVCV,NPAR) C THE COVARIANCE MATRIX. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','D','S',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .TRUE. C WT(1) = 1.0E0 LIFIXD = NPAR LPV = N LSCALE = NPAR LSDPV = N LSDRES = N LWT = 1 C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSDS (Y, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT,'/ + ' + NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)') END *NLS SUBROUTINE NLS(Y, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES C (SHORT CALL). 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 + IXM,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),XM(*),Y(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT, + MIT,NNZW,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1),WT(1) INTEGER + IFIXED(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(1) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(1) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(1) C THE STEP SIZE ARRAY. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S',' ',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .FALSE. C WT(1) = 1.0E0 STP(1) = -1.0E0 MIT = -1 STOPSS = -1.0E0 STOPP = -1.0E0 SCALE(1) = -1.0E0 DELTA = -1.0E0 NPRT = -1 IFIXED(1) = -1 IVAPRX = 0 LIFIXD = 1 LPV = 1 LSTP = 1 LSCALE = 1 LSDPV = 1 LSDRES = 1 LWT = 1 IVCV = 1 C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLS (Y, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK)') 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 + IPRT,ISUBHD C C EXTERNAL SUBROUTINES 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 CALL IPRINT(IPRT) C ISUBHD = 0 CALL NLHDR(PAGE, WIDE, ISUBHD) C IF (WIDE) THEN WRITE (IPRT,1010) WRITE (IPRT,1020) C WRITE (IPRT,1030) C WRITE (IPRT,1040) C WRITE (IPRT,1050) WRITE (IPRT,1000) END IF WRITE (IPRT,1060) C C VCV COMPUTATION NOT COMPLETED C IF (ISKULL(7).NE.0) WRITE (IPRT,1120) C C MAXIMUM NUMBER OF ITERATIONS REACHED BEFORE CONVERGENCE C IF (ISKULL(6).NE.0) WRITE (IPRT,1100) C C FALSE CONVERGENCE C IF (ISKULL(5).NE.0) WRITE (IPRT,1090) C C MEANINGLESS VCV MATRIX C IF (ISKULL(4).NE.0) WRITE (IPRT,1080) C C PROBLEM IS COMPUTATIONALLY SINGULAR C IF (ISKULL(3).NE.0) WRITE (IPRT,1070) C C INITIAL RESIDUAL SUM OF SQUARES COMPUTATION OVERFLOWED C IF (ISKULL(2).NE.0) WRITE (IPRT,1110) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (///) 1010 FORMAT (/48H W W AA RRRRRRR N N IIII, + 19H N N GGG/31H W W A A R RR , + 38H NN N II NN N G G/12H W W , + 51H A A R R N N N II N N N G/ + 59H WW WW AA AA R RR N N N II N N , + 4HN G/47H W W AAAAAA RRRRRRR N NN N II, + 23H N NN N G GGGGG) 1020 FORMAT (49H W WW W A A R R N N N II , + 21H N N N G G/29H W WW W A A R R , + 41H N N N II N N N G G/9H W W , + 59H AA AA R R N NN II N NN G , + 2HGG/49H W W A A R R N N IIII , + 21H N N GGGG G/) 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 (22H ** ERROR SUMMARY **) 1070 FORMAT (/50H THIS MODEL AND DATA ARE COMPUTATIONALLY SINGULAR., + 29H CHECK YOUR INPUT FOR ERRORS.) 1080 FORMAT (/43H AT LEAST ONE OF THE STANDARDIZED RESIDUALS, 6H COULD, + 47H NOT BE COMPUTED BECAUSE THE STANDARD DEVIATION, 8H OF THE , + 18HRESIDUAL WAS ZERO./37H THE VALIDITY OF THE COVARIANCE MATRI, + 18HX IS QUESTIONABLE.) 1090 FORMAT (/46H THE ITERATIONS DO NOT APPEAR TO BE CONVERGING, + 13H TO A MINIMUM, 41H (FALSE CONVERGENCE), INDICATING THAT THE, + 12H CONVERGENCE, 16H CRITERIA STOPSS/22H AND STOPP MAY BE TOO , + 35HSMALL FOR THE ACCURACY OF THE MODEL, 17H AND DERIVATIVES,, + 52H THAT THERE IS AN ERROR IN THE DERIVATIVE MATRIX, OR/ + 15H THAT THE MODEL, 39H IS DISCONTINUOUS NEAR THE CURRENT COEF, + 18HFICIENT ESTIMATES.) 1100 FORMAT (/53H PROGRAM DID NOT CONVERGE IN THE NUMBER OF ITERATIONS, + 13H OR NUMBER OF, 32H MODEL SUBROUTINE CALLS ALLOWED.) 1110 FORMAT (/50H THE RESIDUAL SUM OF SQUARES COULD NOT BE COMPUTED, + 19H USING THE STARTING, 26H MODEL COEFFICIENT VALUES.) 1120 FORMAT (/44H THE VARIANCE-COVARIANCE MATRIX COULD NOT BE, + 26H COMPUTED AT THE SOLUTION.) 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 REAL + PAR(NPAR),PPAR(NPPAR) INTEGER + MASK(NPAR) C C LOCAL SCALARS INTEGER + I,IPPAR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PPAR(NPPAR) C OUTPUT PARAMETER. THE PACKED VERSION OF PAR. SEE INITIAL C DESCRIPTION. C C COMMENCE BODY OF ROUTINE 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 *NLSS SUBROUTINE NLSS(Y, XM, N, M, IXM, MDL, 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 NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES 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 - APRIL 2, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + WT(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(NPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(NPAR) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(1) C THE DUMMY ARRAY FOR THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','S',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .FALSE. SAVE = .TRUE. C WT(1) = 1.0E0 LIFIXD = NPAR LPV = N LSCALE = NPAR LSTP = NPAR LSDPV = N LSDRES = N LWT = 1 C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSS (Y, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, STP, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT,'/ + ' + NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)') 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 REAL + PAR(NPAR),PARE(NPAR) INTEGER + MASK(NPAR) C C LOCAL SCALARS INTEGER + I,JPK C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PARE(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS BEING OPTIMIZED, C NOT INCLUDING THOSE WHOSE VALUES ARE FIXED. 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 *NLSWC SUBROUTINE NLSWC(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES, + LDSTAK, IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, + NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES C AND WEIGHTS (CONTROL CALL). 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 REAL + DELTA,STOPP,STOPSS INTEGER + IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),SCALE(*),STP(*),WT(*),XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,NNZW, + NPARE LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SDPV(1),SDRES(1),VCV(1,1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(NPAR) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(NPAR) C THE STEP SIZE ARRAY. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','W','C',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .FALSE. C LIFIXD = NPAR LPV = 1 LSCALE = NPAR LSTP = NPAR LSDPV = 1 LSDRES = 1 LWT = N IVCV = 1 C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSWC (Y, WT, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, STP, MIT, STOPSS, STOPP, SCALE,'/ + ' + DELTA, IVAPRX, NPRT)') END *NLSWDC SUBROUTINE NLSWDC(Y, WT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE, DELTA, + IVAPRX, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES, WEIGHTS, AND C USER SUPPLIED CONTROL PARAMETERS. 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 REAL + DELTA,STOPP,STOPSS INTEGER + IDRVCK,IVAPRX,IXM,LDSTAK,M,MIT,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),SCALE(*),WT(*),XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + RSD INTEGER + IPRT,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT,NNZW,NPARE LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SDPV(1),SDRES(1),VCV(1,1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE C TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 IFIXED(NPAR) 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 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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 CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','W','D','C'/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .FALSE. C LIFIXD = NPAR LPV = 1 LSCALE = NPAR LSDPV = 1 LSDRES = 1 LWT = N IVCV = 1 C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSWDC (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT)') END *NLSWD SUBROUTINE NLSWD(Y, WT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES AND WEIGHTS C (SHORT CALL). 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 + IXM,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),WT(*),XM(*),Y(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IDRVCK,IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES, + LWT,MIT,NNZW,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SCALE(1),SDPV(1),SDRES(1),VCV(1,1) INTEGER + IFIXED(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER OR NOT THE DERIVATIVES WE C CHECKED OR NOT. 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 IFIXED(1) 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 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 LWT C THE ACTUAL LENGTH OF THE VECTOR WT. C INTEGER M C THE NUMBER OF INDENDENT 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(1) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','W','D',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .FALSE. C IDRVCK = 1 MIT = -1 STOPSS = -1.0E0 STOPP = -1.0E0 SCALE(1) = -1.0E0 DELTA = -1.0E0 NPRT = -1 IFIXED(1) = -1 IVAPRX = 0 LIFIXD = 1 LPV = 1 LSCALE = 1 LSDPV = 1 LSDRES = 1 LWT = N IVCV = 1 C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSWD (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK)') END *NLSWDS SUBROUTINE NLSWDS (Y, WT, XM, N, M, IXM, MDL, DRV, PAR, + NPAR, RES, LDSTAK, IFIXED, IDRVCK, MIT, STOPSS, STOPP, SCALE, + DELTA, IVAPRX, NPRT, NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV, + IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING ANALYTIC DERIVATIVES, WEIGHTS, AND C USER SUPPLIED CONTROL PARAMETERS, AND WITH COMPUTED VALUES C RETURNED TO THE USER. 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IDRVCK,IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NNZW,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),VCV(*),WT(*), + XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL DRV,MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTA C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE C TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 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 IFIXED(NPAR) 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 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C REAL 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'N', 'L', 'S', 'W', 'D', 'S'/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .TRUE. C LIFIXD = NPAR LPV = N LSCALE = NPAR LSDPV = N LSDRES = N LWT = N C CALL NLCNTA(Y, WT, LWT, XM, N, M, IXM, MDL, DRV, PAR, NPAR, RES, + LDSTAK, IFIXED, LIFIXD, IDRVCK, MIT, STOPSS, STOPP, SCALE, + LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES, + LSDRES, VCV, IVCV, NMSUB, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT, 1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSWDS (Y, WT, XM, N, M, IXM, NLSMDL, NLSDRV,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, IDRVCK, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT,'/ + ' + NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV,', + ' IVCV)') C END *NLSW SUBROUTINE NLSW(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES C AND WEIGHTS (SHORT CALL). 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 + IXM,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),RES(*),WT(*),XM(*),Y(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IPRT,IVAPRX,IVCV,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT, + MIT,NNZW,NPARE,NPRT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS REAL + PV(1),SCALE(1),SDPV(1),SDRES(1),STP(1),VCV(1,1) INTEGER + IFIXED(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(1) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(1).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(1) C A DUMMY ARRAY FOR C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(1) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(1) C A DUMMY ARRAY FOR C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(1) C THE STEP SIZE ARRAY. C REAL VCV(1,1) C A DUMMY ARRAY FOR 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','W',' ',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .FALSE. C STP(1) = -1.0E0 MIT = -1 STOPSS = -1.0E0 STOPP = -1.0E0 SCALE(1) = -1.0E0 DELTA = -1.0E0 NPRT = -1 IFIXED(1) = -1 IVAPRX = 0 LIFIXD = 1 LPV = 1 LSTP = 1 LSCALE = 1 LSDPV = 1 LSDRES = 1 LWT = N IVCV = 1 C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSW (Y, WT, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK)') END *NLSWS SUBROUTINE NLSWS(Y, WT, XM, N, M, IXM, MDL, PAR, NPAR, RES, + LDSTAK, IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, + NPRT, NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR NONLINEAR LEAST C SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES C AND WEIGHTS (LONG CALL). 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 REAL + DELTA,RSD,STOPP,STOPSS INTEGER + IVAPRX,IVCV,IXM,LDSTAK,M,MIT,N,NNZW,NPAR,NPARE,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*), + WT(*),XM(*),Y(*) INTEGER + IFIXED(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT LOGICAL + SAVE,WEIGHT C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,NLCNTN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 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 IFIXED(NPAR) 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 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 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. 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 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. N C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. 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 NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(NPAR) C THE CURRENT ESTIMATES OF THE PARAMETERS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL RSD C THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION. 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 REAL SCALE(NPAR) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C REAL 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 REAL 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 REAL STP(NPAR) C THE STEP SIZE ARRAY. C REAL 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 REAL WT(N) C THE WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'N','L','S','W','S',' '/ C C SET VARIOUS PROGRAM PARAMETERS C WEIGHT = .TRUE. SAVE = .TRUE. C LIFIXD = NPAR LPV = N LSCALE = NPAR LSTP = NPAR LSDPV = N LSDRES = N LWT = N C CALL NLCNTN(Y, WT, LWT, XM, N, M, IXM, MDL, 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, WEIGHT, SAVE, NNZW, NPARE) C IF (IERR.NE.1) RETURN C C PRINT PROPER CALL SEQUENCE C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NLSWS (Y, WT, XM, N, M, IXM, NLSMDL,'/ + ' + PAR, NPAR, RES, LDSTAK,'/ + ' + IFIXED, STP, MIT, STOPSS, STOPP,'/ + ' + SCALE, DELTA, IVAPRX, NPRT,'/ + ' + NNZW, NPARE, RSD, PV, SDPV, SDRES, VCV,', + ' IVCV)') END *NLSX1 SUBROUTINE NLSX1(MOD, PAR, NPAR, PV, SDPV, RES, SDRES, VCV, N, + IVCV, NNZW, NPARE, RSD) C C LATEST REVISION - 03/15/90 (JRD) C C SET THE STARTING PARAMETER VALUES FOR NLSX 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 REAL + RSD INTEGER + IVCV,MOD,N,NNZW,NPAR,NPARE C C ARRAY ARGUMENTS REAL + PAR(NPAR),PV(N),RES(N),SDPV(N),SDRES(N),VCV(IVCV,IVCV) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,J C C EXTERNAL SUBROUTINES EXTERNAL SETRV C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C 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 IVCV C THE ACTUAL FIRST DIMENSION OF VCV. C INTEGER MOD C AN INDICATOR VALUE USED TO DESIGNATE THE MODEL FOR WHICH C THE PARAMETERS ARE TO BE SET. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. C TO BE PROVIDED. C INTEGER NPARE C THE NUMBER OF PARAMETERS ESTIMATED BY THE ROUTINE. C INTEGER NNZW C THE NUMBER OF NONZERO WEIGHTS. C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PV(N) C THE PREDICTED VALUES. C REAL RES(N) C THE RESIDUALS. C REAL RSD C THE RESIDUAL STANDARD DEVIATION. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUES. C REAL SDRES(N) C THE STANDARDIZED RESIDUALS. C REAL VCV(IVCV,IVCV) C THE VARIANCE COVARIANCE MATRIX. C C C GO TO (10, 20, 30, 40, 50, 60), MOD C 10 PAR(1) = 0.725E0 PAR(2) = 4.0E0 C GO TO 70 C C 20 PAR(1) = 1.0E0 PAR(2) = 2.0E0 PAR(3) = 3.0E0 C GO TO 70 C C 30 PAR(1) = 6.0E0 PAR(2) = 5.0E0 PAR(3) = 4.0E0 PAR(4) = 3.0E0 PAR(5) = 2.0E0 C GO TO 70 40 CALL SETRV(PAR, NPAR, 0.0E0) C GO TO 70 C C 50 CALL SETRV(PAR, NPAR, 0.5E0) C GO TO 70 C C 60 PAR(1) = 100.0E0 PAR(2) = 15.0E0 C 70 CONTINUE C DO 80 I=1,N RES(I) = -1.0E0 PV(I) = -1.0E0 SDPV(I) = -1.0E0 SDRES(I) = -1.0E0 80 CONTINUE C DO 100 I=1,IVCV DO 90 J=1,IVCV VCV(I,J) = -1.0E0 90 CONTINUE 100 CONTINUE C NNZW = -1 NPARE = -1 RSD = -1.0E0 C IERR = -1 C RETURN C END *NLSX2 SUBROUTINE NLSX2(N, M, IXM, NPAR, IFIXED, STP, IDRVCK, MIT, + STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT, IVCV) C C LATEST REVISION - 03/15/90 (JRD) C C SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE C ROUTINES IN THE NONLINEAR LEAST SQUARES FAMILY. 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 REAL + DELTA,STOPP,STOPSS INTEGER + IDRVCK,IVAPRX,IVCV,IXM,M,MIT,N,NPAR,NPRT C C ARRAY ARGUMENTS REAL + SCALE(10),STP(10) INTEGER + IFIXED(10) C C LOCAL SCALARS REAL + SQMEPS INTEGER + I C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTA C THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE C FIRST ITERATION. C INTEGER IDRVCK C THE VARIABLE USED TO INDICATE WHETHER THE DERIVATIVES ARE C TO BE CHECKED (IDRVCK = 1) OR NOT (IDRVCK = 0). C INTEGER IFIXED(10) 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 C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C IFIXED(I).LT.0, THEN ALL PAR(I),I=1,NPAR, WILL BE OPTIMIZED.. 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(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 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(TRANSPOSE(JACOBIAN)*JACOBIAN) 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(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN C *INVERSE(HESSIAN) 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(TRANSPOSE(JACOBIAN)*JACOBIAN) 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER MIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL SCALE(10) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C REAL SQMEPS C THE SQUARE ROOT OF MACHINE PRECISION C REAL 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 REAL STOPSS C THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE C PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED C BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE. C REAL STP(10) C THE STEP SIZE ARRAY. C C C **SET UP FOR NORMAL STATEMENT** C SQMEPS = SQRT(RMDCON(3)) C N = 6 M = 1 IXM = 10 NPAR = 2 MIT = 500 DO 10 I=1,10 STP(I) = SQMEPS SCALE(I) = 1.0E0 10 CONTINUE IFIXED(1) = -1 IDRVCK = 0 STOPSS = 10.0E-5 STOPP = 10.0E-5 DELTA = 0.5E0 NPRT = 11111 IVAPRX = 3 IVCV = 6 C RETURN C END *NRANDC SUBROUTINE NRANDC(Y, N, ISEED, YMEAN, SIGMA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE GENERATES N NORMALLY DISTRIBUTED PSEUDO- C RANDOM NUMBERS WITH MEAN YMEAN AND STANDARD DEVIATION SIGMA. THE C NUMBERS GENERATED ARE DETERMINED BY ISEED. THEY ARE RETURNED IN Y C C ORIGIN - CONCEIVED BY DR. PETER TRYON TO FACILITATE USE OF C EXISTING RANDOM NUMBER GENERATOR C C WRITTEN BY - C JOHN E. KOONTZ AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, C BOULDER, COLORADO 80302 C C CREATION DATE - DECEMBER 2, 1985 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SIGMA,YMEAN INTEGER + ISEED,N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,IPRT,ISEEDU LOGICAL + ERR01,ERR02,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,LONE(8)*1,LSIGMA(8)*1,LZERO(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS REAL + RANDN EXTERNAL RANDN C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISRNG,ERSGE,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SOULD 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 THE INDEX OF THE COMPUTING LOOP C INTEGER IERR C THE INTEGER VALUE RETURNED BY THEIS 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 FOUND. C INTEGER IPRT C THE STANDARD OUTPUT FILE UNIT NUMBER C INTEGER ISEED C THE ISEED TO THE RANDOM NUMBER GENERATOR. C ISEED MUST LIE BETWEEN 0 AND 2**((MIN(32,I1MACH(8)+1))-1) -1, C INCLUSIVE. IF ISEED IS NOT EQUAL TO 0, ISEED MUST BE ODD. C INTEGER ISEEDU C THE VALUE OF THE SEED ACTUALLY USED. C CHARACTER*1 LN(8), LONE(8), LSIGMA(8), LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLES(S) CHECKED C FOR ERRORS C INTEGER N C THE LENGTH OF DATA SET GENERATED C CHARACTER*1 NMSUB(6) C THE NAME OF THIS SUBROUTINE C REAL SIGMA C THE STANDARD DEVIATION OF THE GENERATED VALUES. C REAL Y(N) C THE GENERATED RANDOM VALUES. C REAL YMEAN C THE MEAN OF THE GENERATED VALUES. C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'N', 'R', 'A', 'N', 'D', 'C'/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8)/'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), + LONE(7), LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ DATA LSIGMA(1),LSIGMA(2),LSIGMA(3),LSIGMA(4),LSIGMA(5),LSIGMA(6), + LSIGMA(7),LSIGMA(8)/'S', 'I', 'G', 'M', 'A', ' ', ' ', ' '/ DATA LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5), LZERO(6), + LZERO(7), LZERO(8)/'Z', 'E', 'R', 'O', ' ', ' ', ' ', ' '/ C IERR = 0 C HEAD = .TRUE. C C CHECK FOR INPUT ERRORS C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE) CALL ERSGE(NMSUB, LSIGMA, SIGMA, 0.0E0, 2, HEAD, ERR02, LZERO) CALL EISRNG(NMSUB, ISEED, ISEEDU, HEAD) C IF (ERR01.OR.ERR02) THEN C CALL IPRINT(IPRT) WRITE (IPRT,1000) IERR = 1 C ELSE C C GENERATE THE PSEUDO-RANDOM NUMBERS C Y(1) = RANDN(ISEEDU) DO 20 I=1,N Y(I) = RANDN(0)*SIGMA + YMEAN 20 CONTINUE END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NRANDC (Y, N, ISEED, YMEAN, SIGMA)') END *NRAND SUBROUTINE NRAND (Y, N, ISEED) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE GENERATES N NORMALLY DISTRIBUTED PSEUDO- C RANDOM NUMBERS WITH ZERO MEAN AND UNIT STANDARD DEVIATION. THE C NUMBERS GENERATED ARE DETERMINED BY ISEED. THEY ARE RETURNED IN Y C C ORIGIN - CONCEIVED BY DR. PETER TRYON TO FACILITATE USE OF C EXISTING RANDOM NUMBER GENERATOR C C WRITTEN BY - C JOHN E. KOONTZ AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C BOULDER, COLORADO 80302 C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISEED,N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,IPRT,ISEEDU LOGICAL + ERR01,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS REAL + RANDN EXTERNAL RANDN C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISRNG,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A FLAG INDICATING WHETHER THE HEADING SOULD 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 THE INDEX OF THE COMPUTING LOOP C INTEGER IERR C THE INTEGER VALUE RETURNED BY THEIS 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 FOUND. C INTEGER IPRT C THE STANDARD OUTPUT FILE UNIT NUMBER C INTEGER ISEED C THE ISEED TO THE RANDOM NUMBER GENERATOR. C ISEED MUST LIE BETWEEN 0 AND 2**((MIN(32,I1MACH(8)+1))-1) -1, C INCLUSIVE. IF ISEED IS NOT EQUAL TO 0, ISEED MUST BE ODD. C INTEGER ISEEDU C THE VALUE OF THE SEED ACTUALLY USED. C CHARACTER*1 LN(8), LONE(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE VARIABLES(S) CHECKED C FOR ERRORS C INTEGER N C THE LENGTH OF DATA SET GENERATED C CHARACTER*1 NMSUB(6) C THE NAME OF THIS SUBROUTINE C REAL Y(N) C THE GENERATED RANDOM VALUES. C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'N', 'R', 'A', 'N', 'D', ' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8)/'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), + LONE(7), LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ C IERR = 0 C HEAD = .TRUE. C C CHECK FOR INPUT ERRORS C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE) CALL EISRNG(NMSUB, ISEED, ISEEDU, HEAD) C IF (ERR01) THEN C CALL IPRINT(IPRT) WRITE (IPRT,1000) IERR = 1 C ELSE C C GENERATE THE PSEUDO-RANDOM NUMBERS C Y(1) = RANDN(ISEEDU) DO 20 I=1,N Y(I) = RANDN(0) 20 CONTINUE END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL NRAND(Y, N, ISEED)') END *OANOVA SUBROUTINE OANOVA(YSUM, RED, NPAR, RVAR, NNZW, TEMP, IPRT) C C LATEST REVISION - 03/15/90 (JRD) C C COMPUTE AND PRINT ANALYSIS OF VARIANCE C C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/09/69. C C THIS ROUTINE WAS ADAPTED FROM THE OMNITAB ROUTINE OANOVA C BY - - C C 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 REAL + RVAR,YSUM INTEGER + IPRT,NNZW,NPAR C C ARRAY ARGUMENTS REAL + RED(NPAR),TEMP(NPAR) C C LOCAL SCALARS REAL + ASUM,CR,F1,F2,FPLM,PF1,PF2,RESMS,RESSS,SSU,V1F2,VR INTEGER + I,K,NSUA C C EXTERNAL FUNCTIONS REAL + CDFF,R1MACH EXTERNAL CDFF,R1MACH C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ASUM C * C REAL CR C * C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C REAL F1 C * C REAL F2 C * C INTEGER I C AN INDEX. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER K C * C INTEGER NPAR C THE NUMBER OF PARAMETERS. C INTEGER NNZW C THE NUMBER OF NON ZERO WEIGHTS. C INTEGER NSUA C * C REAL PF1 C * C REAL PF2 C * C REAL RED(NPAR) C THE REDUCTION TO THE SUM OF SQUARES DUE TO EACH PARAMETER. C REAL RESMS C * C REAL RESSS C * C REAL RVAR C THE RESIDUAL VARIANCE. C REAL SSU C * C REAL TEMP(NPAR) C A WORK VECTOR. C REAL VR C * C REAL V1F2 C * C REAL YSUM C THE SUM OF THE WEIGHTED DEPENDENT VARIABLES SQUARED. C C FPLM = R1MACH(2) C RESMS = YSUM/NNZW NSUA = NNZW WRITE (IPRT,1000) ASUM = 0.0E0 VR = NNZW-NPAR RESSS = VR*RVAR TEMP(NPAR) = RESSS IF (NPAR.EQ.1) GO TO 20 DO 10 I=2,NPAR K = NPAR + 2 - I TEMP(K-1) = TEMP(K) + RED(K) 10 CONTINUE 20 V1F2 = NPAR+1 SSU = NNZW DO 50 I=1,NPAR NSUA = NSUA - 1 ASUM = ASUM + RED(I) SSU = SSU - 1.0E0 CR = ASUM/I RESMS = 0.0E0 IF (SSU.GT.0.0E0) RESMS = TEMP(I)/SSU V1F2 = V1F2 - 1.0E0 C C NEVER POOL C IF (RVAR.GT.0.0E0) GO TO 30 F1 = FPLM F2 = FPLM PF1 = 0.0E0 PF2 = 0.0E0 GO TO 40 30 F1 = RED(I)/RVAR PF1 = 1.0E0 - CDFF(F1,1.0E0,VR) C C TEST HIGHER SUB-HYPOTHESES C F2 = (TEMP(I)+RED(I)-RESSS)/V1F2/RVAR PF2 = 1.0E0 - CDFF(F2,V1F2,VR) 40 CONTINUE WRITE (IPRT,1010) I, RED(I), CR, I, RESMS, NSUA, F1, PF1, F2, + PF2 50 CONTINUE WRITE (IPRT,1020) RESSS, NSUA WRITE (IPRT,1030) YSUM, NNZW RETURN C C FORMAT STATEMENTS C 1000 FORMAT (////50X, 20HANALYSIS OF VARIANCE/24X, 16H-DEPENDENT ON OR, + 33HDER VARIABLES ARE ENTERED, UNLESS, 21H VECTORS ARE ORTHOGON, + 3HAL-// + 1X, 5H PAR , 4X, 14HSUM OF SQUARES, 63X, + 19H------ PAR=0 ------, 4X, 19H------ PARS=0 -----/ + 1X, 5HINDEX, 4X, 14HRED DUE TO PAR, 7X, 10HCUM MS RED, + 6X, 9HDF(MSRED), 6X, 10HCUM RES MS, 6X, 7HDF(RMS), 5X, + 'F', 8X, 7HPROB(F), 7X, 'F', 8X, 7HPROB(F)/) 1010 FORMAT (1X, I3, 6X, G16.9, 3X, G16.9, 1X, I6, 8X, G16.9, 1X, I5, + 4X, G12.6, F7.3, 4X, G12.6, F7.3) 1020 FORMAT (/1X, 10HRESIDUAL , 1X, G14.7, 20X, I6) 1030 FORMAT (1X, 10HTOTAL , 1X, G14.7, 20X, I6) 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 REAL + PVT(N),RES(N),SDPVT(N),SDREST(N),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + FPLM INTEGER + I,IPRT C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL PVT(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES. C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL SDPVT(N) C THE STANDARD DEVIATIONS OF THE PREDICTED VALUES. C REAL SDREST(N) C THE STANDARDIZED RESIDUALS. C REAL Y(N) C THE DEPENDENT VARIABLE. C FPLM = R1MACH(2) C 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)) + WRITE (IPRT, 1060) I, Y(I), PVT(I), SDPVT(I), RES(I), + SDREST(I) IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).EQ.FPLM)) + WRITE (IPRT, 1050) I, Y(I), PVT(I), SDPVT(I), RES(I) IF ((SDPVT(I).EQ.FPLM) .AND. (SDREST(I).EQ.FPLM)) + WRITE (IPRT, 1080) I, Y(I), PVT(I), RES(I) C 140 CONTINUE C RETURN C C FORMAT STATEMENTS C 1050 FORMAT (1X, I4, 4E16.8, 4X, 4HNC *, 1X, E9.3) 1060 FORMAT (1X, I4, 4E16.8, 1X, F7.2, 1X, E9.3) 1080 FORMAT (1X, I4, 2E16.8, 8X, 4HNC *, 4X, E16.8, 4X, 4HNC *, + 1X, E9.3) END *OBSSUM SUBROUTINE OBSSUM(N, M, XM, Y, PV, SDPV, RES, SDRES, WT, IXM, + WEIGHT, K, IFIRST, ILAST, JCOL1, JCOLM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBOUTINE LISTS THE DATA SUMMARY FOR THE 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 29, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IFIRST,ILAST,IXM,JCOL1,JCOLM,K,M,N LOGICAL + WEIGHT C C ARRAY ARGUMENTS REAL + PV(N),RES(N),SDPV(N),SDRES(N),WT(N),XM(IXM,M),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + FPLM INTEGER + I,IPRT,J CHARACTER + STRING*20,FMT1*160,FMT2*160,FMT3*160 C C EXTERNAL FUNCTIONS REAL + R1MACH LOGICAL + MVCHK EXTERNAL R1MACH,MVCHK C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*160 FMT1,FMT2,FMT3 C THE FORMATS USED TO PRINT THE INFORMATION. C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IERR C THE INTEGER VALUE DESIGNATING WHETHER ANY ERRORS HAVE C BEEN DETECTED. C IF IERR .EQ. 0, NO ERRORS WERE DETECTED C IF IERR .NE. 0, ERRORS HAVE BEEN DETECTED. C INTEGER IFIRST, ILAST C THE FIRST AND LAST INDICES TO BE LISTED. 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 JCOLM C THE LAST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED. C INTEGER JCOL1 C THE FIRST COLUMN OF THE INDEPENDENT VARIABLE TO BE PRINTED. C INTEGER K C AN INDEX VARIABLE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL RES(N) C THE RESIDUALS FROM THE FIT. C REAL SDPV(N) C THE STANDARD DEVIATION OF THE PREDICTED VALUE. C REAL SDRES(N) C THE STANDARD DEVIATIONS OF THE RESIDUALS. C CHARACTER*20 STRING C CHARACTER STRING USED TO BUILD THE FORMATS. C LOGICAL WEIGHT C THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO C BE PERFORMED (TRUE) OR NOT (FALSE). C REAL WT(N) C THE USER SUPPLIED WEIGHTS. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C REAL Y(N) C THE ARRAY OF THE DEPENDENT VARIABLE. C FPLM = R1MACH(2) C CALL IPRINT(IPRT) C C CONSTRUCT FORMAT C IF (K.EQ.1) THEN STRING = '1X,I4,15X,G15.8,15X,' ELSE IF (K.EQ.2) THEN STRING = '1X,I4,7X,2G15.8,8X, ' ELSE STRING = '1X,I4,3G15.8, ' END IF WRITE (FMT1,1020) STRING WRITE (FMT2,1030) STRING WRITE (FMT3,1040) STRING C DO 140 I=IFIRST, ILAST IF (MVCHK(SDPV(I),FPLM)) THEN IF (WEIGHT) THEN WRITE (IPRT, FMT1) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), RES(I), WT(I) ELSE WRITE (IPRT, FMT1) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), RES(I) END IF ELSE IF (MVCHK(SDRES(I),FPLM)) THEN IF (WEIGHT) THEN WRITE (IPRT, FMT2) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), SDPV(I), RES(I), WT(I) ELSE WRITE (IPRT, FMT2) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), SDPV(I), RES(I) END IF ELSE IF (WEIGHT) THEN WRITE (IPRT, FMT3) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), SDPV(I), RES(I), + SDRES(I), WT(I) ELSE WRITE (IPRT, FMT3) I, (XM(I,J),J=JCOL1,JCOLM), + Y(I), PV(I), SDPV(I), RES(I), + SDRES(I) END IF END IF END IF 140 CONTINUE C RETURN C C FORMAT STATEMENTS C 1020 FORMAT ('(',A20,'2G16.8,8X,4HNC *,4X,G16.8,4X,4HNC *,1X,E9.3)') 1030 FORMAT ('(',A20,'4G16.8,4X,4HNC *,1X,E9.3)') 1040 FORMAT ('(',A20,'4G16.8,1X,F7.2,1X,E9.3)') 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 REAL + V(33) INTEGER + IV(21) C C LOCAL SCALARS REAL + 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 REAL + VM(27),VX(27) CHARACTER + CNGD(12)*1,DFLT(12)*1,VN(8,27)*1,WHICH(12)*1 C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C EXTERNAL SUBROUTINES EXTERNAL DFAULT,VCOPY C C INTEGER IV(21), N, NN, P C REAL V(33) C DIMENSION IV(*), V(*) C C EXTERNAL DFAULT, RMDCON, VCOPY C REAL 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 REAL 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 DATA BIG/0.0E0/, NVDFLT/27/, TINY/1.0E0/, ZERO/0.0E0/ 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.0E-3/, VM(2)/-0.99E0/, VM(3)/1.0E-3/, VM(4)/1.0E-2/, + VM(5)/1.2E0/, VM(6)/1.0E-2/, VM(7)/1.2E0/, VM(8)/0.0E0/, + VM(9)/0.0E0/, VM(10)/1.0E-3/, VM(11)/-1.0E0/, VM(15)/0.0E0/, + VM(16)/0.0E0/, VM(19)/0.0E0/, VM(20)/-10.0E0/, VM(21)/0.0E0/, + VM(23)/0.0E0/, VM(24)/1.0E10/, VM(27)/1.01E0/ DATA VX(1)/0.9E0/, VX(2)/-1.0E-3/, VX(3)/1.0E1/, VX(4)/0.8E0/, + VX(5)/1.0E2/, VX(6)/0.8E0/, VX(7)/1.0E2/, VX(8)/0.5E0/, + VX(9)/0.5E0/, VX(10)/1.0E0/, VX(11)/1.0E0/, VX(14)/0.1E0/, + VX(15)/1.0E0/, VX(16)/1.0E0/, VX(18)/1.0E0/, VX(22)/1.0E0/, + VX(23)/1.0E0/, VX(25)/1.0E0/, VX(26)/1.0E0/, VX(27)/1.0E2/ 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) PU = IV(PRUNIT) 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) WRITE(PU,10) NN, N, P 10 FORMAT(30H0///// BAD NN, N, OR P... NN =,I5,5H, N =,I5, + 5H, P =,I5) 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) WRITE(PU,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN, + N, P 40 FORMAT('0///// (NN,N,P) CHANGED FROM (',I5,',',I5,',',I3, + ') TO (',I5,',',I5,',',I3,').') GO TO 999 C 50 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70 IV(1) = 50 IF (PU .NE. 0) WRITE(PU,60) IV1 60 FORMAT('0///// IV(1) =',I5,' SHOULD BE BETWEEN 0 AND 12.') 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) WRITE(PU,100) IV(INITS) 100 FORMAT(25H0///// INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0, + 7H AND 2.) 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) WRITE(PU,120) (VN(ICH, I), ICH=1, 8), + (VN(ICH, I), ICH=1, 8), + K, VK, VM(I), VX(I) 120 FORMAT(8H0///// ,8A1,5H.. V(,I2,3H) =,E11.3,7H SHOULD, + ' BE BETWEEN',E11.3,4H AND,E11.3) 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) WRITE(PU,150) K, I, V(I) 150 FORMAT(12H0///// JTOL(,I3,6H) = V(,I3,3H) =,E11.3, + 20H SHOULD BE POSITIVE.) 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(PU,190) IV(INITS) 190 FORMAT(22H0NONDEFAULT VALUES..../20H INITS..... IV(25) =,I3) 200 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 210 IF (M .EQ. 0) WRITE(PU,215) (WHICH(ICH), ICH=1, 12) M = 1 WRITE(PU,205) IV(DTYPE) 205 FORMAT(20H DTYPE..... IV(16) =,I3) 210 K = EPSLON L = PARSV1 DO 240 I = 1, NVDFLT IF (V(K) .EQ. V(L)) GO TO 230 IF (M .EQ. 0) WRITE(PU,215) (WHICH(ICH), ICH = 1, 12) 215 FORMAT ('0',12A1,'ALUES....'/) M = 1 WRITE (PU,220) (VN(ICH, I), ICH = 1, 8), K, V(K) 220 FORMAT (1X, 8A1, 5H.. V(, I2, 3H) =, E15.7) 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(PU,250) (V(I), I = JTOL1, JTOLP) 250 FORMAT(24H0(INITIAL) JTOL ARRAY.../(1X,6E12.3)) 260 IF (V(D0INIT) .GT. ZERO) GO TO 999 K = JTOL1 + P L = K + P - 1 WRITE(PU,270) (V(I), I = K, L) 270 FORMAT(22H0(INITIAL) D0 ARRAY.../1X,6E12.3) C 999 RETURN C *** LAST CARD OF PARCHK FOLLOWS *** END *PARZEN SUBROUTINE PARZEN (LAG, W, LW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES AND STORES THE PARZEN LAG WINDOW C C WRITTEN BY - JANET R. DONALDSON 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 + LAG,LW C C ARRAY ARGUMENTS REAL + W(LW) C C LOCAL SCALARS INTEGER + K,L C C INTRINSIC FUNCTIONS INTRINSIC REAL C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER K C AN INDEX VARIABLE C INTEGER L C THE VALUE LAG/2. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LW C THE LENGTH OF THE VECTOR W. C REAL W(LW) C THE VECTOR OF LAG WINDOWS. C L = LAG/2 W(1) = 1.0E0 IF (L.LE.0) GO TO 15 DO 10 K = 1, L W(K+1) = REAL(K) / REAL(LAG) W(K+1) = 1.0E0 + 6.0E0 * W(K+1) * W(K+1) * (W(K+1) - 1.0E0) 10 CONTINUE C 15 CONTINUE L = L + 1 DO 20 K = L, LAG W(K+1) = 1.0E0 - REAL(K) / REAL(LAG) W(K+1) = 2.0E0 * W(K+1) * W(K+1) * W(K+1) 20 CONTINUE C RETURN END *PGMEST SUBROUTINE PGMEST (YFFT, NFFT, NF, CNST, PER, LPER) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE PERIODOGRAM ESTIMATES. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + CNST INTEGER + LPER,NF,NFFT C C ARRAY ARGUMENTS REAL + PER(LPER),YFFT(NFFT) C C LOCAL SCALARS REAL + FAC INTEGER + I,ISN,NFFT2 C C EXTERNAL SUBROUTINES EXTERNAL FFT,REALTR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL CNST C THE VARIANCE OF THE OBSERVED TIME SERIES TIMES THE NUMBER OF C OBSERVATIONS IN THE SERIES IF CALLED BY IPGM, C OR 1.0E0 IF CALLED BY PGM. C REAL FAC C A FACTOR USED FOR COMPUTATIONS OF THE INTEGRATED PERIODOGRAM. C INTEGER I C AN INDEX VARIABLE C INTEGER ISN C A CODE USED FOR THE FFT. C INTEGER LPER C THE LENGTH OF THE PERIODOGRAM ARRAY. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODOGRAM IS C COMPUTED. C INTEGER NFFT C THE EFFECTIVE NUMBER OF OBSERVATIONS FOR THE FFT TRANSFORM. C INTEGER NFFT2 C THE EFFECTIVE NUMBER OF COMPLEX OBSERVATIONS FOR THE FFT C TRANSFORM. C REAL PER(LPER) C THE PERIODOGRAM. C REAL YFFT(NFFT) C THE CENTERED SERIES. C C COMPUTE THE FOURIER COEFFICIENTS C NFFT2 = (NFFT-2) / 2 ISN = 2 C CALL FFT (YFFT(1), YFFT(2), NFFT2, NFFT2, NFFT2, ISN) CALL REALTR (YFFT(1), YFFT(2), NFFT2, ISN) C FAC = 0.5E0 / (CNST * (NFFT-2)) C NF = NFFT2 + 1 C DO 10 I = 1, NF PER(I) = (YFFT(2*I-1)*YFFT(2*I-1) + YFFT(2*I)*YFFT(2*I)) * FAC 10 CONTINUE C RETURN END *PGM SUBROUTINE PGM (YFFT, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE (RAW) PERIODOGRAM OF A SERIES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + FREQ,IEXTND,IPRT,LDSMIN,NALL0,NF,NFFT,NPRT,YAXIS LOGICAL + ERR01,ERR02,ERR03,HEAD C C LOCAL ARRAYS REAL + RSTAK(12) CHARACTER + LLDS(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL EISGE,IPRINT,LDSCMP,PGMMN,SETESL,STKCLR,STKSET C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES 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 LOGICAL ERR01, ERR02, ERR03 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C INTEGER FREQ C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C CHARACTER*1 LLDS(8), LLYFFT(8), LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS. C INTEGER NALL0 C THE NUMBER OF OUTSTANDING ALLOCATIONS OF THE STACK AT THE C TIME OF THIS CALL. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE, C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .EQ. 1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE. C IF NPRT .GE. 2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C INTEGER YAXIS C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'G', 'M', ' ', ' ', ' '/ DATA + LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), + LLDS(6), LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) + /'L','Y','F','F','T',' ',' ',' '/ 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, 17, 1, HEAD, ERR01, LN) IF (ERR01) GO TO 5 C C SET LENGTH OF EXTENDED SERIES C CALL SETESL(N, 2, NFFT) C CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR02, LLYFFT) C CALL LDSCMP(2, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 2, HEAD, ERR03, LLDS) C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C NALL0 = STKST(1) C C SET DEFAULT VALUES C NPRT = -1 IEXTND = 0 C C SUBDIVIDE THE WORK ARRAY C YAXIS = STKGET(NFFT/2, 3) FREQ = STKGET(NFFT/2, 3) CALL PGMMN (YFFT, N, NFFT, IEXTND, NF, YFFT, LYFFT, RSTAK(YAXIS), + RSTAK(FREQ), NFFT/2, NPRT, NMSUB) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PGM (YFFT, N, LYFFT, LDSTAK)') END *PGMMN SUBROUTINE PGMMN (YFFT, N, NFFT, IEXTND, NF, PER, LPER, YAXIS, + FREQ, LFREQ, NPRT, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS THE MAIN ROUTINE FOR COMPUTING THE RAW PERIODOGRAM. C C WRITTEN BY - JANET R. DONALDSON 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 + IEXTND,LFREQ,LPER,N,NF,NFFT,NPRT C C ARRAY ARGUMENTS REAL + FREQ(LFREQ),PER(LPER),YAXIS(LFREQ),YFFT(NFFT) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS REAL + YEXTND INTEGER + I,N1 C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,PGMEST,PGORD,PGOUT,SETFRQ C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FREQ(LFREQ) C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER LFREQ C THE LENGTH OF THE ARRAY FREQ. C INTEGER LPER C THE LENGTH OF THE ARRAY PER. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE, C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .EQ. 1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE. C IF NPRT .GE. 2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C REAL PER(LPER) C THE ARRAY IN WHICH THE PERIODOGRAM IS STORED. C REAL YAXIS(LFREQ) C THE ARRAY IN WHICH THE Y AXIS VALUES TO BE PLOTTED ARE STORED. C REAL YEXTND C THE VALUE USED TO EXTEND THE SERIES. C REAL YFFT(NFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C YEXTND = 0.0E0 IF (IEXTND .NE. 0) CALL AMEAN (YFFT, N, YEXTND) C C EXTEND THE PERIODOGRAM ARRAY BY ITS MEAN OR ZERO TO THE C EXTENDED LENGTH NFFT. C N1 = N + 1 C DO 40 I = N1, NFFT YFFT(I) = YEXTND 40 CONTINUE C C COMPUTE THE PERIODOGRAM. C CALL PGMEST (YFFT, NFFT, NF, 1.0E0, PER, LPER) C C SET FREQUENCIES FOR PERIODOGRAM VALUES C CALL SETFRQ (FREQ, NF, 1, 0.0E0, 0.5E0, 1.0E0) C IF (NPRT .EQ. 0) RETURN C C SET Y CO-ORDINATES FOR PERIODOGRAM PLOT. C CALL PGORD (PER, NF, YAXIS, NPRT) C C PLOT PERIODOGRAM IF OUTPUT NOT SUPPRESSED C CALL PGOUT (YAXIS, FREQ, NF, NPRT, NMSUB) C RETURN C END *PGMS SUBROUTINE PGMS (YFFT, N, NFFT, LYFFT, IEXTND, NF, PER, LPER, + FREQ, LFREQ, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR COMPUTING C THE (RAW) PERIODOGRAM OF A SERIES (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IEXTND,LFREQ,LPER,LYFFT,N,NF,NFFT,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),PER(*),YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,NFFT2 LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,HEAD C C LOCAL ARRAYS CHARACTER + LLFREQ(8)*1,LLPER(8)*1,LLYFFT(8)*1,LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ENFFT,IPRINT,PGMMN C C COMMON BLOCKS COMMON /ERRCHK/IERR 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 REAL FREQ(LFREQ) C THE ARRAY IN WHICH THE FREQUENCIES CORRESPONDING TO THE C INTEGRATED SPECTRUM VALUES ARE STORED. C LOGICAL HEAD C A VARIABLE USED TO INDICATE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (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 .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IEXTND C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO C (IEXTND .EQ. 0) OR THE SERIES MEAN (IEXTND .NE. 0) IS TO BE C USED TO EXTEND THE SERIES. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER LFREQ C THE LENGTH OF THE ARRAY FREQ. C CHARACTER*1 LLFREQ(8), LLPER(8), LLYFFT(8), LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER LPER C THE LENGTH OF THE ARRAY PER. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE PERIODGRAM IS C TO BE COMPUTED. C INTEGER NFFT C THE EFFECTIVE LENGTH OF THE SERIES TO BE TRANSFORMED. C INTEGER NFFT2 C THE EFFECTIVE SERIES LENGTH ACTUALLY USED. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE, C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .EQ. 1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE. C IF NPRT .GE. 2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C REAL PER(LPER) C THE ARRAY IN WHICH THE PERIODOGRAM IS STORED. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'G', 'M', 'S', ' ', ' '/ DATA + LLFREQ(1), LLFREQ(2), LLFREQ(3), LLFREQ(4), LLFREQ(5), + LLFREQ(6), LLFREQ(7), LLFREQ(8) + /'L','F','R','E','Q',' ',' ',' '/ DATA + LLPER(1), LLPER(2), LLPER(3), LLPER(4), LLPER(5), + LLPER(6), LLPER(7), LLPER(8) /'L','P','E','R',' ',' ',' ',' '/ DATA + LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) + /'L','Y','F','F','T',' ',' ',' '/ 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, 17, 1, HEAD, ERR01, LN) IF (ERR01) GO TO 5 C CALL ENFFT(NMSUB, NFFT, 2, N, LYFFT, NFFT2, HEAD, ERR02) NF = NFFT2/2 C CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT2, 9, HEAD, ERR03, LLYFFT) C CALL EISGE(NMSUB, LLPER, LPER, NF, 9, HEAD, ERR04, LLPER) C CALL EISGE(NMSUB, LLFREQ, LFREQ, NF, 9, HEAD, ERR05, LLFREQ) C IF (ERR02 .OR. ERR03 .OR. ERR04 .OR. ERR05) GO TO 5 GO TO 10 C 5 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 10 CONTINUE C CALL PGMMN (YFFT, N, NFFT2, IEXTND, NF, PER, LPER, YFFT, FREQ, + LFREQ, NPRT, NMSUB) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PGMS (YFFT, N, NFFT, LYFFT,'/ + ' + IEXTND, NF, PER, LPER, FREQ, LFREQ, NPRT)') END *PGORD SUBROUTINE PGORD (PER, NPTS, YAXIS, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CO-ORDINATES FOR THE PERIODOGRAM PLOT. C C WRITTEN BY - JANET R. DONALDSON 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 + NPRT,NPTS C C ARRAY ARGUMENTS REAL + PER(NPTS),YAXIS(NPTS) C C LOCAL SCALARS REAL + FPLM INTEGER + I C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC IABS,LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER I C AN INDEX VARIABLE C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE, C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .EQ. 1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE. C IF NPRT .GE. 2, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C INTEGER NPTS C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE ESTIMATED. C REAL PER(NPTS) C THE ARRAY CONTAINING THE PERIODOGRAM VALUES. C REAL YAXIS(NPTS) C THE Y CO-ORDINATES FOR THE PERIODOGRAM PLOTS. C FPLM = R1MACH(2) C C THE FIRST VALUE SHOULD BE ZERO, SO NO ATTEMPT IS MADE TO PLOT IT. C YAXIS(1) = FPLM C DO 10 I = 2, NPTS YAXIS(I) = FPLM IF (PER(I) .LE. 0.0E0) GO TO 10 YAXIS(I) = PER(I) IF (IABS(NPRT) .EQ. 1) YAXIS(I) = 10.0E0*LOG10(YAXIS(I)) 10 CONTINUE C RETURN C END *PGOUT SUBROUTINE PGOUT (YAXIS, XAXIS, NPTS, NPRT, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES THE PERIODOGRAM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 + NPRT,NPTS C C ARRAY ARGUMENTS REAL + XAXIS(NPTS),YAXIS(NPTS) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS REAL + FPLM,XMISS,XMN,XMX,YMN,YMX INTEGER + ILOG,IPRT LOGICAL + ERROR C C LOCAL ARRAYS REAL + YMISS(1) INTEGER + ISYM(1) C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPLMT,PPMN,VERSP,VPLMT,VPMN C C INTRINSIC FUNCTIONS INTRINSIC ABS,IABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C AN ERROR FLAG C REAL FPLM C THE FLOATING POINT LARGEST MAGNITUDE. C INTEGER ILOG C ... C INTEGER IPRT C THE LOGICAL UNIT NUMBER FOR THE OUTPUT. C INTEGER ISYM(1) C A DUMMY ARRAY FOR THE PAGE PLOTS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPRT C THE VARIABLE CONTROLING PRINTED OUTPUT, WHERE C IF NPRT .LE. -2, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM ON A LOG-LINEAR SCALE, C IF NPRT .EQ. -1, THE OUTPUT CONSISTS OF A PAGE PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE, C IF NPRT .EQ. 0, THE OUTPUT IS SUPPRESSED, C IF NPRT .GE. 1, THE OUTPUT CONSISTS OF A VERTICAL PLOT OF THE C PERIODOGRAM IN DECIBELS ON A LINEAR SCALE. C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL XAXIS(NPTS) C THE X CO-ORDINATES FOR THE PAGE PLOTS. C REAL XMISS C THE VALUE USED TO SPECIFY IF THE PERIODOGRAM VALUE WAS C LESS THAN OR EQUAL TO ZERO. C REAL XMN, XMX C ... C REAL YAXIS(NPTS) C THE Y CO-ORDINATES FOR THE SPECTRAL PLOTS. C REAL YMISS(1) C THE VALUE USED TO SPECIFY IF AN PERIODOGRAM VALUE WAS C LESS THAN OR EQUAL TO ZERO. C REAL YMN, YMX C C FPLM = R1MACH(2) C XMISS = FPLM YMISS(1) = FPLM C C SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH. C CALL IPRINT (IPRT) C CALL VERSP(.TRUE.) IF (IABS(NPRT).EQ.1) THEN WRITE (IPRT, 1010) ELSE WRITE (IPRT, 1000) END IF C IF (ABS(NPRT).EQ.1) THEN ILOG = 0 ELSE ILOG = 1 END IF IF (NPRT.GE.1) THEN C C PLOT VERTICAL PLOTS C CALL VPLMT(YAXIS, YMISS, NPTS, 1, NPTS, 0.0E0, 0.0E0, YMN, YMX, + ERROR, NMSUB, .TRUE., 1) IF (.NOT.ERROR) + CALL VPMN(YAXIS(2), YMISS, NPTS-1, 1, NPTS, 1, 0, ISYM, 1, 0, + YMN, YMX, 0.5E0/(NPTS-1), 0.5E0/(NPTS-1), + .TRUE., ILOG, -1, 0) ELSE C C PLOT PAGE PLOTS C CALL PPLMT(YAXIS, YMISS, XAXIS, XMISS, NPTS, 1, NPTS, + 0.0E0, 0.0E0, YMN, YMX, 0.0E0, 0.5E0, XMN, XMX, + ERROR, NMSUB, .TRUE.) IF (.NOT.ERROR) THEN CALL PPMN (YAXIS, YMISS, XAXIS, XMISS, NPTS, 1, NPTS, 0, + ISYM, 1, 0, -1, YMN, YMX, XMN, XMX, .TRUE., ILOG) WRITE(IPRT, 1030) END IF END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (' SAMPLE PERIODOGRAM') 1010 FORMAT (' SAMPLE PERIODOGRAM (IN DECIBELS)') C1020 FORMAT (5H+FREQ/ C 1 7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X, C 2 3H2.5, 4X, 2H2.) 1030 FORMAT (5H+FREQ/ + 7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X, + 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X, + 6H2.2222, 4X, 2H2.) C END *PLINE SUBROUTINE PLINE(IMIN, IMAX, ISYMBL, LINE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE DEFINES ONE LINE OF A PLOT STRING FOR THE C VERTICAL PLOT ROUTINES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IMAX,IMIN CHARACTER + ISYMBL*1 C C ARRAY ARGUMENTS CHARACTER + LINE(103)*1 C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEXING VARIABLE. C INTEGER IMAX C THE LARGEST LOCATION IN THE PLOT STRING BEING DEFINED. C INTEGER IMIN C THE SMALLEST LOCATION IN THE PLOT STRING BEING DEFINED. C CHARACTER*1 ISYMBL C THE PLOTTING SYMBOL BEING USED. C CHARACTER*1 LINE(103) C THE VECTOR USED FOR THE PLOT STRING. C DO 10 I = IMIN, IMAX LINE(I) = ISYMBL 10 CONTINUE RETURN END *PLTCHK SUBROUTINE PLTCHK (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, + ILOG, YLB, YUB, XLB, XUB, NMSUB, MISS, XCHECK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS PLOT FAMILY ROUTINE CHECKS FOR ERRORS IN THE PARAMETER LISTS C OF THE MULTIPLE PLOT ROUTINES C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,IYM,M,N LOGICAL + MISS,MULTI,XCHECK C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + NV LOGICAL + ERR01,ERR02,ERR03,ERR04,ERR05,ERR06,ERR07,ERR08,ERR09,HEAD C C LOCAL ARRAYS INTEGER + ILOGXY(2) CHARACTER + LIYM(8)*1,LM(8)*1,LN(8)*1,LONE(8)*1,LX(8)*1,LXLB(8)*1, + LXUB(8)*1,LY(8)*1,LYLB(8)*1,LYM(8)*1,LYUB(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERAGT,ERAGTM,ERSGT,ERVGT,ERVGTM,PRTCNT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05, ERR06, ERR07, ERR08, C 1 ERR09 C VALUES 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 IERR C THE COMMON VARIABLE USED AS AN ERROR FLAG C IF = 0 THEN NO ERORRS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER ILOGXY(2) C ... C INTEGER IYM C ACTUAL ROW DIMENSION OF YM DECLARED IN USERS MAIN PROGRAM C CHARACTER*1 LIYM(8), LM(8), LN(8), LONE(8), LX(8), LXLB(8), C * LXUB(8), LY(8), LYLB(8), LYM(8), LYUB(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE INPUT PARAMETERS(S) C CHECKED FOR ERRORS. C INTEGER M C THE NUMBER OF VECTORS IN YM C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALLING C ROUTINE HAS AN M PREFIX (TRUE) OR NOT (FALSE). C INTEGER N C THE LENGTH OF THE VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND IN THE X AND Y AXIS ARRAYS. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C LOGICAL XCHECK C INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES C ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.) C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y (VERTICAL) COORDINATES. C REAL YMMISS(M) C THE MISSING VALUE CODE FOR EACH COLUMN OF YM. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + LIYM(1), LIYM(2), LIYM(3), LIYM(4), LIYM(5), LIYM(6) + / 'I', 'Y', 'M', ' ', ' ', ' '/ DATA LIYM(7), LIYM(8) + / ' ', ' '/ DATA + LM(1), LM(2), LM(3), LM(4), LM(5), LM(6) + / 'M', ' ', ' ', ' ', ' ', ' '/ DATA LM(7), LM(8) + / ' ', ' '/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6) + / 'N', ' ', ' ', ' ', ' ', ' '/ DATA LN(7), LN(8) + / ' ', ' '/ DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), + LONE(7), LONE(8)/'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ DATA + LX(1), LX(2), LX(3), LX(4), LX(5), LX(6) + / 'X', ' ', ' ', ' ', ' ', ' '/ DATA LX(7), LX(8) + / ' ', ' '/ DATA + LXLB(1), LXLB(2), LXLB(3), LXLB(4), LXLB(5), LXLB(6) + / 'X', 'L', 'B', ' ', ' ', ' '/ DATA LXLB(7), LXLB(8) + / ' ', ' '/ DATA + LXUB(1), LXUB(2), LXUB(3), LXUB(4), LXUB(5), LXUB(6) + / 'X', 'U', 'B', ' ', ' ', ' '/ DATA LXUB(7), LXUB(8) + / ' ', ' '/ DATA + LY(1), LY(2), LY(3), LY(4), LY(5), LY(6) + / 'Y', ' ', ' ', ' ', ' ', ' '/ DATA LY(7), LY(8) + / ' ', ' '/ DATA + LYLB(1), LYLB(2), LYLB(3), LYLB(4), LYLB(5), LYLB(6) + / 'Y', 'L', 'B', ' ', ' ', ' '/ DATA LYLB(7), LYLB(8) + / ' ', ' '/ DATA + LYM(1), LYM(2), LYM(3), LYM(4), LYM(5), LYM(6) + / 'Y', 'M', ' ', ' ', ' ', ' '/ DATA LYM(7), LYM(8) + / ' ', ' '/ DATA + LYUB(1), LYUB(2), LYUB(3), LYUB(4), LYUB(5), LYUB(6) + / 'Y', 'U', 'B', ' ', ' ', ' '/ DATA LYUB(7), LYUB(8) + / ' ', ' '/ C C COMMENCE BODY OF ROUTINE C IERR = 0 HEAD = .TRUE. C C NUMBER OF POINTS MUST BE AT LEAST 1 C CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERR01, LONE) C C THERE MUST BE AT LEAST 1 COLUMN OF VECTORS C CALL EISGE(NMSUB, LM, M, 1, 2, HEAD, ERR02, LONE) C C THE ACTUAL LENGTH OF YM MUST EQUAL OR EXCEED THE NUMBER OF C OBSERVATIONS C ERR03 = .TRUE. IF (.NOT.ERR01) + CALL EISGE(NMSUB, LIYM, IYM, N, 3, HEAD, ERR03, LN) C C IF THIS IS A LOG PLOT CHECK FOR NON-POSITIVE VALUES IN DATA C IF (ERR01 .OR. ERR02 .OR. ERR03) IERR = 1 IF (ILOG .LE. 0) RETURN C ERR04 = .FALSE. ERR05 = .FALSE. ERR06 = .FALSE. ERR07 = .FALSE. ERR08 = .FALSE. ERR09 = .FALSE. C CALL PRTCNT (MAX(0,ILOG),2,ILOGXY) IF ((ILOGXY(1).NE.0) .AND. XCHECK) THEN IF (.NOT.ERR01) THEN C C IF X AXIS IS LOG SCALE, CHECK FOR NEGATIVE X AXIS VALUES C IF (MISS) THEN CALL ERVGTM(NMSUB, LX, X, XMISS, N, 0.0E0, 0, HEAD, 1, + NV, ERR04, LX) ELSE CALL ERVGT(NMSUB, LX, X, N, 0.0E0, 0, HEAD, 1, NV, ERR04, + LX) END IF END IF C IF (XLB.LT.XUB) THEN C C CHECK FOR NEGATIVE PLOT BOUNDS C CALL ERSGT(NMSUB, LXLB, XLB, 0.0E0, 1, HEAD, ERR05, LXLB) CALL ERSGT(NMSUB, LXUB, XUB, 0.0E0, 1, HEAD, ERR06, LXUB) END IF END IF IF (ILOGXY(2).NE.0) THEN IF ((.NOT.ERR01) .AND. (.NOT.ERR02) .AND. (.NOT.ERR03)) THEN C C IF Y AYIS IS LOG SCALE, CHECK FOR NEGATIVE Y AYIS VALUES C IF (MISS) THEN IF (MULTI) THEN CALL ERAGTM(NMSUB, LYM, YM, YMMISS, N, M, IYM, 0.0E0, 0, + HEAD, 1, NV, ERR04, LYM) ELSE CALL ERVGTM(NMSUB, LY, YM, YMMISS(1), N, 0.0E0, 0, HEAD, + 1, NV, ERR04, LY) END IF ELSE IF (MULTI) THEN CALL ERAGT(NMSUB, LYM, YM, N, M, IYM, 0.0E0, 0, HEAD, + 1, NV, ERR04, LYM) ELSE CALL ERVGT(NMSUB, LY, YM, N, 0.0E0, 0, HEAD, 1, + NV, ERR04, LY) END IF END IF END IF C IF (YLB.LT.YUB) THEN C C CHECK FOR NEGATIVE PLOT BOUNDS C CALL ERSGT(NMSUB, LYLB, YLB, 0.0E0, 1, HEAD, ERR05, LYLB) CALL ERSGT(NMSUB, LYUB, YUB, 0.0E0, 1, HEAD, ERR06, LYUB) END IF END IF C IF (ERR04 .OR. ERR05 .OR. ERR06 .OR. ERR07 .OR. ERR08 .OR. ERR09) + IERR = 1 C RETURN C END *PLTPLX SUBROUTINE PLTPLX(POINT, YMN, SCALE, IPOINT, IEND) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE POINT LOCATION IN THE PLOT STRING. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + POINT,SCALE,YMN INTEGER + IEND,IPOINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IEND C THE NUMBER OF LOCATIONS IN THE PLOT STRING. C INTEGER IPOINT C THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED. C REAL POINT C THE VALUE TO BE PLOTTED. C REAL SCALE C THE SCALE INTERVAL OF THE PLOT. C REAL YMN C THE GRAPH AXIS LOWER LIMITS ACTUALLY USED. C IPOINT = (POINT-YMN)/SCALE + 2.5 IF (IPOINT .LT. 2) IPOINT = 1 IF (IPOINT .GT. IEND) IPOINT = IEND RETURN END *PLTSYM SUBROUTINE PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SUPPLIES THE APPROPRIATE PLOT SYMBOL FOR C THE PLOT LINE. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + I,IPOINT,IPTSYM,J,N C C ARRAY ARGUMENTS INTEGER + ICOUNT(103),ISYM(N) CHARACTER + LINE(103)*1 C C LOCAL SCALARS INTEGER + ISYMBL C C LOCAL ARRAYS CHARACTER + SYM(30)*1,SYM1(10)*1 C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEXING VARIABLE. C INTEGER ICOUNT(103) C THE NUMBER OF PLOT SYMBOLS AT EACH LOCATION. C INTEGER IPOINT C THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED. C INTEGER IPTSYM C AN INDICATOR VARIABLE USED TO DESIGNATE THE TYPE C OF PLOT. IF IPTSYM = 1, THE PLOT IS A SYMPLE PAGE C OR VERTICAL PLOT. IF IPTSYM = 2, THE PLOT IS A SYMBOL C PLOT. IF IPTSYM = 3, THE PLOT IS A MULTIVARIATE PLOT. C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER ISYMBL C THE INDEX OF THE PLOT SYMBOL TO BE USED. C INTEGER J C AN INDEX VARIABLE. C CHARACTER*1 LINE(103) C THE VECTOR USED FOR THE PLOT STRING. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 SYM(30), SYM1(10) C THE PLOT SYMBOLS. C DATA SYM( 1)/'+'/,SYM( 2)/'.'/,SYM( 3)/'*'/,SYM( 4)/'-'/, + SYM( 5)/'A'/,SYM( 6)/'B'/,SYM( 7)/'C'/,SYM( 8)/'D'/, + SYM( 9)/'E'/,SYM(10)/'F'/,SYM(11)/'G'/,SYM(12)/'H'/, + SYM(13)/'I'/,SYM(14)/'J'/,SYM(15)/'K'/,SYM(16)/'L'/, + SYM(17)/'M'/,SYM(18)/'N'/,SYM(19)/'O'/,SYM(20)/'P'/, + SYM(21)/'Q'/,SYM(22)/'R'/,SYM(23)/'S'/,SYM(24)/'T'/, + SYM(25)/'U'/,SYM(26)/'V'/,SYM(27)/'W'/,SYM(28)/'Y'/, + SYM(29)/'Z'/,SYM(30)/'Z'/ DATA SYM1(1)/'1'/,SYM1(2)/'2'/,SYM1(3)/'3'/,SYM1(4)/'4'/, + SYM1(5)/'5'/,SYM1(6)/'6'/,SYM1(7)/'7'/,SYM1(8)/'8'/, + SYM1(9)/'9'/,SYM1(10)/'X'/ C ICOUNT(IPOINT) = ICOUNT(IPOINT) + 1 IF (ICOUNT(IPOINT) .EQ. 1) GO TO 5 C ISYMBL = MIN(ICOUNT(IPOINT), 10) LINE(IPOINT) = SYM1(ISYMBL) RETURN C 5 CONTINUE GO TO (10, 20, 30), IPTSYM C 10 LINE(IPOINT) = SYM(1) RETURN C 20 ISYMBL = MIN(29, MAX(1, ISYM(I))) LINE(IPOINT) = SYM(ISYMBL) RETURN C 30 ISYMBL = MIN(29, MAX(1, J+4)) LINE(IPOINT) = SYM(ISYMBL) C RETURN END *POLAR SUBROUTINE POLAR (AMPL, PHAS, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE CONVERTS THE PAIR OF SERIES AMPL AND PHAS C FROM THE REAL AND IMAGINARY PARTS OF A SERIES OF COMPLEX C NUMBERS TO THEIR MAGNITUDES AND PHASES. THE CONVERSION IS C DONE IN PLACE. C C WRITTEN BY - PETER BLOOMFIELD C FOURIER ANALSERIESSIS OF TIME SERIES- AN C INTRODUCTION C JOHN WILESERIES AND SONS, NEW SERIESORK, 1976 C PAGE 150 C ADAPTED FOR STARPAC BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DEVISION C NATIONAL BUREAU OF STANDARDS C BOULDER, COLORADO C C CREATION DATE - NOVEMBER 26, 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS REAL + AMPL(N),PHAS(N) C C LOCAL SCALARS REAL + PHASE,R INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ATAN2,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AMPL(N) C THE ARRAY IN WHICH THE AMPLITUDES ARE STORED. C INTEGER I C AN INDEX VARIABLE. C INTEGER N C THE NUMBER OF OBSERVATIONS. C REAL PHAS(N) C THE ARRAY IN WHICH THE PRIMARY PHASE ESTIMATES ARE RETURNED. C REAL PHASE C THE PHASE COMPONENT OF THE DEMODULATED SERIES. C REAL R C THE AMPLITUDE COMPONENT OF THE DEMODULATED SERIES. C DO 10 I = 1, N R = SQRT(AMPL(I)*AMPL(I) + PHAS(I)*PHAS(I)) PHASE = 0.0E0 IF (R .NE. 0.0E0) PHASE = ATAN2(PHAS(I), AMPL(I)) AMPL(I) = R PHAS(I) = PHASE 10 CONTINUE RETURN END *PPC SUBROUTINE PPC(YM, X, N, ILOG, ISIZE, NOUT, YLB, YUB, XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,ISIZE,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XMISS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', 'C', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ISCHCK = 0 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PPC (Y, X, N, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *PPCNT SUBROUTINE PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLING ROUTINE FOR USER CALLED PAGE PLOT ROUTINES C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,ISCHCK,ISIZE,IYM,LISYM,M,N,NOUT LOGICAL + MISS,MULTI C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(*) INTEGER + ISYM(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XMN,XMX,YMN,YMX LOGICAL + ERROR,XCHECK C C EXTERNAL SUBROUTINES EXTERNAL PLTCHK,PPLMT,PPMN,VERSP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C A VALUE INDICATING WHETHER AN ERROR WAS DETECTEC (TRUE) C OR NOT (FALSE). C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(LISYM) C VECTOR CONTAINING SYMBOLS FOR PLOTTING, NOT USED IN SOME CASES C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C LOGICAL XCHECK C INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES C ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.) C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XMN, XMX C THE X-AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C VECTOR OF OBSERVATIONS FOR THE Y (VERTICAL) COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YMN, YMX C THE Y-AYIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C COMMENCE BODY OF ROUTINE C XCHECK = .TRUE. CALL PLTCHK (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, MISS, XCHECK) C IF (IERR.EQ.0) THEN C C DETERMINE THE BOUNDS FOR THE X AND Y AXIS AND COMPLETE ERROR C CHECKING C CALL PPLMT (YM, YMMISS, X, XMISS, N, M, IYM, YLB, YUB, YMN, YMX, + XLB, XUB, XMN, XMX, ERROR, NMSUB, MISS) C IF (ERROR) THEN IERR = 1 ELSE C C PRINT PLOT C IF (ISIZE.LE.9) THEN CALL VERSP(.TRUE.) ELSE CALL VERSP(.FALSE.) END IF CALL PPMN (YM, YMMISS, X, XMISS, N, M, IYM, ISCHCK, ISYM, + LISYM, ISIZE, NOUT, YMN, YMX, XMN, XMX, MISS, ILOG) C END IF END IF C RETURN C END *PP SUBROUTINE PP(YM, X, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', ' ', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 0 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PP (Y, X, N)') END *PPFCHS REAL FUNCTION PPFCHS(P, NU) C C LATEST REVISION - 03/15/90 (JRD) C C THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE CHSPPF, WITH C MODIFICATIONS TO FACILITATE CONVERSION TO DOUBLE PRECISION C AUTOMATICALLY USING THE NAG, INC., CODE APT, AND TO CORRESPOND C TO STARPAC CONVENTIONS. C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE CHI-SQUARED DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU. C THE CHI-SQUARED DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL NON-NEGATIVE X, C AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN C IN REFERENCES 2, 3, AND 4 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 INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0E0 (INCLUSIVELY) C AND 1.0E0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --NU = THE INTEGER NUMBER OF DEGREES C OF FREEDOM. C NU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPFCHS = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPFCHS FOR THE CHI-SQUARED DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = NU. C PRINTING--DECEMBER 2, 1985 (JRD) UNLESS AN INPUT ARGUMENT ERROR C C RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE. C --P SHOULD BE BETWEEN 0.0E0 (INCLUSIVELY) C AND 1.0E0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--REAL. C LANGUAGE--ANSI FORTRAN. C ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS) C COMPARED TO THE KNOWN NU = 2 (EXPONENTIAL) C RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT C DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO C P = .999. FOR P = .95 AND SMALLER, THE AGREEMENT C WAS EVEN BETTER--7 SIGNIFICANT DIGITS. C (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK, C GNANADESIKAN, AND HUYETT REFERENCE BELOW, PAGE 20, C ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE-- C THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3 C SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE) C FOR P = .999.) C REFERENCES--WILK, GNANADESIKAN, AND HUYETT, "PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION", C TECHNOMETRICS, 1962, PAGES 1-15, C ESPECIALLY PAGES 3-5. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 257, FORMULA 6.1.41, C AND PAGES 940-943. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 46-51. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE 301-921-2315 C ORIGINAL VERSION--SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C C--------------------------------------------------------------------- C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + P INTEGER + NU C C LOCAL SCALARS REAL + A,AJ,B,C,CUT1,CUT2,CUTOFF,DEN,DX,FP,GAMMA, + PCALC,SUM,TERM,XDEL,XLOWER,XMAX,XMID,XMIN,XMIN0,XUPPER, + Z,Z2,Z3,Z4,Z5 INTEGER + ICOUNT,ILOOP,IPRT,J,MAXIT C C LOCAL ARRAYS REAL + D(10) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC EXP,LOG C C DATA C/0.918938533204672741E0/ DATA D(3),D(4),D(5) + /+0.793650793650793651E-3, + -0.595238095238095238E-3, + +0.8417508417508417151E-3/ DATA D(6),D(7),D(8),D(9),D(10) + /-0.191752691752691753E-2, + +0.641025641025641025E-2, + -0.2955065359147712418E-1, + +0.179644372368830573E0, + -0.139243221690590111E1/ C D(1) = 1.0E0/12.0E0 D(2) = 1.0E0/360.0E0 C CALL IPRINT (IPRT) C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF (P.LT.0.0E0 .OR. P.GE.1.0E0) THEN WRITE(IPRT,1010) WRITE(IPRT,1030) P PPFCHS = 0.0E0 RETURN END IF IF(NU.LT.1) THEN WRITE(IPRT,1020) WRITE(IPRT,1040) NU PPFCHS = 0.0E0 RETURN END IF C C-----START POINT----------------------------------------------------- C C EXPRESS THE CHI-SQUARED DISTRIBUTION PERCENT POINT C FUNCTION IN TERMS OF THE EQUIVALENT GAMMA C DISTRIBUTION PERCENT POINT FUNCTION, C AND THEN EVALUATE THE LATTER. C FP = P GAMMA = NU/2.0E0 MAXIT = 10000 C C COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE C NBS APPLIED MATHEMATICS SERIES REFERENCE. C THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. C IT IS USED IN THE CALCULATION OF THE CDF BASED ON C THE TENTATIVE VALUE OF THE PPFCHS IN THE ITERATION. C Z = GAMMA DEN = 1.0E0 150 IF(Z.LT.10.0E0) THEN DEN = DEN*Z Z = Z+1.0E0 GO TO 150 END IF Z2 = Z*Z Z3 = Z*Z2 Z4 = Z2*Z2 Z5 = Z2*Z3 A = (Z-0.5E0)*LOG(Z)-Z+C B = D(1)/Z + D(2)/Z3 + D(3)/Z5 + D(4)/(Z2*Z5) + D(5)/(Z4*Z5) + + D(6)/(Z*Z5*Z5) + D(7)/(Z3*Z5*Z5) + D(8)/(Z5*Z5*Z5) + + D(9)/(Z2*Z5*Z5*Z5) C G = EXP(A+B)/DEN C C DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P C PERCENT POINT. C ILOOP = 1 C XMIN0 = (FP*GAMMA*G)**(1.0E0/GAMMA) XMIN0 = EXP((1.0E0/GAMMA)*(LOG(FP)+LOG(GAMMA)+(A+B)-LOG(DEN))) XMIN = XMIN0 XLOWER = XMIN XMID = XMIN XUPPER = XMIN ICOUNT = 1 350 CONTINUE XMAX = ICOUNT*XMIN0 DX = XMAX GO TO 600 360 IF(PCALC.LT.FP) THEN XMIN = XMAX ICOUNT = ICOUNT+1 IF(ICOUNT.LE.30000) GO TO 350 END IF XMID = (XMIN+XMAX)/2.0E0 C C NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED. C ILOOP = 2 XLOWER = XMIN XUPPER = XMAX ICOUNT = 0 550 DX = XMID GO TO 600 560 IF(PCALC.NE.FP) THEN IF(PCALC.GT.FP) THEN XUPPER = XMID XMID = (XMID+XLOWER)/2.0E0 ELSE XLOWER = XMID XMID = (XMID+XUPPER)/2.0E0 END IF XDEL = XMID-XLOWER IF(XDEL.LT.0.0E0)XDEL = -XDEL ICOUNT = ICOUNT+1 IF((XDEL.GE.0.0000000001E0) .AND. (ICOUNT.LE.100)) GO TO 550 END IF PPFCHS = 2.0E0*XMID RETURN C C******************************************************************** C THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. C THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE C PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 C ITERATION LOOPS IN THE ABOVE CODE. C C COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN, C AND HUYETT REFERENCE C 600 SUM = 1.0E0/GAMMA TERM = 1.0E0/GAMMA CUT1 = DX-GAMMA CUT2 = DX*10000000000.0E0 DO 700 J=1,MAXIT AJ = J TERM = DX*TERM/(GAMMA+AJ) SUM = SUM+TERM CUTOFF = CUT1+(CUT2*TERM/SUM) IF (AJ.GT.CUTOFF) GO TO 750 700 CONTINUE WRITE(IPRT,1050)MAXIT WRITE(IPRT,1060)P WRITE(IPRT,1070)NU WRITE(IPRT,1080) PPFCHS = 0.0E0 RETURN C 750 CONTINUE C PCALC = (DX**GAMMA)*(EXP(-DX))*SUM/G PCALC = EXP(GAMMA*LOG(DX) + LOG(SUM) + LOG(DEN) - DX - A - B) IF (ILOOP.EQ.1) GO TO 360 GO TO 560 C 1010 FORMAT(' ',115H***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE + PPFCHS FUNCTION IS OUTSIDE THE ALLOWABLE (0,1 ) INTERVAL *****) 1020 FORMAT(' ', 91H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE + PPFCHS FUNCTION IS NON-POSITIVE ***** ) 1030 FORMAT(' ', 35H***** THE VALUE OF THE ARGUMENT IS ,E15.8,6H *****) 1040 FORMAT(' ', 35H***** THE VALUE OF THE ARGUMENT IS ,I8 ,6H *****) 1050 FORMAT(' ',48H*****ERROR IN INTERNAL OPERATIONS IN THE PPFCHS , + 43HFUNCTION--THE NUMBER OF ITERATIONS EXCEEDS ,I7) 1060 FORMAT(' ',33H THE INPUT VALUE OF P IS ,E15.8) 1070 FORMAT(' ',33H THE INPUT VALUE OF NU IS ,I8) 1080 FORMAT(52H THE OUTPUT VALUE OF PPFCHS HAS BEEN SET TO 0.0) C END *PPFF REAL FUNCTION PPFF(P, NU1, NU2) C C LATEST REVISION - 03/15/90 (JRD) C C THIS FUNCTION IS A VERSION OF DATAPLOT SUBROUTINE FPPF, C WITH MODIFICATIONS NECESSARY TO CORRESPOND TO STARPAC CONVENTIONS. C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FOR THE F DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM C PARAMETERS = NU1 AND NU2. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0E0 AND 1.0E0) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --NU1 = THE INTEGER DEGREES OF FREEDOM C FOR THE NUMERATOR OF THE F RATIO. C NU1 SHOULD BE POSITIVE. C --NU2 = THE INTEGER DEGREES OF FREEDOM C FOR THE DENOMINATOR OF THE F RATIO. C NU2 SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPFF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPFF FOR THE F DISTRIBUTION C WITH DEGREES OF FREEDOM C PARAMETERS = NU1 AND NU2. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN C 0.0E0 (INCLUSIVELY) AND 1.0E0 (EXCLUSIVELY). C --NU1 SHOULD BE A POSITIVE INTEGER VARIABLE. C --NU2 SHOULD BE A POSITIVE INTEGER VARIABLE. C LANGUAGE--ANSI FORTRAN. C REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGES 946-947, C FORMULAE 26.6.4, 26.6.5, 26.6.8, AND 26.6.15. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGE 83, FORMULA 20, C AND PAGE 84, THIRD FORMULA. C --PAULSON, AN APPROXIMATE NORMAILIZATION C OF THE ANALYSIS OF VARIANCE DISTRIBUTION, C ANNALS OF MATHEMATICAL STATISTICS, 1942, C NUMBER 13, PAGES 233-135. C --SCHEFFE AND TUKEY, A FORMULA FOR SAMPLE SIZES C FOR POPULATION TOLERANCE LIMITS, 1944, C NUMBER 15, PAGE 217. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE-- THIS ROUTINE WAS ADAPTED FROM DATAPLOT SUBROUTINE C FPPF WITH PERMISSION FROM THE AUTHOR. DATAPLOT IS C A REGISTERED TRADEMARK. C C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THIS LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C VERSION NUMBER--82.3 C ORIGINAL VERSION--MAY 1978. C UPDATED --AUGUST 1979. C UPDATED --DECEMBER 1981. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + P INTEGER + NU1,NU2 C C LOCAL SCALARS REAL + ANU1,ANU2,EXPF,PCALC,SDF,TOL,X,XDEL,XLOW,XMAX, + XMID,XMIN,XN,XUP,ZN INTEGER + IBUG,ICOUNT,IPRT,MAXIT C C EXTERNAL FUNCTIONS REAL + CDFF,PPFNML EXTERNAL CDFF,PPFNML C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC ABS,EXP,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ANU1 C THE (REAL) DEGREES OF FREEDOM IN THE NUMERATOR. C REAL ANU2 C THE (REAL) DEGREES OF FREEDOM IN THE DENOMINATOR. C REAL EXPF C * C INTEGER IBUG C * C INTEGER ICOUNT C * C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER MAXIT C * C INTEGER NU1 C THE DEGREES OF FREEDOM IN THE NUMERATOR. C INTEGER NU2 C THE DEGREES OF FREEDOM IN THE DENOMINATOR. C REAL P C THE VALUE (BETWEEN 0.0E0 AND 1.0E0) AT WHICH THE PERCENT POINT C IS TO BE CALCULATED. C REAL PCALC C * C REAL SDF C * C REAL TOL C * C REAL X C * C REAL XDEL C * C REAL XLOW C * C REAL XMAX C * C REAL XMID C * C REAL XMIN C * C REAL XN C * C REAL XUP C * C REAL ZN C * C C--------------------------------------------------------------------- C C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C COMMON /PRINT/IFEEDB,IPRINT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C CALL IPRINT(IPRT) C PPFF = 0.0E0 IF (NU1.LE.0) GO TO 10 IF (NU2.LE.0) GO TO 20 IF (P.LT.0.0E0 .OR. P.GE.1.0E0) GO TO 30 GO TO 40 10 WRITE (IPRT,1010) WRITE (IPRT,1040) NU1 PPFF = 0.0E0 RETURN 20 WRITE (IPRT,1020) WRITE (IPRT,1040) NU2 PPFF = 0.0E0 RETURN 30 WRITE (IPRT,1000) WRITE (IPRT,1030) P PPFF = 0.0E0 RETURN 40 CONTINUE C C-----START POINT----------------------------------------------------- C IBUG = 0.0E0 C TOL = 0.000001E0 MAXIT = 100 XMIN = 0.0E0 XMAX = 10.0E30 XLOW = XMIN XUP = XMAX C ANU1 = NU1 ANU2 = NU2 C EXPF = 0.5E0*((1.0E0/ANU2)-(1.0E0/ANU1)) SDF = SQRT(0.5E0*((1.0E0/ANU2)+(1.0E0/ANU1))) ZN = PPFNML(P) XN = EXPF + ZN*SDF XMID = EXP(2.0E0*XN) IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID C IF (P.EQ.0.0E0) GO TO 50 GO TO 60 50 CONTINUE PPFF = XMIN RETURN 60 CONTINUE C ICOUNT = 0 C 70 CONTINUE X = XMID PCALC = CDFF(X,ANU1,ANU2) IF (PCALC.EQ.P) GO TO 130 IF (PCALC.GT.P) GO TO 100 C 80 CONTINUE XLOW = XMID X = XMID*2.0E0 IF (X.GE.XUP) GO TO 90 XMID = X IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID PCALC = CDFF(X,ANU1,ANU2) IF (PCALC.EQ.P) GO TO 130 IF (PCALC.LT.P) GO TO 80 XUP = X 90 CONTINUE XMID = (XLOW+XUP)/2.0E0 IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID GO TO 120 C 100 CONTINUE XUP = XMID X = XMID/2.0E0 IF (X.LE.XLOW) GO TO 110 XMID = X IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID PCALC = CDFF(X,ANU1,ANU2) IF (PCALC.EQ.P) GO TO 130 IF (PCALC.GT.P) GO TO 100 XLOW = X 110 CONTINUE XMID = (XLOW+XUP)/2.0E0 IF (IBUG.EQ.1) WRITE (IPRT,1050) XMID C 120 CONTINUE XDEL = ABS(XMID-XLOW) ICOUNT = ICOUNT + 1 IF (XDEL.LT.TOL .OR. ICOUNT.GT.MAXIT) GO TO 130 GO TO 70 C 130 CONTINUE PPFF = XMID C RETURN 1000 FORMAT (' ', 49H***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO T, + 59HHE FPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL , + 5H*****) 1010 FORMAT (' ', 49H***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO T, + 42HHE FPPF SUBROUTINE IS NON-POSITIVE *****) 1020 FORMAT (' ', 49H***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO T, + 42HHE FCDF SUBROUTINE IS NON-POSITIVE *****) 1030 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , E15.8, + 6H *****) 1040 FORMAT (' ', 35H***** THE VALUE OF THE ARGUMENT IS , I8, 6H *****) 1050 FORMAT (' ', 7HXMID = , E15.7) END *PPFNML REAL 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.0E0 AND 1.0E0, 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 REAL + P C C LOCAL SCALARS REAL + 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 REAL ADEN, ANUM C * C REAL P C THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED C REAL P0, P1, P2, P3, P4 C VARIOUS PARAMETERS USED IN THE APPROXIMATIONS. C REAL Q0, Q1, Q2, Q3, Q4 C VARIOUS ADDITIONAL PARAMETERS USED IN THE APPROXIMATIONS. C REAL R C * C REAL T C * C DATA P0, P1, P2, P3, P4 + /-.322232431088E0, -1.0E0, -.342242088547E0, + -.204231210245E-1,-.453642210148E-4/ DATA Q0, Q1, Q2, Q3, Q4 + /.993484626060E-1, .588581570495E0, + .531103462366E0, .103537752850E0, .38560700634E-2/ C C IF (P.NE.0.5E0) GO TO 30 PPFNML = 0.0E0 RETURN C 30 R = P IF (P.GT.0.5E0) R = 1.0E0 - R T = SQRT(-2.0E0*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.5E0) PPFNML = -PPFNML C RETURN C END *PPFT REAL 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.0E0 (EXCLUSIVELY) C AND 1.0E0 (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 REAL + P INTEGER + IDF C C LOCAL SCALARS REAL + 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 REAL + 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 REAL ARG C * C REAL B21 C * C REAL B31, B32, B33, B34 C * C REAL B41, B42, B43, B44, B45 C * C REAL B51, B52, B53, B54, B55, B56 C * C REAL C, CON C * C REAL DF C THE DEGREES OF FREEDOM. C REAL D1, D3, D5, D7, D9 C * C INTEGER IDF C THE (INTEGER) DEGREES OF FREEDOM. C INTEGER IPASS C * C INTEGER MAXIT C * C REAL P C THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED. C REAL PI C THE VALUE OF PI. C REAL PPFN C THE NORMAL PERCENT POINT VALUE. C REAL S C * C REAL SQRT2 C THE SQUARE ROOT OF TWO. C * C REAL TERM1, TERM2, TERM3, TERM4, TERM5 C * C REAL Z C * C C DEFINE CONSTANTS USED IN THE APPROXIMATIONS C DATA B21 /4.0E0/ DATA B31, B32, B33, B34 /96.0E0, 5.0E0, 16.0E0, 3.0E0/ DATA B41, B42, B43, B44, B45 + /384.0E0, 3.0E0, 19.0E0, 17.0E0, -15.0E0/ DATA B51, B52, B53, B54, B55, B56 + /9216.0E0, 79.0E0, 776.0E0, 1482.0E0, + -1920.0E0, -945.0E0/ C CALL GETPI(PI) C SQRT2 = SQRT(2.0E0) 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.0E0 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.0E0 TERM2 = 2.0E0*P - 1.0E0 TERM3 = SQRT(P*(1.0E0-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.0E0/B21)*(D3+D1)/DF TERM3 = (1.0E0/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) TERM4 = (1.0E0/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) TERM5 = (1.0E0/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.5E0) 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.0E0*C*C) 70 CONTINUE PPFT = SQRT(DF)*S/C RETURN C C AUGMENT THE RESULTS FOR THE IDF = 4 CASE C 80 CON = 2.0E0*(P-0.5E0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 90 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((1.0E0+0.5E0*C*C)*S-CON)/(1.5E0*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.5E0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 110 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - (Z+(C+(2.0E0/3.0E0)*C*C*C)*S-CON)/((8.0E0/3.0E0)*C**4) 110 CONTINUE PPFT = SQRT(DF)*S/C RETURN C C AUGMENT THE RESULTS FOR THE IDF = 6 CASE C 120 CON = 2.0E0*(P-0.5E0) ARG = PPFT/SQRT(DF) Z = ATAN(ARG) DO 130 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((1.0E0+0.5E0*C*C+0.375E0*C**4)*S-CON)/ + ((15.0E0/8.0E0)*C**5) 130 CONTINUE PPFT = SQRT(DF)*S/C RETURN C END *PPL SUBROUTINE PPL(YM, X, N, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N C C ARRAY ARGUMENTS REAL + X(*),YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', 'L', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 0 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PPL (Y, X, N, ILOG)') END *PPLMT SUBROUTINE PPLMT (YM, YMMISS, X, XMISS, N, M, IYM, YLB, YUB, YMN, + YMX, XLB, XUB, XMN, XMX, ERROR, NMSUB, MISS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE PLOT LIMITS FOR PAGE PLOTS C WITH MISSING VALUES. C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS C REAL + XLB,XMISS,XMN,XMX,XUB,YLB,YMN,YMX,YUB INTEGER + IYM,M,N LOGICAL + ERROR,MISS C C ARRAY ARGUMENTS REAL + X(N),YM(IYM,M),YMMISS(M) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + I,II,IPRT,J LOGICAL + HEAD,SETLMT,SKPROW C C EXTERNAL FUNCTIONS LOGICAL + MVCHK real r1mach EXTERNAL MVCHK external r1mach C C EXTERNAL SUBROUTINES EXTERNAL ADJLMT,EHDR,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C A VALUE INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) C OR NOT (FALSE). C LOGICAL HEAD C PRINT HEADING (HEAD=TRUE) OR NOT (HEAD=FALSE). C INTEGER I, II C INDEXING VARIABLES. C INTEGER IPRT C ... C INTEGER IYM C ACTUAL ROW DIMENSION OF YM DECLARED IN THE USERS MAIN PROGRAM C INTEGER J C AN INDEX VARIABLE. C INTEGER M C THE NUMBER OF VECTORS IN YM C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS . C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C LOGICAL SETLMT C AN INDICATOR VARIABLE USED TO DETERMINE IF STARTING VALUES C FOR XMN, XMX, YMN, YMX HAVE BEEN FOUND. C LOGICAL SKPROW C AN INDICATOR VARIABLE USED TO DESIGNATE WHETHER ALL C OBSERVATIONS IN A GIVEN ROW OF YM ARE UNUSED (TRUE) C OR NOT (FALSE). C REAL X(N) C THE ARRAY CONTAINING THE INDEPENDENT VARIABLE. C REAL XLB C THE USER SUPPLIED X-AXIS LOWER BOUND. C REAL XMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IS MISSING. C IF X(I) = XMISS, THE VALUE IS ASSUMED MISSING, OTHERWISE C IT IS NOT. C REAL XMN, XMX C THE X-AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL XUB C THE USER SUPPLIED X-AXIS UPPER BOUNDS. C REAL YLB C THE USER SUPPLIED Y-AXIS LOWER BOUND. C REAL YM(IYM,M) C THE ARRAY CONTAINING THE DEPENDENT VARIABLE(S). C REAL YMMISS(M) C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IS MISSING. C IF YM(I,J) = YMMISS(J), THE VALUE IS ASSUMED MISSING, OTHERWISE C IT IS NOT. C REAL YMN, YMX C THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YUB C THE USER SUPPLIED Y-AXIS UPPER BOUNDS. C ERROR = .FALSE. C IF ((XLB .LT. XUB) .AND. (YLB .LT. YUB)) THEN C C SET LIMITS TO USER SPECIFIED VALUES C XMN = XLB XMX = XUB YMN = YLB YMX = YUB C ELSE C C SET LIMITS TO RANGE OF VALUES WITHIN ANY USER SPECIFIED VALUES C SETLMT = .FALSE. II = 1 xmn = r1mach(2) xmx = -r1mach(2) ymn = r1mach(2) ymx = -r1mach(2) C C FIND FIRST VALUE TO BE PLOTTED C DO 20 I=1,N IF (MISS .AND. MVCHK(X(I),XMISS)) GO TO 20 IF ((XLB.LT.XUB) .AND. ((X(I).LT.XLB) .OR. + (XUB.LT.X(I)))) GO TO 20 XMN = X(I) XMX = X(I) DO 10 J=1,M IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 10 IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR. + (YUB.LT.YM(I,J)))) GO TO 10 IF (SETLMT) GO TO 5 YMN = YM(I,J) YMX = YM(I,J) SETLMT = .TRUE. II = I + 1 GO TO 10 5 YMN = MIN(YMN, YM(I,J)) YMX = MAX(YMX, YM(I,J)) 10 CONTINUE IF (SETLMT) GO TO 30 20 CONTINUE C 30 IF (II.LE.1) THEN C C NO VALUES TO BE PLOTTED. PRINT ERROR MESSAGE C ERROR = .TRUE. CALL IPRINT(IPRT) HEAD = .TRUE. CALL EHDR(NMSUB,HEAD) IF ((YLB.GE.YUB) .AND. (XLB.GE.XUB)) THEN WRITE (IPRT, 1010) ELSE WRITE (IPRT, 1020) END IF WRITE (IPRT, 1030) C ELSE C C FIND LIMITS FROM REMAINING VALUES C IF (II.LE.N) THEN DO 50 I=II,N IF (MISS .AND. MVCHK(X(I),XMISS)) GO TO 50 IF ((XLB.LT.XUB) .AND. ((X(I).LT.XLB) .OR. + (XUB.LT.X(I)))) GO TO 50 SKPROW = .TRUE. DO 40 J=1,M IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 40 IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR. + (YUB.LT.YM(I,J)))) GO TO 40 SKPROW = .FALSE. YMN = MIN(YMN, YM(I,J)) YMX = MAX(YMX, YM(I,J)) 40 CONTINUE IF (SKPROW) GO TO 50 XMN = MIN(XMN, X(I)) XMX = MAX(XMX, X(I)) 50 CONTINUE END IF END IF C IF (YLB.LT.YUB) THEN C C SET Y AXIS LIMITS TO USER SUPPLIED VALUES C YMN = YLB YMX = YUB ELSE C C ADJUST Y AXIS LIMITS IF EQUAL C IF (YMN .GE. YMX) CALL ADJLMT(YMN, YMX) END IF C IF (XLB.LT.XUB) THEN C C SET X AXIS LIMITS TO USER SUPPLIED VALUES C XMN = XLB XMX = XUB ELSE C C ADJUST X AXIS LIMITS IF EQUAL C IF (XMN .GE. XMX) CALL ADJLMT(XMN, XMX) C END IF C END IF C RETURN C C FORMAT STATEMENTS C 1010 FORMAT (/ + 44H NO NON-MISSING PLOT COORDINATES WERE FOUND.) 1020 FORMAT (/ + 40H NO NON-MISSING VALUES WERE FOUND WITHIN, + 26H THE USER SUPPLIED LIMITS.) 1030 FORMAT (/ + 30H THE PLOT HAS BEEN SUPPRESSED.) END *PPMC SUBROUTINE PPMC(YM, YMMISS, X, XMISS, N, ILOG, ISIZE, NOUT, YLB, + YUB, XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT FOR DATA WITH MISSING OBSERVATIONS (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,ISIZE,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', 'M', 'C', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ISCHCK = 0 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PPMC (Y, YMISS, X, XMISS, N, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *PPM SUBROUTINE PPM(YM, YMMISS, X, XMISS, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT FOR DATA WITH MISSING OBSERVATIONS (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', 'M', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 0 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PPM (Y, YMISS, X, XMISS, N)') END *PPML SUBROUTINE PPML(YM, YMMISS, X, XMISS, N, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT FOR DATA WITH MISSING OBSERVATIONS (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + ILOG,N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'P', 'P', 'M', 'L', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 0 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = 1 C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL PPML (Y, YMISS, X, XMISS, N, ILOG)') END *PPMN SUBROUTINE PPMN (YM, YMMISS, X, XMISS, N, M, IYM, ISCHCK, ISYM, + LISYM, ISIZE, NOUT, YMN, YMX, XMN, XMX, MISS, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN ROUTINE FOR PAGE PLOTS C C WRITTEN BY -- C JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION/BOULDER C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - NOVEMBER 21, 1980 C C INPUT ARGUMENTS - (IN ORDER OF USAGE) C C X THE N VECTOR OF OBSERVATIONS FOR THE X C COORDINATES C Y THE N BY M MATRIX OF OBSERVATIONS FOR THE Y (VERTICAL) C COORDINATES C THE ITH COLUMN IS PLOTTED USING THE FOLLOWING SYMBOL C 1 = A 2 = B 3 = C 4 = D C 5 = E 6 = F 7 = G 8 = H C 9 = I 10 = J 11 = K 12 = L C 13 = M 14 = N 15 = O 16 = P C 17 = Q 18 = R 19 = S 20 = T C 21 = U 22 = V 23 = W 24 = Y C 25 (AND ABOVE) = Z C THE NUMBERS 1 TO 9 INDICATE MULTIPLE POINTS ON A GIVEN C PLOT LOCATION, WHERE THE NUMBER INDICATES HOW MANY POINTS C ARE REPRESENTED C NOTE THAT X IS NOT USED AS A PLOTTING SYMBOL EXCEPT TO C INDICATE THAT MORE THAN 9 POINTS FELL ON THE SAME PLOT C LOCATION C N THE INTEGER NUMBER OF OBSERVATIONS TO BE PLOTTED (IN EACH C COLUMN) C M THE NUMBER OF COLUMNS IN THE Y ARRAY TO BE PLOTTED VERSUS X C FOR THE CASE OF A VECTOR Y, M MUST BE EQUAL TO 1 C IYM THE ACTUAL INTEGER VALUE OF THE ROW DIMENSION OF THE Y ARRAY C WHEN Y IS A VECTOR (M.EQ.1) IYM SHOULD BE SET EQUAL TO N C ISCHCK THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C ISYM THE N VECTOR OF INTEGERS DETERMINING THE PLOTTING SYMBOLS TO C USED FOR THE S SERIES OF PLOTS, WHERE C 1 = + 2 = . 3 = * 4 = - C 5 = A 6 = B 7 = C 8 = D C 9 = E 10 = F 11 = G 12 = H C 13 = I 14 = J 15 = K 16 = L C 17 = M 18 = N 19 = O 20 = P C 21 = Q 22 = R 23 = S 24 = T C 25 = U 26 = V 27 = W 28 = Y C 29 (AND ABOVE) = Z C THE NUMBERS 1 TO 9 INDICATE MULTIPLE POINTS ON A GIVEN C PLOT LOCATION, WHERE THE NUMBER INDICATES HOW MANY POINTS C ARE REPRESENTED C NOTE THAT X IS NOT USED AS A PLOTTING SYMBOL EXCEPT TO C INDICATE THAT MORE THAN 9 POINTS FELL ON THE SAME PLOT C LOCATION C ISIZE THE INTEGER CODE FOR THE PLOT SIZE, WHERE C 0 INDICATES A PLOT 100 COL BY 50 ROWS C 1 INDICATES A PLOT 50 COL BY 50 ROWS C NOUT THE INTEGER VALUE INDICATING HOW MANY OF THE POINTS WHICH C FELL OUTSIDE OF THE GRAPH LIMITS ARE TO BE LISTED C IF XLB.EQ.XUB AND YLB.EQ.YUB, NOUT SHOULD BE SET TO ZERO C XLB THE MINIMUM VALUE OF X TO BE PLOTTED(IE, THE LOWER BOUND FOR C THE X AXIS), WHERE IF XLB=XUB THE ROUTINE WILL DETERMINE C THIS VALUE FROM THE MINIMUM VALUE OF THE X VECTOR C XUB THE MAXIMUM VALUE OF X TO BE PLOTTED(IE, THE UPPER BOUND FOR C THE X AXIS), WHERE IF XLB=XUB THE ROUTINE WILL DETERMINE C THIS VALUE FROM THE MAXIMUM VALUE OF THE X VECTOR C YLB THE MINIMUM VALUE OF Y TO BE PLOTTED(IE, THE LOWER BOUND FOR C THE Y AXIS), WHERE IF YLB=YUB THE ROUTINE WILL DETERMINE C THIS VALUE FROM THE MINIMUM VALUE OF THE Y VECTOR C YUB THE MAXIMUM VALUE OF Y TO BE PLOTTED(IE, THE UPPER BOUND FOR C THE Y AXIS), WHERE IF YLB=YUB THE ROUTINE WILL DETERMINE C THIS VALUE FROM THE MAXIMUM VALUE OF THE Y VECTOR C ILOG THE INTEGER INDICATOR VARIABLE USED TO DETERMINE WHETHER C THE Y AXIS SCALE IS TO BE LOG OR NOT C IF ILOG.EQ.0, THE SCALE IS NOT LOG C IF ILOG.NE.0, THE SCALE IS LOG C C C ADDITIONAL VARIABLES USED - (IN ALPHABETICAL ORDER) C C ALINE THE VECTOR OF THE CURRENT PLOT LINE C ALPHAI THE PLOT AXIS SYMBOL I C AXISCH THE Y A AXIS SYMBOL TO BE USED FOR THE CURRENT LINE, C EITHER I OR - C ALPHAX THE PLOTTING SYMBOL X DESIGNATING MORE THAN 9 POINTS FELL ON C A SINGLE PLOTTING LOCATION C BLANK THE PLOTTING SYMBOL BLANK C DELX THE RANGE OF THE X AXIS C DELY THE RANGE OF THE Y AXIS C HYPHEN THE PLOT AXIS SYMBOL - C IC THE COUNT OF THE NUMBER OF VALUES FALLING OUTSIDE OF THE C GRAPH BOUNDS C ICOL THE COLUMN LOCATION FOR THE PLOT LINE C IOUT THE MINIMUM OF NOUT OR 50, INDICATING HOW MANY OF THE C POINTS WHICH FELL OUTSIDE OF THE GRAPH LIMITS WILL ACTUALLY C BE LISTED C IPCODE THE INTEGER CODE, USED IN ERROR CHECKING, WHICH DETERMINES C WHICH PLOT ROUTINE HAS BEEN CALLED C IPR THE UNIT NUMBER OF THE PRINTER C ITEST THE INDICATOR VARIABLE FOR WHETHER THE X AXIS LABELS ARE C PRINTED IN E OR F FORMAT C KSS AN INTEGER VECTOR USED IN DETERMINING THE PLOT SYMBOL C NEEDED C NN THE NUMBER OF Y LABELS TO BE LISTED ON THE LEFT AXIS, C (DEPENDENT ON THE GRAPH SIZE) C NUMCOL THE INTEGER VALUE OF THE NUMBER OF COLUMNS IN THE GRAPH C NUMLAB THE INTEGER NUMBER OF X LABELS TO BE LISTED AT THE BOTTOM C OF THE GRAPH (DEPENDENT ON GRAPH SIZE) C NUMROW THE INTEGER NUMBER OF ROWS IN THE GRAPH C SYM THE VECTOR OF PLOT SYMBOL ASSIGNMENTS (SEE IS ABOVE) C SYM1 THE VECTOR OF INTEGER VALUES USED TO INDICATE MULTIPLE C POINTS ON THE SAME PLOT LOCATION C TEMP THE ARRAY OF VALUES TO BE PRINTED WHICH FALL OUTSIDE THE C GRAPH LIMITS C XLABEL THE VECTOR OF X AXIS LABELS C XMN THE MINIMUM X VALUE TO BE PLOTTED, COMPUTED FROM DATA OR C ASSIGNED BY XLB C XWIDTH THE VALUE OF AN INDIVIDUAL X AXIS GRAPH INTERVAL C XMX THE MAXIMUM X VALUE TO BE PLOTTED, COMPUTED FROM DATA OR C ASSIGNED BY XUB C YLABEL THE VALUE OF THE Y AXIS LABEL TO BE PRINTED C YLOWER THE LOWER BOUND FOR Y VALUES TO BE PLOTTED ON THE CURRENT C LINE C YMN THE MINIMUM Y VALUE TO BE PLOTTED, COMPUTED FROM DATA OR C ASSIGNED BY YLB C YUPPER THE UPPER BOUND FOR Y VALUES TO BE PLOTTED ON THE CURRENT C LINE C YWIDTH THE VALUE OF AN INDIVIDUAL Y AXIS GRAPH INTERVAL C YMX THE MAXIMUM Y VALUE TO BE PLOTTED, COMPUTED FROM DATA OR C ASSIGNED BY YUB C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS,XMN,XMX,YMN,YMX INTEGER + ILOG,ISCHCK,ISIZE,IYM,LISYM,M,N,NOUT LOGICAL + MISS C C ARRAY ARGUMENTS REAL + X(N),YM(IYM,M),YMMISS(M) INTEGER + ISYM(LISYM) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + DELX,DELY,TN,TX,XDMN,XDMX,XWIDTH,XX,YDMN,YDMX,YL,YLOWER, + YUPPER,YWIDTH,YY INTEGER + I,IC,ICOL,IK,ILOGX,ILOGY,IOUT,IPRT,IROW,IT,ITEST,J,JCOL,K, + L,NLABLX,NLABLY,NLU,NN,NUMCOL,NUMCP2,NUMROW CHARACTER + ALPHAI*1,ALPHAX*1,AXISCH*1,BLANK*1,HYPHEN*1,FMT*4, + XLFMT*205,XLFMT2*205 C C LOCAL ARRAYS REAL + TEMP(50,2),XLABEL(20),YLABEL(20) INTEGER + ALINE(105),ILOGXY(2),ISIZXY(2),ISPACE(20),KSS(101) CHARACTER + CLINE(105)*1,ITEMP(50)*1,SYM(30)*1,SYM1(9)*1 C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LOGLMT,PRTCNT C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10,MAX,MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ALINE(105) C CHARACTER*1 ALPHAI, ALPHAX C CHARACTER*1 AXISCH C CHARACTER*1 BLANK C CHARACTER*1 CLINE(105) C REAL DELX, DELY C CHARACTER FMT*4 C THE FORMAT FOR THE X-AXIS LABELS C CHARACTER*1 HYPHEN C INTEGER I, IC, ICOL, IERR, IK C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER ILOGX C THE VALUES OF P AS SPECIFIED BY ILOG. C INTEGER ILOGXY(2) C THE VALUES OF P AND Q AS SPECIFIED BY ILOG. C INTEGER ILOGY C THE VALUES OF Q AS SPECIFIED BY ILOG. C INTEGER IOUT C INTEGER IPRT, IROW C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISIZXY(2) C INTEGER ISPACE(20) C THE SPACING FOR THE X-AXIS LABELS C INTEGER ISYM(LISYM) C INTEGER IT C CHARACTER*1 ITEMP(50) C INTEGER ITEST C INTEGER IYM C INTEGER J, JCOL C INTEGER K C INTEGER KSS(101) C INTEGER L C INTEGER LISYM C INTEGER M C LOGICAL MISS C INTEGER N C INTEGER NLABLX, NLABLY, NLU C INTEGER NN, NOUT, NUMCOL, NUMCP2, NUMROW C CHARACTER*1 SYM(30), SYM1(9) C REAL TEMP(50, 2) C REAL TN, TX C REAL X(N) C REAL XDMN, XDMX C THE X-AXIS DATA LIMITS ACTUALLY USED. C REAL XLABEL(20) C THE X-AXIS LABLES. C CHARACTER XLFMT*205, XLFMT2*205 C THE FORMATS USED TO PRINT THE X-AXIS C REAL XMISS, XMN, XMX, XWIDTH, XX C REAL YDMN, YDMX C THE Y-AXIS DATA LIMITS ACTUALLY USED. C REAL YL C REAL YLABEL(20) C THE Y-AXIS LABLES. C REAL YLOWER C REAL YM(IYM, M) C REAL YMMISS(M) C REAL YMN, YMX, YUPPER, YWIDTH, YY C DATA BLANK/' '/,HYPHEN/'-'/,ALPHAI/'I'/,ALPHAX/'X'/ DATA SYM( 1)/'+'/,SYM( 2)/'.'/,SYM( 3)/'*'/,SYM( 4)/'-'/, + SYM( 5)/'A'/,SYM( 6)/'B'/,SYM( 7)/'C'/,SYM( 8)/'D'/, + SYM( 9)/'E'/,SYM(10)/'F'/,SYM(11)/'G'/,SYM(12)/'H'/, + SYM(13)/'I'/,SYM(14)/'J'/,SYM(15)/'K'/,SYM(16)/'L'/, + SYM(17)/'M'/,SYM(18)/'N'/,SYM(19)/'O'/,SYM(20)/'P'/, + SYM(21)/'Q'/,SYM(22)/'R'/,SYM(23)/'S'/,SYM(24)/'T'/, + SYM(25)/'U'/,SYM(26)/'V'/,SYM(27)/'W'/,SYM(28)/'Y'/, + SYM(29)/'Z'/,SYM(30)/'Z'/ DATA SYM1(1)/'1'/,SYM1(2)/'2'/,SYM1(3)/'3'/,SYM1(4)/'4'/, + SYM1(5)/'5'/,SYM1(6)/'6'/,SYM1(7)/'7'/,SYM1(8)/'8'/, + SYM1(9)/'9'/ C CALL IPRINT(IPRT) C C DEFINE THE NUMBER OF ROWS AND COLUMNS WITHIN THE PLOT C CALL PRTCNT(MAX(0,ISIZE),2,ISIZXY) IF (ISIZXY(1).EQ.0) THEN NUMCOL=101 ELSE NUMCOL = 51 END IF IF (ISIZXY(2).EQ.0) THEN NUMROW = 51 ELSE NUMROW = 26 END IF C NUMCP2 = NUMCOL + 2 NN=(NUMROW-1)/5 C C ADJUST FOR LOG PLOTS IF NECESSARY AND FIND AXIS LABELS C CALL PRTCNT (MAX(0,ILOG),2,ILOGXY) ILOGX = ILOGXY(1) ILOGY = ILOGXY(2) CALL LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMROW, 5, DELY, YWIDTH, + NLABLY, YDMN, YDMX) CALL LOGLMT (ILOGX, XMN, XMX, XLABEL, NUMCOL, 10, DELX, XWIDTH, + NLABLX, XDMN, XDMX) C C TEST FOR FORMAT FOR Y AXIS LABELS C ITEST=0 TX=YMX TN=YMN IF (ILOGY.EQ.0) GO TO 190 TX=10.0E0**TX TN=10.0E0**TN 190 IF ((TN .GE. 1.0E6 .OR. TN .LE. (-1.0E5)) .OR. + (ABS(TN).GT.0.0E0.AND.ABS(TN).LT.0.001E0)) ITEST=1 IF ((TX .GE. 1.0E6 .OR. TX .LE. (-1.0E5)) .OR. + (ABS(TX).GT.0.0E0.AND.ABS(TX).LT.0.001E0)) ITEST=1 C C BLANK OUT THE PLOT PRINT LINE CLINE C DO 200 ICOL=1,105 CLINE(ICOL)=BLANK 200 CONTINUE C C WRITE OUT THE TOP HORIZONTAL AXIS OF THE PLOT C DO 210 ICOL=1,NUMCOL CLINE(ICOL)=HYPHEN 210 CONTINUE CLINE(1)=ALPHAI IF (ILOGX.EQ.0) THEN DO 215 ICOL=11,NUMCOL,10 CLINE(ICOL)=ALPHAI 215 CONTINUE ELSE DO 216 IK = NLABLX, 1, -1 ICOL = ((LOG10(XLABEL(IK))-XMN)/XWIDTH)+1.5E0 CLINE(ICOL) = ALPHAI 216 CONTINUE END IF CLINE(NUMCOL+1)=HYPHEN CLINE(NUMCOL+2)=BLANK WRITE (IPRT, 1004) HYPHEN,(CLINE(I),I=1,NUMCOL),HYPHEN DO 217 ICOL=1,105 CLINE(ICOL)=BLANK 217 CONTINUE C C DETERMINE AND WRITE OUT THE PLOT POSITIONS ONE LINE AT A TIME. C L=-1 IK=1 DO 320 IROW=1,NUMROW L=L+1 IF (L.GT.NN) L=1 DO 235 ICOL=1,NUMCOL ALINE(ICOL)=0 KSS(ICOL)=0 235 CONTINUE YUPPER=YMX+(1.5E0-IROW)*YWIDTH YLOWER=YMX+(0.5E0-IROW)*YWIDTH DO 255 I = 1, N C IF (MISS .AND. MVCHK(X(I), XMISS)) GO TO 255 C IF (ILOGX.EQ.0) THEN XX=X(I) ELSE XX=LOG10(X(I)) END IF DO 250 J=1,M C IF (MISS .AND. MVCHK(YM(I,J), YMMISS(J))) GO TO 250 IF (ILOGY.EQ.0) THEN YY=YM(I,J) ELSE YY=LOG10(YM(I,J)) END IF IF (((YLOWER.LE.YY).AND.(YY.LT.YUPPER)) .AND. + ((YY.GE.YDMN).AND.(YY.LE.YDMX))) THEN IF ((XX.GE.XDMN) .AND. (XX.LE.XDMX)) THEN ICOL=((XX-XMN)/XWIDTH)+1.5E0 ALINE(ICOL) = ALINE(ICOL) + 1 C SIMPLE PLOTTING (PLT) KSS(ICOL)=1 C SYMBOL PLOTS (SPLT) IF (ISCHCK .EQ. 1) KSS(ICOL) = ISYM(I) C MULTIPLE PLOTS (MPLT) IF (ISCHCK .EQ. 2) KSS(ICOL) = J + 4 IF (KSS(ICOL).GT.30) KSS(ICOL)=30 IF (KSS(ICOL).LT.1) KSS(ICOL)=1 END IF END IF 250 CONTINUE 255 CONTINUE DO 290 ICOL=1,NUMCOL IF (ALINE(ICOL).EQ.0) THEN CLINE(ICOL)=BLANK ELSE IF (ALINE(ICOL).EQ.1) THEN K=KSS(ICOL) CLINE(ICOL)=SYM(K) ELSE IF (ALINE(ICOL).LE.9) THEN CLINE(ICOL)=SYM1(ALINE(ICOL)) ELSE CLINE(ICOL)=ALPHAX END IF END IF END IF 290 CONTINUE CLINE(NUMCOL+2)=HYPHEN AXISCH=HYPHEN IF (ILOGY.EQ.0) THEN YL = YLABEL(IK) ELSE YL = LOG10(YLABEL(IK)) END IF IF ((YLOWER.GT.YL) .OR. (YL.GE.YUPPER)) THEN C C PRINT LINE WITHOUT LABEL C CLINE(NUMCP2)=ALPHAI WRITE(IPRT, 1008) ALPHAI, (CLINE(ICOL), ICOL=1,NUMCP2) ELSE C C PRINT LINE WITH LABEL C IF (ITEST.EQ.0) THEN WRITE(IPRT,1006) YLABEL(IK),AXISCH, + (CLINE(ICOL),ICOL=1,NUMCP2) ELSE WRITE(IPRT,1007) YLABEL(IK),AXISCH, + (CLINE(ICOL),ICOL=1,NUMCP2) END IF IK=IK+1 END IF 320 CONTINUE C C WRITE OUT THE BOTTOM HORIZONTAL AXIS AND THE X AXIS LABELS. C DO 330 ICOL=1,NUMCOL CLINE(ICOL)=HYPHEN 330 CONTINUE CLINE(1)=ALPHAI IF (ILOGX.EQ.0) THEN NLU = NLABLX+1 DO 340 ICOL=NUMCOL,1,-10 CLINE(ICOL)=ALPHAI NLU = NLU - 1 ISPACE(NLU) = 1 340 CONTINUE ELSE JCOL = 1 CLINE(JCOL) = ALPHAI NLU = NLABLX DO 345 IK = NLABLX, 1, -1 ICOL = ((LOG10(XLABEL(IK))-XMN)/XWIDTH)+1.5 CLINE(ICOL) = ALPHAI IF (ICOL-JCOL.GE.10) THEN ISPACE(NLU) = ICOL-JCOL-9 NLU = NLU - 1 XLABEL(NLU) = XLABEL(IK) JCOL = ICOL END IF 345 CONTINUE END IF CLINE(NUMCOL+1)=HYPHEN CLINE(NUMCOL+2)=BLANK C WRITE(IPRT, 1004) HYPHEN, (CLINE(ICOL), ICOL = 1, NUMCP2) C C CHECK X-AXIS LABELS FOR FORMAT C FMT = 'F9.4' DO 350 I=1,NLABLX IF (((ABS(XLABEL(I)).GT.0.0E0) .AND. (ABS(XLABEL(I)).LT.0.01E0)) + .OR. + ((XLABEL(I).GE.1.0E4) .OR. (XLABEL(I).LE.(-1.0E3)))) THEN FMT = 'E9.4' GO TO 355 END IF 350 CONTINUE 355 CONTINUE WRITE(XLFMT2,1000) NLABLX-NLU WRITE(XLFMT,XLFMT2) (FMT, ISPACE(I), I=NLABLX,NLU+1,-1), FMT WRITE(IPRT, XLFMT) (XLABEL(I),I=NLABLX,NLU,-1) C C DETERMINE VALUES TO BE LISTED IF OUTSIDE OF AXIS LIMITS. C IC = 0 IOUT = MIN(NOUT,50) IF (IOUT.GE.0) THEN DO 180 I = 1, N C IF (MISS .AND. MVCHK(X(I), XMISS)) GO TO 180 C IF (ILOGX.EQ.0) THEN XX = X(I) ELSE XX = LOG10(X(I)) END IF DO 175 J=1,M C IF (MISS .AND. MVCHK(YM(I,J), YMMISS(J))) GO TO 175 C IF (ILOGY.EQ.0) THEN YY = YM(I,J) ELSE YY = LOG10(YM(I,J)) END IF C IF (((YDMN .LE. YY) .AND. (YY .LE. YDMX)) .AND. + ((XDMN .LE. XX) .AND. (XX .LE. XDMX))) GO TO 175 C IC=IC+1 IF (IC.GT.IOUT) GO TO 175 TEMP(IC,1)=X(I) TEMP(IC,2)=YM(I,J) IT=1 IF (ISCHCK.EQ.1) IT=ISYM(I) IF (ISCHCK.EQ.2) IT=J+4 IF (IT.LT.1) IT=1 IF (IT.GT.30) IT=30 ITEMP(IC) = SYM(IT) 175 CONTINUE 180 CONTINUE END IF C C CHECK FOR POINTS OUTSIDE OF GRAPH LIMITS AND LIST IF REQUESTED C THE TOTAL NUMBER OF POINTS TO BE PLOTTED IS N*M C IF (IC.EQ.0) RETURN IF (IOUT .LT. 0) RETURN WRITE (IPRT, 1010) IC IF (IOUT.LE.0) RETURN WRITE (IPRT, 1016) IF (IC.LE.IOUT) GO TO 360 IC=IOUT WRITE(IPRT, 1011) IOUT GO TO 370 360 WRITE(IPRT, 1012) 370 WRITE(IPRT, 1013) (TEMP(I,1), TEMP(I,2), ITEMP(I), I = 1, IC) RETURN C C FORMAT STATEMENTS C 1000 FORMAT ('(''(14X'',', I2, '('', '', A4, '','', I2, ''X''),', + ''', '', A4, '')'')') 1004 FORMAT (' ',16X, A1, 105A1) 1006 FORMAT(4X,F11.4,1X,A1,1X,105A1) 1007 FORMAT (' ', E14.7, 1X, A1, 1X, 105A1) 1008 FORMAT (' ', 15X, A1, 1X, 105A1) 1010 FORMAT(16X,6H**NOTE,I4,43H VALUES FELL OUTSIDE THE SPECIFIED LIMIT +S**) 1011 FORMAT ('1', 15X, 10HTHE FIRST , I3, + 35H VALUES OUTSIDE THE PLOT LIMITS ARE/ 22X, + 33H X Y SYM) 1012 FORMAT ('1', 15X, 38HTHE VALUES OUTSIDE THE PLOT LIMITS ARE/ 22X, + 33H X Y SYM) 1013 FORMAT (15X,2E15.8,9X,A1) 1016 FORMAT (16X, 22HSEE NEXT PAGE FOR LIST) C 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 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 *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 REAL + J(NN,P),R(N) C C LOCAL SCALARS REAL + T INTEGER + I,K,L,NL1 C C EXTERNAL FUNCTIONS REAL + DOTPRD EXTERNAL DOTPRD C C INTRINSIC FUNCTIONS INTRINSIC ABS C C *****PARAMETERS. C INTEGER NN, N, P, IERR C REAL 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 REAL T C/ C *****FUNCTIONS. C EXTERNAL DOTPRD C REAL DOTPRD 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 *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 REAL + ALPHA(N),QR(NM,N),SUM(N) INTEGER + IPIVOT(N) C C LOCAL SCALARS REAL + 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 REAL + 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 REAL QR(NM,N),ALPHA(N),SUM(N) C *****LOCAL VARIABLES. C INTEGER I,J,JBAR,K,K1,MINUM,MK1 C REAL ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL, C 1 RKTOL1,SUMJ C *****FUNCTIONS. C/+ C INTEGER MIN C REAL ABS,SQRT C/ C EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM C REAL 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 REAL ONE, P01, P99, ZERO DATA ONE/1.0E0/, P01/0.01E0/, P99/0.99E0/, ZERO/0.0E0/ 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.0E0/, UFETA/0.0E0/ 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 *R9GMIT REAL FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C COMPUTE TRICOMI-S INCOMPLETE GAMMA FUNCTION FOR SMALL X. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,ALGAP1,ALX,SGNGAM,X C C LOCAL SCALARS REAL AE,AEPS,ALG2,ALGS,BOT,EPS,FK,S,SGNG2,T,TE INTEGER K,M,MA C C EXTERNAL FUNCTIONS REAL ALNGAM,R1MACH EXTERNAL ALNGAM,R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,EXP,FLOAT,LOG,SIGN C DATA EPS, BOT / 2*0.0 / C IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1)) C IF (X.LE.0.0) CALL XERROR ('R9GMIT X SHOULD BE GT 0', 24, 1, 2) C MA = A + 0.5 IF (A.LT.0.0) MA = A - 0.5 AEPS = A - FLOAT(MA) C AE = A IF (A.LT.(-0.5)) AE = AEPS C T = 1.0 TE = AE S = T DO 20 K=1,200 FK = K TE = -X*TE/FK T = TE/(AE+FK) S = S + T IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 20 CONTINUE CALL XERROR ( 'R9GMIT NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SE 1RIES', 54, 2, 2) C 30 IF (A.GE.(-0.5)) THEN ALGS = -ALGAP1 + LOG(S) ELSE C ALGS = -ALNGAM(1.0+AEPS) + LOG(S) S = 1.0 M = -MA - 1 IF (M.EQ.0) GO TO 50 T = 1.0 DO 40 K=1,M T = X*T/(AEPS-FLOAT(M+1-K)) S = S + T IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 40 CONTINUE C 50 R9GMIT = 0.0 ALGS = -FLOAT(MA)*LOG(X) + ALGS IF (S.NE.0.0 .AND. AEPS.NE.0.0) THEN SGNG2 = SGNGAM*SIGN(1.0,S) ALG2 = -X - ALGAP1 + LOG(ABS(S)) C IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2) IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS) RETURN END IF END IF R9GMIT = EXP(ALGS) RETURN C END *R9LGIC REAL FUNCTION R9LGIC (A, X, ALX) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C COMPUTE THE LOG COMPLEMENTARY INCOMPLETE GAMMA FUNCTION FOR LARGE X C AND FOR A .LE. X. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,ALX,X C C LOCAL SCALARS REAL EPS,FK,P,R,S,T,XMA,XPA INTEGER K C C EXTERNAL FUNCTIONS REAL R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG C DATA EPS / 0.0 / C IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) C XPA = X + 1.0 - A XMA = X - 1.0 - A C R = 0.0 P = 1.0 S = P DO 10 K=1,200 FK = K T = FK*(A-FK)*(1.0+R) R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T) P = R*P S = S + P IF (ABS(P).LT.EPS*S) GO TO 20 10 CONTINUE CALL XERROR ( 'R9LGIC NO CONVERGENCE IN 200 TERMS OF CONTINUED F 1RACTION', 57, 1, 2) C 20 R9LGIC = A*ALX - X + LOG(S/XPA) C RETURN END *R9LGIT REAL FUNCTION R9LGIT (A, X, ALGAP1) C JULY 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C COMPUTE THE LOG OF TRICOMI-S INCOMPLETE GAMMA FUNCTION WITH PERRON-S C CONTINUED FRACTION FOR LARGE X AND FOR A .GE. X. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL A,ALGAP1,X C C LOCAL SCALARS REAL A1X,AX,EPS,FK,HSTAR,P,R,S,SQEPS,T INTEGER K C C EXTERNAL FUNCTIONS REAL R1MACH EXTERNAL R1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG,SQRT C DATA EPS, SQEPS / 2*0.0 / C IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3) IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4)) C IF (X.LE.0.0 .OR. A.LT.X) CALL XERROR ( 1 'R9LGIT X SHOULD BE GT 0.0 AND LE A', 35, 2, 2) C AX = A + X A1X = AX + 1.0 R = 0.0 P = 1.0 S = P DO 20 K=1,200 FK = K T = (A+FK)*X*(1.0+R) R = T/((AX+FK)*(A1X+FK)-T) P = R*P S = S + P IF (ABS(P).LT.EPS*S) GO TO 30 20 CONTINUE CALL XERROR ( 'R9LGIT NO CONVERGENCE IN 200 TERMS OF CONTINUED F 1RACTION', 57, 3, 2) C 30 HSTAR = 1.0 - X*S/A1X IF (HSTAR.LT.SQEPS) CALL XERROR ( 1 'R9LGIT RESULT LESS THAN HALF PRECISION', 39, 1, 1) C R9LGIT = -X - ALGAP1 - LOG(HSTAR) C RETURN END *R9LGMC REAL FUNCTION R9LGMC (X) C AUGUST 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. C C COMPUTE THE LOG GAMMA CORRECTION FACTOR FOR X .GE. 10.0 SO THAT C LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL X C C LOCAL SCALARS REAL XBIG,XMAX INTEGER NALGM C C LOCAL ARRAYS REAL ALGMCS(6) C C EXTERNAL FUNCTIONS REAL CSEVL,R1MACH INTEGER INITS EXTERNAL CSEVL,R1MACH,INITS C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC EXP,LOG,MIN,SQRT C C C SERIES FOR ALGM ON THE INTERVAL 0. TO 1.00000D-02 C WITH WEIGHTED ERROR 3.40E-16 C LOG WEIGHTED ERROR 15.47 C SIGNIFICANT FIGURES REQUIRED 14.39 C DECIMAL PLACES REQUIRED 15.86 C DATA ALGMCS( 1) / .1666389480 45186E0 / DATA ALGMCS( 2) / -.0000138494 817606E0 / DATA ALGMCS( 3) / .0000000098 108256E0 / DATA ALGMCS( 4) / -.0000000000 180912E0 / DATA ALGMCS( 5) / .0000000000 000622E0 / DATA ALGMCS( 6) / -.0000000000 000003E0 / C DATA NALGM, XBIG, XMAX / 0, 2*0.0 / C IF (NALGM.NE.0) GO TO 10 NALGM = INITS (ALGMCS, 6, R1MACH(3)) XBIG = 1.0/SQRT(R1MACH(3)) XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) ) C 10 IF (X.LT.10.0) CALL XERROR ('R9LGMC X MUST BE GE 10', 23, 1, 2) IF (X.GE.XMAX) GO TO 20 C R9LGMC = 1.0/(12.0*X) IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X RETURN C 20 R9LGMC = 0.0 CALL XERROR ('R9LGMC X SO BIG R9LGMC UNDERFLOWS', 34, 2, 1) RETURN C END *RANDN REAL FUNCTION RANDN(JD) C***BEGIN PROLOGUE RANDN (ORIGINALLY RNOR) C***DATE WRITTEN 810915 C***REVISION DATE 900315 C***CATEGORY NO. L6A14 C***KEYWORDS RANDOM NUMBERS, UNIFORM RANDOM NUMBERS C***AUTHOR KAHANER, DAVID C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST C C MARSAGLIA, GEORGE C COMPUTER SCIENCE DEPT., WASH STATE UNIV C C MODIFIED BY - C DONALDSON, JANET C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST C C***PURPOSE GENERATES QUASI NORMAL RANDOM NUMBERS, WITH MEAN ZERO AND C UNIT STANDARD DEVIATION, AND CAN BE USED WITH ANY COMPUTER C WITH INTEGERS AT LEAST AS LARGE AS 32767. C***DESCRIPTION C C RANDN GENERATES QUASI NORMAL RANDOM NUMBERS WITH ZERO MEAN AND C UNIT STANDARD DEVIATION. C IT CAN BE USED WITH ANY COMPUTER WITH INTEGERS AT LEAST AS C LARGE AS 32767. C C C USE C FIRST TIME.... C Z = RANDN(JD) C HERE JD IS ANY N O N - Z E R O INTEGER. C THIS CAUSES INITIALIZATION OF THE PROGRAM C AND THE FIRST RANDOM NUMBER TO BE RETURNED AS Z. C SUBSEQUENT TIMES... C Z = RANDN(0) C CAUSES THE NEXT RANDOM NUMBER TO BE RETURNED AS Z. C C======================================================================= C C NOTE: USERS WHO WISH TO TRANSPORT THIS PROGRAM TO OTHER C COMPUTERS SHOULD READ THE FOLLOWING .... C C MACHINE DEPENDENCIES... C MDIG = A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE C FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT. C THIS MUST BE AT LEAST 16, BUT CAN BE INCREASED IN C LINE WITH REMARK A BELOW. C C REMARKS... C A. THIS PROGRAM CAN BE USED IN TWO WAYS: C (1) TO OBTAIN REPEATABLE RESULTS ON DIFFERENT COMPUTERS, C SET 'MDIG' TO THE SMALLEST OF ITS VALUES ON EACH, OR, C (2) TO ALLOW THE LONGEST SEQUENCE OF RANDOM NUMBERS TO BE C GENERATED WITHOUT CYCLING (REPEATING) SET 'MDIG' TO THE C LARGEST POSSIBLE VALUE. C B. THE SEQUENCE OF NUMBERS GENERATED DEPENDS ON THE INITIAL C INPUT 'JD' AS WELL AS THE VALUE OF 'MDIG'. C IF MDIG=16 ONE SHOULD FIND THAT C THE FIRST EVALUATION C Z=RANDN(87) GIVES Z=-.40079207... C THE SECOND EVALUATION C Z=RANDN(0) GIVES Z=-1.8728870... C THE THIRD EVALUATION C Z=RANDN(0) GIVES Z=1.8216004... C THE FOURTH EVALUATION C Z=RANDN(0) GIVES Z=.69410355... C THE THOUSANDTH EVALUATION C Z=RANDN(0) GIVES Z=.96782424... C C***REFERENCES MARSAGLIA & TSANG, "A FAST, EASILY IMPLEMENTED C METHOD FOR SAMPLING FROM DECREASING OR C SYMMETRIC UNIMODAL DENSITY FUNCTIONS", TO BE C PUBLISHED IN SIAM J SISC 1983. C***ROUTINES CALLED I1MACH,XERROR C***END PROLOGUE RANDN C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + JD C C LOCAL SCALARS REAL + AA,B,C,C1,C2,ONE,P5,PC,RMAX,S,X,XN,Y INTEGER + I,I1,J,J0,J1,JSEED,K0,K1,M1,M2,MDIG C C LOCAL ARRAYS REAL + V(65),W(65) INTEGER + M(17) C C EXTERNAL FUNCTIONS REAL + RANDU INTEGER + I1MACH EXTERNAL RANDU,I1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,EXP,LOG,MIN,MOD,REAL,SIGN C C SAVE STATEMENT SAVE I1,J1,M,M1,M2,RMAX C DATA AA,B,C,RMAX/12.37586E0,0.4878992E0,12.67706E0,3.0518509E-5/ DATA C1,C2,PC,XN/0.9689279E0,1.301198E0,0.1958303E-1,2.776994E0/ DATA (V(I),I=1,15)/0.3409450E0,0.4573146E0,0.5397793E0, + 0.6062427E0,0.6631691E0,0.7136975E0,0.7596125E0,0.8020356E0, + 0.8417227E0,0.8792102E0,0.9148948E0,0.9490791E0,0.9820005E0, + 1.0138492E0,1.0447810E0/ DATA (V(I),I=16,30)/1.0749254E0,1.1043917E0,1.1332738E0, + 1.1616530E0,1.1896010E0,1.2171815E0,1.2444516E0,1.2714635E0, + 1.2982650E0,1.3249008E0,1.3514125E0,1.3778399E0,1.4042211E0, + 1.4305929E0,1.4569915E0/ DATA (V(I),I=31,45)/1.4834526E0,1.5100121E0,1.5367061E0, + 1.5635712E0,1.5906454E0,1.6179680E0,1.6455802E0,1.6735255E0, + 1.7018503E0,1.7306045E0,1.7598422E0,1.7896223E0,1.8200099E0, + 1.8510770E0,1.8829044E0/ DATA (V(I),I=46,60)/1.9155830E0,1.9492166E0,1.9839239E0, + 2.0198430E0,2.0571356E0,2.0959930E0,2.1366450E0,2.1793713E0, + 2.2245175E0,2.2725185E0,2.3239338E0,2.3795007E0,2.4402218E0, + 2.5075117E0,2.5834658E0/ DATA (V(I),I=61,65)/2.6713916E0,2.7769943E0,2.7769943E0, + 2.7769943E0,2.7769943/ DATA (W(I),I=1,20)/0.10405134E-04,0.13956560E-04,0.16473259E-04, + 0.18501623E-04,0.20238931E-04,0.21780983E-04,0.23182241E-04, + 0.24476931E-04,0.25688121E-04,0.26832186E-04,0.27921226E-04, + 0.28964480E-04,0.29969191E-04,0.30941168E-04,0.31885160E-04, + 0.32805121E-04,0.33704388E-04,0.34585827E-04,0.35451919E-04, + 0.36304851E-04/ DATA (W(I),I=21,40)/0.37146564E-04,0.37978808E-04,0.38803170E-04, + 0.39621114E-04,0.40433997E-04,0.41243096E-04,0.42049621E-04, + 0.42854734E-04,0.43659562E-04,0.44465208E-04,0.45272764E-04, + 0.46083321E-04,0.46897980E-04,0.47717864E-04,0.48544128E-04, + 0.49377973E-04,0.50220656E-04,0.51073504E-04,0.51937936E-04, + 0.52815471E-04/ DATA (W(I),I=41,60)/0.53707761E-04,0.54616606E-04,0.55543990E-04, + 0.56492112E-04,0.57463436E-04,0.58460740E-04,0.59487185E-04, + 0.60546402E-04,0.61642600E-04,0.62780711E-04,0.63966581E-04, + 0.65207221E-04,0.66511165E-04,0.67888959E-04,0.69353880E-04, + 0.70922996E-04,0.72618816E-04,0.74471933E-04,0.76525519E-04, + 0.78843526E-04/ DATA (W(I),I=61,65)/0.81526890E-04,0.84749727E-04,0.84749727E-04, + 0.84749727E-04,0.84749727E-04/ DATA M(1),M(2),M(3),M(4),M(5),M(6),M(7),M(8),M(9),M(10),M(11), + M(12),M(13),M(14),M(15),M(16),M(17)/30788,23052,2053,19346, + 10646,19427,23975,19049,10949,19693,29746,26748,2796,23890, + 29168,31924,16499/ DATA M1,M2,I1,J1/32767,256,5,17/ DATA P5,ONE/0.5E0,1.0E0/ C C FAST PART... C C C***FIRST EXECUTABLE STATEMENT RANDN IF (JD.NE.0) THEN C FILL MDIG = I1MACH(8) + 1 C C MODIFICATION SO SAME NUMBERS WILL BE GENERATED ON ALL MACHINES C WITH I1MACH(8) AT LEAST 31 C MDIG = MIN(MDIG,32) C C BE SURE THAT MDIG AT LEAST 16... IF (MDIG.LT.16) CALL XERROR('RANDN--MDIG LESS THAN 16',23,1,2) C M1 = 2** (MDIG-2) + (2** (MDIG-2)-1) M2 = 2** (MDIG/2) JSEED = MIN(ABS(JD),M1) IF (MOD(JSEED,2).EQ.0) JSEED = JSEED - 1 K0 = MOD(9069,M2) K1 = 9069/M2 J0 = MOD(JSEED,M2) J1 = JSEED/M2 DO 10 I = 1,17 JSEED = J0*K0 J1 = MOD(JSEED/M2+J0*K1+J1*K0,M2/2) J0 = MOD(JSEED,M2) M(I) = J0 + M2*J1 10 CONTINUE J1 = 17 I1 = 5 RMAX = ONE/REAL(M1) C SEED UNIFORM (0,1] GENERATOR. (JUST A DUMMY CALL) RANDN = RANDU(JD) DO 20 I = 1,65 W(I) = RMAX*V(I) 20 CONTINUE END IF I = M(I1) - M(J1) IF (I.LT.0) I = I + M1 M(J1) = I I1 = I1 - 1 IF (I1.EQ.0) I1 = 17 J1 = J1 - 1 IF (J1.EQ.0) J1 = 17 J = MOD(I,64) + 1 RANDN = I*W(J+1) IF (((I/M2)/2)*2.EQ. (I/M2)) RANDN = -RANDN IF (ABS(RANDN).GT.V(J)) THEN C SLOW PART; AA IS A*F(0) X = (ABS(RANDN)-V(J))/ (V(J+1)-V(J)) Y = RANDU(0) S = X + Y IF (S.LE.C2) THEN IF (S.LE.C1) THEN RETURN ELSE IF (Y.LE.C-AA*EXP(-P5 * (B-B*X)**2)) THEN IF (EXP(-P5*V(J+1)**2)+Y*PC/V(J+1).GT. + EXP(-P5*RANDN**2)) THEN 30 CONTINUE C TAIL PART; 3.855849 IS .5*XN**2 S = XN - LOG(RANDU(0))/XN IF (3.855849E0+LOG(RANDU(0))-XN*S.GT. + -P5*S**2) GO TO 30 RANDN = SIGN(S,RANDN) END IF RETURN ELSE END IF END IF RANDN = SIGN(B-B*X,RANDN) END IF END *RANDU REAL FUNCTION RANDU(JD) C***BEGIN PROLOGUE RANDU (ORIGINALLY UNI) C***DATE WRITTEN 810915 C***REVISION DATE 900315 C***CATEGORY NO. L6A21 C***KEYWORDS RANDOM NUMBERS, UNIFORM RANDOM NUMBERS C***AUTHOR BLUE, JAMES C KAHANER, DAVID C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST C C MARSAGLIA, GEORGE C COMPUTER SCIENCE DEPT., WASH STATE UNIV C C MODIFIED BY - C DONALDSON, JANET C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISTION, NIST C C***PURPOSE THIS ROUTINE GENERATES QUASI UNIFORM RANDOM NUMBERS ON C (0,1] AND CAN BE USED ON ANY COMPUTER WITH WHICH ALLOWS C INTEGERS AT LEAST AS LARGE AS 32767. C***DESCRIPTION C C THIS ROUTINE GENERATES QUASI UNIFORM RANDOM NUMBERS ON THE C INTERVAL (0,1]. IT CAN BE USED WITH ANY COMPUTER WHICH ALLOWS C INTEGERS AT LEAST AS LARGE AS 32767. C C C USE C FIRST TIME.... C Z = RANDU(JD) C HERE JD IS ANY N O N - Z E R O INTEGER. C THIS CAUSES INITIALIZATION OF THE PROGRAM C AND THE FIRST RANDOM NUMBER TO BE RETURNED AS Z. C SUBSEQUENT TIMES... C Z = RANDU(0) C CAUSES THE NEXT RANDOM NUMBER TO BE RETURNED AS Z. C C C=================================================================== C NOTE: USERS WHO WISH TO TRANSPORT THIS PROGRAM FROM ONE COMPUTER C TO ANOTHER SHOULD READ THE FOLLOWING INFORMATION: C C MACHINE DEPENDENCIES... C MDIG = A LOWER BOUND ON THE NUMBER OF BINARY DIGITS AVAILABLE C FOR REPRESENTING INTEGERS, INCLUDING THE SIGN BIT. C THIS VALUE MUST BE AT LEAST 16, BUT MAY BE INCREASED C IN LINE WITH REMARK A BELOW. C C REMARKS... C A. THIS PROGRAM CAN BE USED IN TWO WAYS: C (1) TO OBTAIN REPEATABLE RESULTS ON DIFFERENT COMPUTERS, C SET 'MDIG' TO THE SMALLEST OF ITS VALUES ON EACH, OR, C (2) TO ALLOW THE LONGEST SEQUENCE OF RANDOM NUMBERS TO BE C GENERATED WITHOUT CYCLING (REPEATING) SET 'MDIG' TO THE C LARGEST POSSIBLE VALUE. C B. THE SEQUENCE OF NUMBERS GENERATED DEPENDS ON THE INITIAL C INPUT 'JD' AS WELL AS THE VALUE OF 'MDIG'. C IF MDIG=16 ONE SHOULD FIND THAT C THE FIRST EVALUATION C Z=RANDU(305) GIVES Z=.027832881... C THE SECOND EVALUATION C Z=RANDU(0) GIVES Z=.56102176... C THE THIRD EVALUATION C Z=RANDU(0) GIVES Z=.41456343... C THE THOUSANDTH EVALUATION C Z=RANDU(0) GIVES Z=.19797357... C C***REFERENCES MARSAGLIA G., "COMMENTS ON THE PERFECT UNIFORM RANDOM C NUMBER GENERATOR", UNPUBLISHED NOTES, WASH S. U. C***ROUTINES CALLED I1MACH,XERROR C***END PROLOGUE RANDU C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + JD C C LOCAL SCALARS REAL + ONE,ZERO INTEGER + I,J,J0,J1,JSEED,K,K0,K1,M1,M2,MDIG C C LOCAL ARRAYS INTEGER + M(17) C C EXTERNAL FUNCTIONS INTEGER + I1MACH EXTERNAL I1MACH C C EXTERNAL SUBROUTINES EXTERNAL XERROR C C INTRINSIC FUNCTIONS INTRINSIC ABS,MIN,MOD,REAL C C SAVE STATEMENT SAVE I,J,M,M1,M2 C C DATA M(1),M(2),M(3),M(4),M(5),M(6),M(7),M(8),M(9),M(10),M(11), + M(12),M(13),M(14),M(15),M(16),M(17)/30788,23052,2053,19346, + 10646,19427,23975,19049,10949,19693,29746,26748,2796,23890, + 29168,31924,16499/ DATA M1,M2,I,J/32767,256,5,17/ DATA ZERO,ONE /0.0E0,1.0E0/ C C***FIRST EXECUTABLE STATEMENT RANDU IF (JD.NE.0) THEN C FILL MDIG = I1MACH(8) + 1 C C MODIFICATION SO SAME NUMBERS WILL BE GENERATED ON ALL MACHINES C WITH I1MACH(8) AT LEAST 31 C MDIG = MIN(MDIG,32) C C BE SURE THAT MDIG AT LEAST 16... IF (MDIG.LT.16) CALL XERROR('RANDU--MDIG LESS THAN 16',22,1,2) M1 = 2** (MDIG-2) + (2** (MDIG-2)-1) M2 = 2** (MDIG/2) JSEED = MIN(ABS(JD),M1) IF (MOD(JSEED,2).EQ.0) JSEED = JSEED - 1 K0 = MOD(9069,M2) K1 = 9069/M2 J0 = MOD(JSEED,M2) J1 = JSEED/M2 DO 10 I = 1,17 JSEED = J0*K0 J1 = MOD(JSEED/M2+J0*K1+J1*K0,M2/2) J0 = MOD(JSEED,M2) M(I) = J0 + M2*J1 10 CONTINUE I = 5 J = 17 END IF C BEGIN MAIN LOOP HERE K = M(I) - M(J) IF (K.LT.0) K = K + M1 M(J) = K I = I - 1 IF (I.EQ.0) I = 17 J = J - 1 IF (J.EQ.0) J = 17 RANDU = REAL(K)/REAL(M1) C C MODIFICATION SO RANDOM NUMBERS IN (0,1] RATHER THAN [0,1) C IF (RANDU.EQ.ZERO) RANDU = ONE END *RANKO SUBROUTINE RANKO(N, Y, H, R, T) C C LATEST REVISION - 03/15/90 (JRD) C C VERSION 45.0 RANKO 3/ 6/70 C ***** C PUTS RANK OF N X"S IN VECTOR R. VECTOR H IS USED FOR STORAGE. C X,H AND R MUST BE DIMENSIONED N OR GREATER. C STORES CORRECTION FOR TIES IN T = SUM(T-1)*T*(T+1). C N.B. T IS 12 TIMES VALUE COMPUTED BY ORIGINAL OMNITAB ROUTINE. C T=0 MEANS NO TIES. C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/9/69. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + T INTEGER + N C C ARRAY ARGUMENTS REAL + R(N),Y(N) INTEGER + H(N) C C LOCAL SCALARS INTEGER + I,IJ,J,K,K2 C C EXTERNAL SUBROUTINES EXTERNAL SRTIR,SRTRI C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER H(N) C THE INDICES TO THE HIERARCHY OF R C INTEGER I C INDEX VARIABLE C INTEGER IJ C INDEX VARIABLE BASED ON I-J C INTEGER J C INDEX VARIABLE C INTEGER K C INDEX VARIABLE C INTEGER K2 C INDEX VARIABLE C INTEGER N C NUMBER OF OBSERVATIONS C REAL R(N) C FINAL VECTOR CONTAINING RANK C REAL T C 12 TIMES THE OMNITAB CORRECTION FOR TIES C T = SUM(T-1)*T*(T+1) C T = 0 MEANS NO TIES C REAL Y(N) C VECTOR TO BE RANKED C C C MOVE Y TO R AND PUT I IN H C DO 10 I=1,N H(I) = I R(I) = Y(I) 10 CONTINUE C C SORT Y IN R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H. C CALL SRTIR(H, N, R) C C REPLACE R(I) BY I*. C LET K BE SUCH THAT R(I)=R(I-J+1),J=1,K. THEN I* = I-(K-1)/2. C K = 1 T = 0 DO 40 I=2,N IF (R(I).EQ.R(I-1)) THEN K = K + 1 ELSE DO 30 J=1,K IJ = I - J R(IJ) = (I-1) - (K-1)/2.0E0 30 CONTINUE T = T + (K-1)*K*(K+1) K = 1 END IF 40 CONTINUE T = T + (K-1)*K*(K+1) DO 50 I=1,K K2 = N + 1 - I R(K2) = N - (K-1)/2.0E0 50 CONTINUE C C SORT H CARRY ALONG R TO OBTAIN RANKS IN R C CALL SRTRI(R, N, H) RETURN END *REALTR SUBROUTINE REALTR(A, B, N, ISN) C IF ISN=1, THIS SUBROUTINE COMPLETES THE FOURIER TRANSFORM C OF 2*N DATA VALUES, WHERE THE ORIGINAL DATA VALUES ARE C STORED ALTERNATELY IN ARRAYS A AND B, AND ARE FIRST C TRANSFORMED BY A COMPLEX FOURIER TRANSFORM OF DIMENSION N. C THE COSINE COEFFICIENTS ARE IN A(1),A(2),...A(N+1) AND C THE SINE COEFFICIENTS ARE IN B(1),B(2),...B(N+1). C A TYPICAL CALLING SEQUENCE IS C CALL FFT(A,B,N,N,N,1) C CALL REALTR(A,B,N,1) C THE RESULTS SHOULD BE MULTIPLIED BY 0.5E0/N TO GIVE THE C USUAL SCALING OF COEFFICIENTS. C IFISN-1, THE INVERSE TRANSFORMATION IS DONE, THE FIRST STEP C IN EVALUATING A REAL FOURIER SERIES. C A TYPICAL CALLING SEQUENCE IS C CALL REALTRA(A,B,N,-1) C CALL FFT(A,B,N,N,N,-1) C THE RESULTS SHOULD BE MULTIPLIED BY 0.5E0 TO GIVE THE USUAL C SCALING, AND THE TIME DOMAIN RESULTS ALTERNATE IN ARRAYS A C AND B, I.E. A(1),B(1),A(2),B(2),...A(N),B(N). C THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX C ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO C GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO C PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY C VALUES, E.G. C CALL FFT(A,A(2),N,N,N,2) C CALL REALTR(A,A(2),N,2) C IN THIS CASE, THE COSINE AND SINE COEFFICIENTS ALTERNATE IN A. C BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ISN,N C C ARRAY ARGUMENTS REAL + A(1),B(1) C C LOCAL SCALARS REAL + AA,AB,BA,BB,CD,CN,IM,RE,SD,SN INTEGER + INC,J,K,NH,NK C C INTRINSIC FUNCTIONS INTRINSIC ATAN,IABS,SIN C C C INC = IABS(ISN) NK = N*INC + 2 NH = NK/2 SD = 2.0E0*ATAN(1.0E0)/N CD = 2.0E0*SIN(SD)**2 SD = SIN(SD+SD) SN = 0.0E0 IF (ISN.LT.0) GO TO 30 CN = 1.0E0 A(NK-1) = A(1) B(NK-1) = B(1) 10 DO 20 J=1,NH,INC K = NK - J AA = A(J) + A(K) AB = A(J) - A(K) BA = B(J) + B(K) BB = B(J) - B(K) RE = CN*BA + SN*AB IM = SN*BA - CN*AB B(K) = IM - BB B(J) = IM + BB A(K) = AA - RE A(J) = AA + RE AA = CN - (CD*CN+SD*SN) SN = (SD*CN-CD*SN) + SN CN = 0.5E0/(AA**2+SN**2) + 0.5E0 SN = CN*SN CN = CN*AA 20 CONTINUE RETURN 30 CN = -1.0E0 SD = -SD GO TO 10 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 REAL + ABSTOL,RELTOL INTEGER + N,NFAIL C C ARRAY ARGUMENTS REAL + 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 REAL 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 REAL RELTOL C THE RELATIVE TOLERANCE USED IN THE COMPARISON. C REAL V(N), W(N) C THE VALUES BEING COMPARED. 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.0E0).OR.(W(I).EQ.0.0E0)).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 *RELDST REAL 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 REAL + D(P),X(P),X0(P) C C LOCAL SCALARS REAL + EMAX,T,XMAX,ZERO INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC ABS C DATA ZERO/0.0E0/ 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 *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 REAL + D(NRESTS*NPAR) C C LOCAL SCALARS INTEGER + I,I1,I2,J 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 *RMDCON REAL 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 REAL + BIG,ETA,MACHEP,ONE001,PT999 C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH C C INTRINSIC FUNCTIONS INTRINSIC SQRT 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 C DATA ONE001/1.001E0/, PT999/0.999E0/ C BIG = R1MACH(2) ETA = R1MACH(1) MACHEP = R1MACH(4) C C------------------------------- BODY -------------------------------- C GO TO (10, 20, 30, 40, 50, 60), K C 10 RMDCON = ETA GO TO 999 C 20 RMDCON = SQRT(ONE001*ETA) GO TO 999 C 30 RMDCON = MACHEP GO TO 999 C 40 RMDCON = SQRT(PT999*MACHEP) GO TO 999 C 50 RMDCON = SQRT(PT999*BIG) GO TO 999 C 60 RMDCON = BIG C 999 RETURN C *** LAST CARD OF RMDCON FOLLOWS *** 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 REAL + J(NN,P),RD(P),X(P),Y(P),Z(P) INTEGER + IPIVOT(P) C C LOCAL SCALARS REAL + ZK INTEGER + I,IM1,K,KM1 C C EXTERNAL FUNCTIONS REAL + DOTPRD EXTERNAL DOTPRD 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 *S88FMT SUBROUTINE S88FMT( N, W, IFMT ) C C LATEST REVISION - OCTOBER 3, 1983 (JRD) C C S88FMT REPLACES IFMT(1), ... , IFMT(N) WITH C THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT C DIGITS OF W. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER N,W C C ARRAY ARGUMENTS CHARACTER IFMT(N)*4 C C LOCAL SCALARS INTEGER IDIGIT,NT,WT C C LOCAL ARRAYS CHARACTER DIGITS(10)*4 C C INTRINSIC FUNCTIONS INTRINSIC MOD C C DATA DIGITS( 1) / '0' / DATA DIGITS( 2) / '1' / DATA DIGITS( 3) / '2' / DATA DIGITS( 4) / '3' / DATA DIGITS( 5) / '4' / DATA DIGITS( 6) / '5' / DATA DIGITS( 7) / '6' / DATA DIGITS( 8) / '7' / DATA DIGITS( 9) / '8' / DATA DIGITS(10) / '9' / C NT = N WT = W C 10 IF (NT .LE. 0) RETURN IDIGIT = MOD( WT, 10 ) IFMT(NT) = DIGITS(IDIGIT+1) WT = WT/10 NT = NT - 1 GO TO 10 C END *SAMPLE SUBROUTINE SAMPLE (Y, N, NS, YS, NYS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE SAMPLES EVERY KTH OBSERVATION FROM THE INPUT C SERIES Y, STORING THE SAMPLED SERIES IN YS. 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 + N,NS,NYS C C ARRAY ARGUMENTS REAL + Y(*),YS(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,ERR02,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,LNS(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,IPRINT,SMPLY C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02 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 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 CHARACTER*1 LN(8), LNS(8), LONE(8) C THE ARRAY CONTAINING THE NAME OF THE VARIABLE N AND NS. 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 NS C THE SAMPLING RATE. C INTEGER NYS C THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YS(N) C THE VECTOR IN WHICH THE SAMPLED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'A', 'M', 'P', 'L', 'E'/ DATA + LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) + / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LNS(1), LNS(2), LNS(3), LNS(4), LNS(5), LNS(6), LNS(7), LNS(8) + / 'N', 'S', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7), + LONE(8) + / 'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ 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 EISII(NMSUB, LNS, NS, 1, N, 1, HEAD, ERR02, LONE, LN) C IF (ERR01 .OR. ERR02) GO TO 10 GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C CALL SMPLY (Y, N, NS, YS, NYS) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 38H CALL SAMPLE (Y, N, NS, YS, NYS)) END *SETERR SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT) C C SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS C ACCORDING TO THE FOLLOWING RULES... C C IF IOPT = 1 AND RECOVERING - JUST REMEMBER THE ERROR. C IF IOPT = 1 AND NOT RECOVERING - PRINT AND STOP. C IF IOPT = 2 - PRINT, DUMP AND STOP. C C INPUT C C MESSG - THE ERROR MESSAGE. C NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS. C NERR - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO. C IOPT - THE OPTION. MUST HAVE IOPT=1 OR 2. C C ERROR STATES - C C 1 - MESSAGE LENGTH NOT POSITIVE. C 2 - CANNOT HAVE NERR=0. C 3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR. C 4 - BAD VALUE FOR IOPT. C C ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED. C C THE ERROR HANDLER CALLS A SUBROUTINE NAMED FDUMP TO PRODUCE A C SYMBOLIC DUMP. TO COMPLETE THE PACKAGE, A DUMMY VERSION OF FDUMP C IS SUPPLIED, BUT IT SHOULD BE REPLACED BY A LOCALLY WRITTEN VERSION C WHICH AT LEAST GIVES A TRACE-BACK. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER IOPT,NERR,NMESSG C C ARRAY ARGUMENTS CHARACTER MESSG(NMESSG)*4 C C LOCAL SCALARS INTEGER ITEMP,IWUNIT,NW C C EXTERNAL FUNCTIONS INTEGER I1MACH,I8SAVE EXTERNAL I1MACH,I8SAVE C C EXTERNAL SUBROUTINES EXTERNAL E9RINT,EPRINT,FDUMP C C INTRINSIC FUNCTIONS INTRINSIC MIN C C C THE UNIT FOR ERROR MESSAGES. C IWUNIT=I1MACH(4) C IF (NMESSG.GE.1) GO TO 10 C C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. C WRITE(IWUNIT,9000) 9000 FORMAT('1ERROR 1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.') GO TO 60 C C NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES. C 10 NW=(MIN(NMESSG,72)-1)/I1MACH(6)+1 C IF (NERR.NE.0) GO TO 20 C C CANNOT TURN THE ERROR STATE OFF USING SETERR. C WRITE(IWUNIT,9001) 9001 FORMAT('1ERROR 2 IN SETERR - CANNOT HAVE NERR=0'// 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) CALL E9RINT(MESSG,NW,NERR,.TRUE.) ITEMP=I8SAVE(1,1,.TRUE.) GO TO 50 C C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. C 20 IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30 C WRITE(IWUNIT,9002) 9002 FORMAT('1ERROR 3 IN SETERR -', 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) CALL EPRINT CALL E9RINT(MESSG,NW,NERR,.TRUE.) GO TO 50 C C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. C 30 CALL E9RINT(MESSG,NW,NERR,.TRUE.) C IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 C C MUST HAVE IOPT = 1 OR 2. C WRITE(IWUNIT,9003) 9003 FORMAT('1ERROR 4 IN SETERR - BAD VALUE FOR IOPT'// 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) GO TO 50 C C TEST FOR RECOVERY. C 40 IF (IOPT.EQ.2) GO TO 50 C IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN C CALL EPRINT STOP C 50 CALL EPRINT 60 CALL FDUMP STOP C END *SETESL SUBROUTINE SETESL(N, NDIV, NFFT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE SMALLEST VALUE OF NFFT WHICH C EQUALS OR EXCEEDS N + 2, SUCH THAT NFFT - 2 IS C 1. DIVISIBLE BY NDIV, C 2. HAS NO MORE THAN 11 PRIME FACTORS, C 3. HAS NO PRIME FACTOR GREATER THAN 23, AND C 4. THE PRODUCT OF THE SQUARE FREE PRIME FACTORS OF C (NFFT-2)/NDIV DO NOT EXCEED 210 IF NDIV = 2, AND C 105 IF NDIV = 4. C THE VALUE OF NFFT THUS MEET THE REQUIREMENTS OF C THE EXTENDED LENGTH OF THE SERIES REQUIRED FOR ANY ROUTINE C USING THE SINGLETON FFT PROVIDING THE PROPER VALUE OF NDIV C IS CHOSEN. C C WRITTEN BY - JANET R. DONALDSON 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 + N,NDIV,NFFT C C LOCAL SCALARS INTEGER + I,NPF,NSFP C C LOCAL ARRAYS INTEGER + IPF(50),IPFEXP(50) C C EXTERNAL SUBROUTINES EXTERNAL FACTOR C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER IPF(50), IPFEXP(50) C THE VECTORS OF PRIME FACTORS OF NFFT AND THEIR EXPONENTS, C RESPECTIVELY, WHERE THE LENGTH OF THESE VECTORS IS C SUFFICIENT TO ACCOMODATE THE PRIME FACTORS OF AN INTEGER C UP TO 2 ** 128 (APPROXIMATELY 10 ** 40). C INTEGER N C THE NUMBER UPON WHICH NFFT IS BASED. C INTEGER NDIV C A REQUIRED FACTOR OF NFFT - 2. C INTEGER NFFT C THE RETURNED VALUE WHICH MEETS THE ABOVE DESCRIPTION. C INTEGER NPF C THE NUMBER OF PRIME FACTORS IN NFFT. C INTEGER NSFP C THE PRODUCT OF THE NON SQUARE FACTORS. C NFFT = N IF (NFFT.LE.0) RETURN IF (MOD(NFFT, NDIV) .NE. 0) NFFT = NFFT + NDIV - MOD(NFFT, NDIV) NFFT = NFFT - NDIV 20 NFFT = NFFT + NDIV CALL FACTOR(NFFT/NDIV, NPF, IPF, IPFEXP) IF ((NPF.GE.11) .OR. (IPF(NPF).GT.23)) GO TO 20 NSFP = 1 IF (NDIV.EQ.4) NSFP = 2 DO 30 I = 1, NPF IF (MOD(IPFEXP(I), 2).EQ.1) NSFP = NSFP * IPF(I) 30 CONTINUE IF (NSFP .GE. 210) GO TO 20 C NFFT = NFFT + 2 C RETURN C END *SETFRQ SUBROUTINE SETFRQ (FREQ, NF, NPRT, FMIN, FMAX, H) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE FREQUENCIES AT WHICH THE C SPECTRUM IS TO BE ESTIMATED. 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 REAL + FMAX,FMIN,H INTEGER + NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(NF) C C LOCAL SCALARS REAL + DELTAF INTEGER + I C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELTAF C THE FREQUENCY INCREMENT. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCIES AT WHICH THE C SPECTRUM IS TO BE ESTIMATED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL H C THE SAMPLING INTERVAL. C INTEGER I C AN INDEXING VARIABLE. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT EQUALS 2 THE FREQUENCY SCALE IS LINEAR, AND IF C NPRT EQUALS 3 THE FREQUENCY SCALE IS LOG. C IF (NPRT .EQ. 3) GO TO 20 C C COMPUTE FREQUENCY VALUES FOR LINEAR SCALE C FREQ(1) = FMIN C IF (NF .EQ. 1) RETURN C DELTAF = (FMAX - FMIN) / (H * (NF - 1)) DO 10 I = 2, NF FREQ(I) = FREQ(I-1) + DELTAF 10 CONTINUE C FREQ(NF) = FMAX RETURN C 20 CONTINUE C C COMPUTE FREQUENCY VALUES FOR LOG SCALE C DELTAF = (LOG10(FMAX) - LOG10(FMIN)) / (H * (NF - 1)) C FREQ(1) = FMIN C IF (NF .EQ. 1) RETURN C DO 30 I = 2, NF FREQ(I) = 10.0E0**(LOG10(FREQ(I-1)) + DELTAF) 30 CONTINUE C FREQ(NF) = FMAX C C RETURN 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 DO 10 I=1,N VECTOR(I) = VALUE 10 CONTINUE C RETURN C END *SETLAG SUBROUTINE SETLAG (N, LAGMAX) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE NUMBER OF AUTOCORRELATIONS TO BE C COMPUTED. 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 + LAGMAX,N C C INTRINSIC FUNCTIONS INTRINSIC MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER LAGMAX C THE NUMBER OF LAGS AT WHICH THE AUTOCOVARIANCES ARE TO BE C COMPUTED. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C IF (N .GE. 96) LAGMAX = MIN(N / 3, 100) IF (33 .LE. N .AND. N .LE. 95) LAGMAX = 32 IF (N .LE. 32) LAGMAX = N - 1 RETURN END *SETRA SUBROUTINE SETRA(ARRAY, IM, M, N, VALUE) C C LATEST REVISION - 03/15/90 (JRD) C C SETS THE FIRST N ROWS AND M COLUMNS OF THE ARRAY 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 REAL + VALUE INTEGER + IM,M,N C C ARRAY ARGUMENTS REAL + ARRAY(IM,M) C C LOCAL SCALARS INTEGER + I,J C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ARRAY(IM,M) C ARRAY FOR WHICH ELEMENTS WILL BE SET C INTEGER I C * C INTEGER IM C ACTUAL FIRST DIMENSION OF ARRAY IN CALLING PROGRAM C INTEGER J C * C INTEGER M C NUMBER OF COLUMNS TO SET C INTEGER N C NUMBER OF ROWS TO SET C REAL VALUE C VALUE TO WHICH THE ELEMENTS ARE TO BE SET C C DO 20 I=1,N DO 10 J=1,M ARRAY(I,J) = VALUE 10 CONTINUE 20 CONTINUE RETURN 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 REAL + 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 REAL XM(IXM,M) C THE INDEPENDENT VARIABLE MATRIX. 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.0E0) GO TO 20 10 CONTINUE NROWU = I RETURN 20 CONTINUE C NROWU = 1 C RETURN END *SETRV SUBROUTINE SETRV(VECTOR, N, VALUE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS THE FIRST N ELEMENTS OF VECTOR 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 REAL + VALUE INTEGER + N C C ARRAY ARGUMENTS REAL + 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 REAL VALUE C VALUE TO WHICH THE ELEMENTS ARE TO BE SET C REAL VECTOR(N) C VECTOR WHOSE FIRST N ELEMENTS ARE TO BE SET. C DO 10 I=1,N VECTOR(I) = VALUE 10 CONTINUE C RETURN C END *SLFLT SUBROUTINE SLFLT (Y, N, K, H, YF, NYF) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PERFORMS A SYMMETRIC FILTERING OPERATION C ON AN INPUT SERIES Y, RETURNING THE FILTERED SERIES IN YF. 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,N,NYF C C ARRAY ARGUMENTS REAL + H(*),Y(*),YF(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT LOGICAL + ERR01,ERR02,ERR03,ERR04,HEAD C C LOCAL ARRAYS CHARACTER + LH(8)*1,LK(8)*1,LN(8)*1,LONE(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERIODD,ERSLF,FLTSL,IPRINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01, ERR02, ERR03, ERR04 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C REAL H(K) C THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS. 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 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. C CHARACTER*1 LH(8), LK(8), LN(8), LONE(8) C THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES 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 REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YF(N) C THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'L', 'F', 'L', 'T', ' '/ DATA + LH(1), LH(2), LH(3), LH(4), LH(5), LH(6), LH(7), LH(8) + / 'H', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ 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', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA + LONE(1), LONE(2), LONE(3), LONE(4), LONE(5), LONE(6), LONE(7), + LONE(8) /'O', 'N', 'E', ' ', ' ', ' ', ' ', ' '/ 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 EISII(NMSUB, LK, K, 1, N, 1, HEAD, ERR02, LONE, LN) C CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR03) C IF (ERR01 .OR. ERR02 .OR. ERR03) GO TO 10 C CALL ERSLF(NMSUB, LH, K, H, HEAD, ERR04) C IF (.NOT. ERR04) GO TO 20 C 10 CONTINUE IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 20 CONTINUE C CALL FLTSL (Y, N, K, H, YF, NYF) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 39H CALL SLFLT (Y, N, K, H, YF, NYF)) 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 REAL + COSMIN,SIZE,WSCALE INTEGER + P C C ARRAY ARGUMENTS REAL + A(1),STEP(P),U(P),W(P),WCHMTD(P),Y(P) C C LOCAL SCALARS REAL + DENMIN,HALF,ONE,SDOTWM,T,UI,WI,ZERO INTEGER + I,J,K C C EXTERNAL FUNCTIONS REAL + 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 REAL 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 REAL DENMIN, SDOTWM, T, UI, WI C C *** CONSTANTS *** C REAL HALF, ONE, ZERO C C/ C *** EXTERNAL FUNCTIONS AND SUBROUTINES *** C C EXTERNAL DOTPRD, SLVMUL, V2NORM C REAL DOTPRD, V2NORM C DATA HALF/0.5E0/, ONE/1.0E0/, ZERO/0.0E0/ 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 *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 REAL + S(1),X(P),Y(P) C C LOCAL SCALARS REAL + XI INTEGER + I,IM1,J,K C C EXTERNAL FUNCTIONS REAL + DOTPRD EXTERNAL DOTPRD C C *** PARAMETER DECLARATIONS *** C C INTEGER P C REAL 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 REAL XI C C *** EXTERNAL FUNCTION *** C C EXTERNAL DOTPRD C REAL DOTPRD 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 *SMPLY SUBROUTINE SMPLY (Y, N, NS, YS, NYS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE SAMPLES EVERY KTH OBSERVATION FROM THE INPUT C SERIES Y, STORING THE SAMPLED SERIES IN YS. 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 + N,NS,NYS C C ARRAY ARGUMENTS REAL + Y(N),YS(N) C C LOCAL SCALARS INTEGER + I,I1 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I, I1 C INDEXING VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES Y. C INTEGER NS C THE SAMPLING RATE. C INTEGER NYS C THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YS. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YS(N) C THE VECTOR IN WHICH THE SAMPLED SERIES IS RETURNED. C NYS = 0 DO 30 I = 1, N, NS NYS = NYS + 1 YS(NYS) = Y(I) 30 CONTINUE I1 = NYS + 1 DO 40 I = I1, N YS(I) = 0.0E0 40 CONTINUE C RETURN END *SPCCK SUBROUTINE SPCCK (SPC, ISORT, NF, SPCMN, SPCMX, NSPC, ISPCER) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE ANALYZES THE ORDINATES FOR THE SPECTRAL SEMI LOG C PLOTS PRODUCED BY THE ASPC SERIES OF ROUTINES. Y AXIS VALUES C (YORD) MORE THAN 3 POWERS OF TEN LESS THAN THE NEXT LARGER C VALUE ARE CONSIDERED INSIGNIFICANT AND ARE CULLED FROM THE C ORDINATES. 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 REAL + SPCMN,SPCMX INTEGER + ISPCER,NF,NSPC C C ARRAY ARGUMENTS REAL + SPC(NF) INTEGER + ISORT(NF) C C LOCAL SCALARS INTEGER + I,K1,K2,LOG1,LOG2 C C EXTERNAL SUBROUTINES EXTERNAL SRTIR,SRTRI C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE C INTEGER ISORT(NF) C THE ARRAY IN WHICH THE ORDER PERMUTATION FOR THE SORTED C DATA IS STORED. C INTEGER ISPCER C AN INDICATOR VARIABLE USED TO SUPRESS THE SPECTRAL PLOTS C WHEN FEWER THAN 1 VALID SPECTRAL VALUES WERE COMPUTED. C INTEGER K1, K2 C INDEX VARIABLES. C INTEGER LOG1, LOG2 C THE ORDER OF THE SPECTRAL ESTIMATES. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRAL ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NSPC C THE NUMBER OF VALID SPECTRAL ESTIMATES. C REAL SPC(NF) C THE ARRAY CONTAINING THE SPECTRAL ESTIMATES. C REAL SPCMN, SPCMX C THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED. C C ORDER THE SPECTRAL ESTIMATES FROM SMALLEST TO LARGEST. C DO 10 I = 1, NF ISORT(I) = I 10 CONTINUE CALL SRTIR (ISORT, NF, SPC) C C DETERMINE SIGINIFICANT VALUES TO BE PLOTTED. C K1 = NF K2 = K1 IF ((SPC(NF) .LE. 0.0E0) .OR. (NF.EQ.1)) GO TO 30 LOG1 = LOG10(SPC(NF)) IF (SPC(NF) .LT. 1.0E0) LOG1 = LOG1 - 1 DO 20 I = 2, NF K2 = K1 - 1 IF (SPC(K2) .LE. 0.0E0) GO TO 30 LOG2 = LOG10(SPC(K2)) IF (SPC(K2) .LT. 1.0E0) LOG2 = LOG2 - 1 IF (LOG1-LOG2 .GE. 3 .AND. NF-K2 .GE. 5) GO TO 30 LOG1 = LOG2 K1 = K2 20 CONTINUE C 30 SPCMN = SPC(K1) NSPC = NF + 1 - K1 C SPCMX = SPC(NF) C CALL SRTRI (SPC, NF, ISORT) ISPCER = 0 IF (NF-K2 .LE. 0) ISPCER = 1 C RETURN END *SPPC SUBROUTINE SPPC(YM, X, N, ISYM, ILOG, ISIZE, NOUT, YLB, YUB, + XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,ISIZE,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XMISS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', 'C', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ISCHCK = 1 MISS = .FALSE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPPC (Y, X, N, ISYM, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *SPP SUBROUTINE SPP(YM, X, N, ISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N C C ARRAY ARGUMENTS REAL + X(*),YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C THE LABELED COMMON FOR COMMUNICATING ERROR FLAGS TO THE USER C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', ' ', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 1 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPP (Y, X, N, ISYM)') END *SPPL SUBROUTINE SPPL(YM, X, N, ISYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N C C ARRAY ARGUMENTS REAL + X(*),YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', 'L', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 XMISS = 1.0E0 M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 1 ISIZE = -1 NOUT = 0 MISS = .FALSE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPPL (Y, X, N, ISYM, ILOG)') END *SPPLTC SUBROUTINE SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW, + CILOW, CIMID, CIUP, LPCV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CONFIDENCE INTERVAL AND BANDWIDTH C CO-ORDINATES FOR THE SPECTRUM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + BW,CILOW,CIMID,CIUP,XPLTMN,XPLTMX INTEGER + LPCV,NPTS C C ARRAY ARGUMENTS REAL + XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C INTRINSIC FUNCTIONS INTRINSIC MAX C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL BW C THE BANDWIDTH. C REAL CILOW, CIMID, CIUP C THE Y CORDNATES FOR THE LOWER MID AND UPPER CONFIDENCE C INTERVAL POINTS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR THE PLOTS. C INTEGER NPTS C THE NUMBER OF CO-ORDINATES TO BE PLOTTED. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C IF (XPLTMX - XPLTMN .GE. BW) GO TO 10 C XPLTMX = MAX(XPLTMX + (BW - XPLTMX + XPLTMN) / 2.0E0, 0.5E0) XPLTMN = XPLTMX - BW C 10 CONTINUE C NPTS = NPTS + 1 C XAXIS(NPTS) = XPLTMX - 0.5E0 * BW YAXIS(NPTS) = CIUP ISYM(NPTS) = 7 C NPTS = NPTS + 1 C XAXIS(NPTS) = XPLTMX - 0.5E0 * BW YAXIS(NPTS) = CIMID ISYM(NPTS) = 3 C NPTS = NPTS + 1 C XAXIS(NPTS) = XPLTMX - 0.5E0 * BW YAXIS(NPTS) = CILOW ISYM(NPTS) = 13 C NPTS = NPTS + 1 C XAXIS(NPTS) = XPLTMX - BW YAXIS(NPTS) = CIMID ISYM(NPTS) = 6 C NPTS = NPTS + 1 C XAXIS(NPTS) = XPLTMX YAXIS(NPTS) = CIMID ISYM(NPTS) = 27 C RETURN END *SPPLTD SUBROUTINE SPPLTD (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX, + CILOW, CIMID, CIUP, YMAX) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS VARIOUS Y AXIS LIMITS FOR DECIBLE C SPECTRUM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALOW,AUP,CILOW,CIMID,CIUP,SPCMN,SPCMX,YMAX,YPLTMN,YPLTMX C C LOCAL SCALARS REAL + RNGMN,YMIN C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALOW, AUP C FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS. C REAL CILOW, CIMID, CIUP C THE Y CORDNATES FOR THE LOWER MID AND UPPER CONFIDENCE C INTERVAL POINTS. C REAL RNGMN C THE MINIMUM Y AXIS RANGE FOR THE PLOT. C REAL SPCMN, SPCMX C THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED. C REAL YMAX, YMIN C THE MAXIMUM AND MINIMUM ACTUAL SPECTRAL VALUE C (IN DECIBELS) TO BE PLOTTED. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS. C C SET CO-ORDINATES FOR DECIBLE PLOTS C YMAX = 10.0E0 * LOG10(SPCMX) YMIN = 10.0E0 * LOG10(SPCMN) - YMAX C YPLTMX = 0.0E0 RNGMN = 20.0E0 * (LOG10(AUP) - LOG10(ALOW)) IF (ABS(YMIN) .LT. RNGMN) YPLTMX = (RNGMN + YMIN) * 0.5E0 YPLTMN = YMIN - YPLTMX CIUP = YPLTMX CIMID = CIUP - 10.0E0 * LOG10(AUP) CILOW = CIMID + 10.0E0 * LOG10(ALOW) C RETURN END *SPPLTL SUBROUTINE SPPLTL (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX, + CILOW, CIMID, CIUP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SETS VARIOUS Y AXIS LIMITS FOR DECIBLE C SPECTRUM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALOW,AUP,CILOW,CIMID,CIUP,SPCMN,SPCMX,YPLTMN,YPLTMX C C LOCAL SCALARS REAL + RNGMN,YMAX,YMIN C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALOW, AUP C FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS. C REAL CILOW, CIMID, CIUP C THE Y CORDNATES FOR THE LOWER MID AND UPPER CONFIDENCE C INTERVAL POINTS. C REAL RNGMN C THE MINIMUM Y AXIS RANGE FOR THE PLOT. C REAL SPCMN, SPCMX C THE MINIMUM AND MAXIMUM SPECTRAL VALUE TO BE PLOTTED. C REAL YMAX, YMIN C THE MAXIMUM AND MINIMUM ACTUAL SPECTRUM VALUE TO BE PLOTTED. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS. C C SET CO-ORDINATES FOR DECIBLE PLOTS C YMAX = LOG10(SPCMX) YMIN = LOG10(SPCMN) C YPLTMX = SPCMX YPLTMN = SPCMN RNGMN = 2.0E0 * (LOG10(AUP) - LOG10(ALOW)) IF (YMAX - YMIN .GE. RNGMN) GO TO 10 C YPLTMX = 10.0E0 ** (YMAX + (RNGMN - YMAX + YMIN) * 0.5E0) YPLTMN = 10.0E0 ** (YMIN - (RNGMN - YMAX + YMIN) * 0.5E0) C 10 CIUP = YPLTMX CIMID = CIUP / AUP CILOW = CIMID * ALOW C RETURN END *SPPMC SUBROUTINE SPPMC(YM, YMMISS, X, XMISS, N, ISYM, ILOG, ISIZE, NOUT, + YLB, YUB, XLB, XUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING C OBSERVATIONS (LONG CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XLB,XMISS,XUB,YLB,YUB INTEGER + ILOG,ISIZE,N,NOUT C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', 'M', 'C', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ISCHCK = 1 MISS = .TRUE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPPMC (Y, YMISS, X, XMISS, N, ISYM, ILOG,'/ + ' + ISIZE, NOUT, YLB, YUB, XLB, XUB)') END *SPPM SUBROUTINE SPPM(YM, YMMISS, X, XMISS, N, ISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING C OBSERVATIONS (SHORT CALL). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + ILOG,IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', 'M', ' ', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 1 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPPM (Y, YMISS, X, XMISS, N, ISYM)') END *SPPML SUBROUTINE SPPML(YM, YMMISS, X, XMISS, N, ISYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A SIMPLE PAGE C PLOT WITH USER CONTROL OF PLOT SYMBOLS AND WITH MISSING C OBSERVATIONS (LOG OPTION). C C WRITTEN BY - LINDA L. MITCHELL AND JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XMISS INTEGER + ILOG,N C C ARRAY ARGUMENTS REAL + X(*),YM(*),YMMISS(1) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XLB,XUB,YLB,YUB INTEGER + IPRT,ISCHCK,ISIZE,IYM,LISYM,M,NOUT LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOLS FOR PLOTTING. C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NOUT C USED TO INDICATE HOW MANY OF THE POINTS OUTSIDE THE BOUNDS C OF THE PLOT ARE TO BE LISTED. C REAL X(N) C VECTOR OF OBSERVATIONS FOR X COORDINATES C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL XMISS C THE MISSING VALUE CODE FOR THE X-AXIS. C REAL XUB C THE UPPER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(N,1) C VECTOR OF OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'P', 'P', 'M', 'L', ' '/ C C COMMENCE BODY OF ROUTINE C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 0.0E0 XUB = 0.0E0 ISCHCK = 1 ISIZE = -1 NOUT = 0 MISS = .TRUE. LISYM = N C CALL PPCNT (YM, YMMISS, X, XMISS, N, M, IYM, MULTI, ILOG, + YLB, YUB, XLB, XUB, NMSUB, ISCHCK, ISYM, ISIZE, NOUT, MISS, + LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SPPML (Y, YMISS, X, XMISS, N, ISYM, ILOG)') END *SRTIR SUBROUTINE SRTIR(IR, LA, A) C C LATEST REVISION - 03/15/90 (JRD) C C FUNCTION SRTIR - SORT INTEGER ARRAY IR ON KEY ARRAY A. C IF THE INTEGER ARRAY CONSISTS OF THE C ORDERED SEQUENCE 1, 2, ... LA, THEN C ON COMPLETION IR IS A PERMUTATION C VECTOR FOR THE SORT OF A. C USAGE - CALL SRTIR (A,LA,IR) C PARAMETERS A(LA) - ON INPUT, CONTAINS THE ARRAY TO BE SORTED ON C ON OUTPUT, A CONTAINS THE SORTED ARRAY C LA - INPUT VARIABLE CONTAINING THE NUMBER OF C ELEMENTS IN THE ARRAY TO BE SORTED C IR(LA) - IF ON INPUT, IR CONTAINS THE INTEGER VALUES C 1,2,...,LA. C - THEN ON OUTPUT, IR CONTAINS A RECORD OF THE C PERMUTATIONS MADE ON THE VECTOR A. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LA C C ARRAY ARGUMENTS REAL + A(LA) INTEGER + IR(LA) C C LOCAL SCALARS REAL + R,T,TT INTEGER + I,IJ,IT,ITT,J,K,L,M C C LOCAL ARRAYS INTEGER + IL(21),IU(21) C C INTRINSIC FUNCTIONS INTRINSIC INT C C M = 1 I = 1 J = LA R = .375E0 10 IF (I.EQ.J) GO TO 90 IF (R.GT.0.5898437E0) GO TO 20 R = R + 3.90625E-2 GO TO 30 20 R = R - .21875E0 30 K = I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + INT((J-I)*R) T = A(IJ) IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 40 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) 40 L = J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (A(J).GE.T) GO TO 60 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 60 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) GO TO 60 50 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 60 L = L - 1 IF (A(L).GT.T) GO TO 60 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 70 K = K + 1 IF (A(K).LT.T) GO TO 70 C INTERCHANGE THESE ELEMENTS IF (K.LE.L) GO TO 50 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I.LE.J-K) GO TO 80 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 100 80 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 100 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 90 M = M - 1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 100 IF (J-I.GE.1) GO TO 30 IF (I.EQ.1) GO TO 10 I = I - 1 110 I = I + 1 IF (I.EQ.J) GO TO 90 T = A(I+1) IT = IR(I+1) IF (A(I).LE.T) GO TO 110 K = I 120 A(K+1) = A(K) IR(K+1) = IR(K) K = K - 1 IF (T.LT.A(K)) GO TO 120 A(K+1) = T IR(K+1) = IT GO TO 110 END *SRTIRR SUBROUTINE SRTIRR(IR, RR, LA, A) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SORTS THE LENGTH LA ARRAY A, THE LENGTH LA C INTEGER ARRAY IR, AND THE LENGTH LA ARRAY RR INTO C ASCENDING ORDER, BASED ON THE VALUES IN A. THE ARRAY C A CONSTITUTES THE SORTING KEY. THE OTHER TWO ARRAYS ARE C CARRIED ALONG. ORDINARILY THE ARRAY IR CONTAINS THE C VALUES 1, ..., LA INITIALLY, SO THAT THE THREE ARRAYS CAN C LATER BE SORTED AGAIN WITH IR AS THE KEY, IN ORDER TO C RESTORE A AND RR TO THEIR ORIGINAL ORDER. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C (BASED CLOSELY ON THE IMSL CDC LIBRARY 3 ROUTINE VSORTP) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LA C C ARRAY ARGUMENTS REAL + A(LA),RR(LA) INTEGER + IR(LA) C C LOCAL SCALARS REAL + R,RT,RTT,T,TT INTEGER + I,IJ,IT,ITT,J,K,L,M C C LOCAL ARRAYS INTEGER + IL(21),IU(21) C C INTRINSIC FUNCTIONS INTRINSIC INT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL A(LA) C INPUT/OUTPUT PARAMETER. THE KEY ARRAY. C INTEGER I C * C INTEGER IJ C * C INTEGER IL(21) C * C INTEGER IR(LA) C INPUT/OUTPUT PARAMETER. THE INTEGER ARRAY CARRIED ALONG C IN THE SORT. INITIALLY IT SHOULD CONTAIN 1, ..., LA. C ON EXIT IT CONTAINS THE PERMUTATION VECTOR OF THE SORT. C SORTING ON THE PERMUTATION VECTOR WILL RESTORE THE KEY C ARRAY A AND THE ARRAY RR TO THEIR ORIGINAL ORDERS. C INTEGER IT C * C INTEGER ITT C * C INTEGER IU(21) C * C INTEGER J C * C INTEGER K C * C INTEGER L C * C INTEGER LA C INPUT PARAMETER. THE LENGTH OF THE INPUT/OUTPUT PARAMETERS C A, IR, AND RR. C INTEGER M C * C REAL R C * C REAL RR(LA) C INPUT/OUTPUT PARAMETER. THE ARRAY CARRIED ALONG IN C THE SORT. IT MIGHT BE THE SET OF WEIGHTS FOR A. C REAL RT C * C REAL RTT C * C REAL T C * C REAL TT C M = 1 I = 1 J = LA R = .375E0 10 IF (I.EQ.J) GO TO 90 IF (R.GT.0.5898437E0) GO TO 20 R = R + 3.90625E-2 GO TO 30 20 R = R - .21875E0 30 K = I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + INT((J-I)*R) T = A(IJ) IT = IR(IJ) RT = RR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 40 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) RR(IJ) = RR(I) RR(I) = RT RT = RR(IJ) 40 L = J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (A(J).GE.T) GO TO 60 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ) RR(IJ) = RR(J) RR(J) = RT RT = RR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 60 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) RR(IJ) = RR(I) RR(I) = RT RT = RR(IJ) GO TO 60 50 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT RTT = RR(L) RR(L) = RR(K) RR(K) = RTT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 60 L = L - 1 IF (A(L).GT.T) GO TO 60 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 70 K = K + 1 IF (A(K).LT.T) GO TO 70 C INTERCHANGE THESE ELEMENTS IF (K.LE.L) GO TO 50 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I.LE.J-K) GO TO 80 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 100 80 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 100 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 90 M = M - 1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 100 IF (J-I.GE.1) GO TO 30 IF (I.EQ.1) GO TO 10 I = I - 1 110 I = I + 1 IF (I.EQ.J) GO TO 90 T = A(I+1) IT = IR(I+1) RT = RR(I+1) IF (A(I).LE.T) GO TO 110 K = I 120 A(K+1) = A(K) IR(K+1) = IR(K) RR(K+1) = RR(K) K = K - 1 IF (T.LT.A(K)) GO TO 120 A(K+1) = T IR(K+1) = IT RR(K+1) = RT GO TO 110 END *SRTRI SUBROUTINE SRTRI(A, LA, IR) C C LATEST REVISION - 03/15/90 (JRD) C C FUNCTION SRTRI - SORT ARRAY A ON AN INTEGER ARRAY IR. C IF THE INTEGER ARRAY IS A PERMUTATION C VECTOR FOR THE ARRAY, THEN THE C ARRAY IS RESTORED TO ITS ORIGINAL C (UNPERMUTED) ORDER. C PERMUTATIONS RETURNED C USAGE - CALL SRTRI (A,LA,IR) C PARAMETERS A(LA) - ON INPUT, CONTAINS THE ARRAY TO BE SORTED C ON OUTPUT, A CONTAINS THE SORTED ARRAY C LA - INPUT VARIABLE CONTAINING THE NUMBER OF C ELEMENTS IN THE ARRAY TO BE SORTED C IR(LA) - ON INPUT, CONTAINS THE INTEGER KEY ARRAY C ON OUTPUT, CONTAINS THE SORTED KEY ARRAY C 1,2,...,LA. C - THEN ON OUTPUT, IR CONTAINS A RECORD OF THE C PERMUTATIONS MADE ON THE VECTOR A. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LA C C ARRAY ARGUMENTS REAL + A(LA) INTEGER + IR(LA) C C LOCAL SCALARS REAL + R,T,TT INTEGER + I,IJ,IT,ITT,J,K,L,M C C LOCAL ARRAYS INTEGER + IL(21),IU(21) C C INTRINSIC FUNCTIONS INTRINSIC INT C C M = 1 I = 1 J = LA R = .375E0 10 IF (I.EQ.J) GO TO 90 IF (R.GT.0.5898437E0) GO TO 20 R = R + 3.90625E-2 GO TO 30 20 R = R - .21875E0 30 K = I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION IT IJ = I + INT((J-I)*R) T = A(IJ) IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN IT, INTERCHANGE WITH IT IF (IR(I).LE.IT) GO TO 40 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) 40 L = J C IF LAST ELEMENT OF ARRAY IS LESS THAN C IT, INTERCHANGE WITH IT IF (IR(J).GE.IT) GO TO 60 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN IT, INTERCHANGE WITH IT IF (IR(I).LE.IT) GO TO 60 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) GO TO 60 50 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN IT 60 L = L - 1 IF (IR(L).GT.IT) GO TO 60 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN IT 70 K = K + 1 IF (IR(K).LT.IT) GO TO 70 C INTERCHANGE THESE ELEMENTS IF (K.LE.L) GO TO 50 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I.LE.J-K) GO TO 80 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 100 80 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 100 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 90 M = M - 1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 100 IF (J-I.GE.1) GO TO 30 IF (I.EQ.1) GO TO 10 I = I - 1 110 I = I + 1 IF (I.EQ.J) GO TO 90 T = A(I+1) IT = IR(I+1) IF (IR(I).LE.IT) GO TO 110 K = I 120 A(K+1) = A(K) IR(K+1) = IR(K) K = K - 1 IF (IT.LT.IR(K)) GO TO 120 A(K+1) = T IR(K+1) = IT GO TO 110 END *SRTRRI SUBROUTINE SRTRRI(A, RR, LA, IR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE SORTS THE LENGTH LA INTEGER ARRAY IR, THE LENGTH LA C ARRAY A, AND THE LENGTH LA ARRAY RR INTO ASCENDING C ORDER, BASED ON THE VALUES IN IR. THE INTEGER ARRAY IR C CONSTITUTES THE KEY. THE OTHER ARRAYS ARE CARRIED ALONG. C ORDINARILY THE ARRAY IR CONTAINS THE PERMUTATION VECTOR C RESULTING FROM AN APPLICATION OF THE ROUTINE SRTIRR, SO THAT C SORTING ON IR RESTORES A TO THE ORDER THAT IT HAD BEFORE C SRTIRR WAS APPLIED. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C (BASED CLOSELY ON THE IMSL CDC LIBRARY 3 ROUTINE VSORTP) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LA C C ARRAY ARGUMENTS REAL + A(LA),RR(LA) INTEGER + IR(LA) C C LOCAL SCALARS REAL + R,RT,RTT,T,TT INTEGER + I,IJ,IT,ITT,J,K,L,M C C LOCAL ARRAYS INTEGER + IL(21),IU(21) C C INTRINSIC FUNCTIONS INTRINSIC INT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL A(LA) C INPUT/OUTPUT PARAMETER. THE ARRAY TO BE SORTED ON C THE BASIS OF THE VALUES IN IR. IF IR IS A PERMUTATION C VECTOR PRODUCED ORIGINALLY IN A SORT OF A, THEN THIS C OPERATION RESTORES A TO ITS ORIGINAL ORDER. C INTEGER I C * C INTEGER IJ C * C INTEGER IL(21) C * C INTEGER IR(LA) C INPUT/OUTPUT PARAMETER. THE INTEGER KEY ARRAY. ORDINARILY C IT WILL BE A PERMUTATION VECTOR PRODUCED BY SOME PREVIOUS C SORT OF A AND RR ON A, SO THAT SORTING ON IR WILL RESTORE C A TO ITS ORIGINAL ORDER. C INTEGER IT C * C INTEGER ITT C * C INTEGER IU(21) C * C INTEGER J C * C INTEGER K C * C INTEGER L C * C INTEGER LA C INPUT PARAMETER. THE LENGTH OF THE INPUT/OUTPUT PARAMETERS C A, RR, AND IR. C INTEGER M C * C REAL R C * C REAL RR(LA) C INPUT/OUTPUT PARAMETER. THE ARRAY CARRIED ALONG IN C THE SORT. IT MIGHT BE THE SET OF WEIGHTS FOR A. C REAL RT C * C REAL RTT C * C REAL T C * C REAL TT C * C M = 1 I = 1 J = LA R = .375E0 10 IF (I.EQ.J) GO TO 90 IF (R.GT.0.5898437E0) GO TO 20 R = R + 3.90625E-2 GO TO 30 20 R = R - .21875E0 30 K = I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION IT IJ = I + INT((J-I)*R) T = A(IJ) IT = IR(IJ) RT = RR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN IT, INTERCHANGE WITH IT IF (IR(I).LE.IT) GO TO 40 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) RR(IJ) = RR(I) RR(I) = RT RT = RR(IJ) 40 L = J C IF LAST ELEMENT OF ARRAY IS LESS THAN C IT, INTERCHANGE WITH IT IF (IR(J).GE.IT) GO TO 60 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ) RR(IJ) = RR(J) RR(J) = RT RT = RR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN IT, INTERCHANGE WITH IT IF (IR(I).LE.IT) GO TO 60 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) RR(IJ) = RR(I) RR(I) = RT RT = RR(IJ) GO TO 60 50 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT RTT = RR(L) RR(L) = RR(K) RR(K) = RTT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN IT 60 L = L - 1 IF (IR(L).GT.IT) GO TO 60 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN IT 70 K = K + 1 IF (IR(K).LT.IT) GO TO 70 C INTERCHANGE THESE ELEMENTS IF (K.LE.L) GO TO 50 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I.LE.J-K) GO TO 80 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 100 80 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 100 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 90 M = M - 1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 100 IF (J-I.GE.1) GO TO 30 IF (I.EQ.1) GO TO 10 I = I - 1 110 I = I + 1 IF (I.EQ.J) GO TO 90 T = A(I+1) IT = IR(I+1) RT = RR(I+1) IF (IR(I).LE.IT) GO TO 110 K = I 120 A(K+1) = A(K) IR(K+1) = IR(K) RR(K+1) = RR(K) K = K - 1 IF (IT.LT.IR(K)) GO TO 120 A(K+1) = T IR(K+1) = IT RR(K+1) = RT GO TO 110 END *SSIDI SUBROUTINE SSIDI(A,LDA,N,KPVT,DET,INERT,WORK,JOB) C C LATEST REVISION - JANUARY 24, 1990 (JRD) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER JOB,LDA,N C C ARRAY ARGUMENTS REAL A(LDA,*),DET(2),WORK(*) INTEGER INERT(3),KPVT(*) C C LOCAL SCALARS REAL AK,AKKP1,AKP1,D,T,TEMP,TEN INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NODET,NOERT,NOINV C C EXTERNAL FUNCTIONS REAL SDOT EXTERNAL SDOT C C EXTERNAL SUBROUTINES EXTERNAL SAXPY,SCOPY,SSWAP C C INTRINSIC FUNCTIONS INTRINSIC ABS,IABS,MOD C C SSIDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE C OF A REAL SYMMETRIC MATRIX USING THE FACTORS FROM SSIFA. C C ON ENTRY C C A REAL(LDA,N) C THE OUTPUT FROM SSIFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. C C N INTEGER C THE ORDER OF THE MATRIX A. C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM SSIFA. C C WORK REAL(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C JOB HAS THE DECIMAL EXPANSION ABC WHERE C IF C .NE. 0, THE INVERSE IS COMPUTED, C IF B .NE. 0, THE DETERMINANT IS COMPUTED, C IF A .NE. 0, THE INERTIA IS COMPUTED. C C FOR EXAMPLE, JOB = 111 GIVES ALL THREE. C C ON RETURN C C VARIABLES NOT REQUESTED BY JOB ARE NOT USED. C C A CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF C THE ORIGINAL MATRIX. THE STRICT LOWER TRIANGLE C IS NEVER REFERENCED. C C DET REAL(2) C DETERMINANT OF ORIGINAL MATRIX. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0 C OR DET(1) = 0.0. C C INERT INTEGER(3) C THE INERTIA OF THE ORIGINAL MATRIX. C INERT(1) = NUMBER OF POSITIVE EIGENVALUES. C INERT(2) = NUMBER OF NEGATIVE EIGENVALUES. C INERT(3) = NUMBER OF ZERO EIGENVALUES. C C ERROR CONDITION C C A DIVISION BY ZERO MAY OCCUR IF THE INVERSE IS REQUESTED C AND SSICO HAS SET RCOND .EQ. 0.0 C OR SSIFA HAS SET INFO .NE. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SCOPY,SDOT,SSWAP C FORTRAN ABS,IABS,MOD C C NOINV = MOD(JOB,10) .EQ. 0 NODET = MOD(JOB,100)/10 .EQ. 0 NOERT = MOD(JOB,1000)/100 .EQ. 0 C TEN = 10.0E0 C IF (NODET .AND. NOERT) GO TO 140 IF (NOERT) GO TO 10 INERT(1) = 0 INERT(2) = 0 INERT(3) = 0 10 CONTINUE IF (NODET) GO TO 20 DET(1) = 1.0E0 DET(2) = 0.0E0 20 CONTINUE T = 0.0E0 DO 130 K = 1, N D = A(K,K) C C CHECK IF 1 BY 1 C IF (KPVT(K) .GT. 0) GO TO 50 C C 2 BY 2 BLOCK C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) C (S C) C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. C IF (T .NE. 0.0E0) GO TO 30 T = ABS(A(K,K+1)) D = (D/T)*A(K+1,K+1) - T GO TO 40 30 CONTINUE D = T T = 0.0E0 40 CONTINUE 50 CONTINUE C IF (NOERT) GO TO 60 IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE C IF (NODET) GO TO 120 DET(1) = D*DET(1) IF (DET(1) .EQ. 0.0E0) GO TO 110 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 70 80 CONTINUE 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 90 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE C C COMPUTE INVERSE(A) C IF (NOINV) GO TO 270 K = 1 150 IF (K .GT. N) GO TO 260 KM1 = K - 1 IF (KPVT(K) .LT. 0) GO TO 180 C C 1 BY 1 C A(K,K) = 1.0E0/A(K,K) IF (KM1 .LT. 1) GO TO 170 CALL SCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = SDOT(J,A(1,J),1,WORK,1) CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) 170 CONTINUE KSTEP = 1 GO TO 220 180 CONTINUE C C 2 BY 2 C T = ABS(A(K,K+1)) AK = A(K,K)/T AKP1 = A(K+1,K+1)/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - 1.0E0) A(K,K) = AKP1/D A(K+1,K+1) = AK/D A(K,K+1) = -AKKP1/D IF (KM1 .LT. 1) GO TO 210 CALL SCOPY(KM1,A(1,K+1),1,WORK,1) DO 190 J = 1, KM1 A(J,K+1) = SDOT(J,A(1,J),1,WORK,1) CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 190 CONTINUE A(K+1,K+1) = A(K+1,K+1) + SDOT(KM1,WORK,1,A(1,K+1),1) A(K,K+1) = A(K,K+1) + SDOT(KM1,A(1,K),1,A(1,K+1),1) CALL SCOPY(KM1,A(1,K),1,WORK,1) DO 200 J = 1, KM1 A(J,K) = SDOT(J,A(1,J),1,WORK,1) CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 200 CONTINUE A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) 210 CONTINUE KSTEP = 2 220 CONTINUE C C SWAP C KS = IABS(KPVT(K)) IF (KS .EQ. K) GO TO 250 CALL SSWAP(KS,A(1,KS),1,A(1,K),1) DO 230 JB = KS, K J = K + KS - JB TEMP = A(J,K) A(J,K) = A(KS,J) A(KS,J) = TEMP 230 CONTINUE IF (KSTEP .EQ. 1) GO TO 240 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 240 CONTINUE 250 CONTINUE K = K + KSTEP GO TO 150 260 CONTINUE 270 CONTINUE RETURN END *SSIFA SUBROUTINE SSIFA(A,LDA,N,KPVT,INFO) C C LATEST REVISION - JANUARY 24, 1990 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER INFO,LDA,N C C ARRAY ARGUMENTS REAL A(LDA,*) INTEGER KPVT(*) C C LOCAL SCALARS REAL ABSAKK,AK,AKM1,ALPHA,BK,BKM1,COLMAX,DENOM,MULK,MULKM1,ROWMAX, + T INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP LOGICAL SWAP C C EXTERNAL FUNCTIONS INTEGER ISAMAX EXTERNAL ISAMAX C C EXTERNAL SUBROUTINES EXTERNAL SAXPY,SSWAP C C INTRINSIC FUNCTIONS INTRINSIC ABS,AMAX1,SQRT C C C SSIFA FACTORS A REAL SYMMETRIC MATRIX BY ELIMINATION C WITH SYMMETRIC PIVOTING. C C TO SOLVE A*X = B , FOLLOW SSIFA BY SSISL. C TO COMPUTE INVERSE(A)*C , FOLLOW SSIFA BY SSISL. C TO COMPUTE DETERMINANT(A) , FOLLOW SSIFA BY SSIDI. C TO COMPUTE INERTIA(A) , FOLLOW SSIFA BY SSIDI. C TO COMPUTE INVERSE(A) , FOLLOW SSIFA BY SSIDI. C C ON ENTRY C C A REAL(LDA,N) C THE SYMMETRIC MATRIX TO BE FACTORED. C ONLY THE DIAGONAL AND UPPER TRIANGLE ARE USED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS C NOT AN ERROR CONDITION FOR THIS SUBROUTINE, C BUT IT DOES INDICATE THAT SSISL OR SSIDI MAY C DIVIDE BY ZERO IF CALLED. C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSWAP,ISAMAX C FORTRAN ABS,AMAX1,SQRT C C C INITIALIZE C C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 C INFO = 0 C C MAIN LOOP ON K, WHICH GOES FROM N TO 1. C K = N 10 CONTINUE C C LEAVE THE LOOP IF K=0 OR K=1. C C ...EXIT IF (K .EQ. 0) GO TO 200 IF (K .GT. 1) GO TO 20 KPVT(1) = 1 IF (A(1,1) .EQ. 0.0E0) INFO = 1 C ......EXIT GO TO 200 20 CONTINUE C C THIS SECTION OF CODE DETERMINES THE KIND OF C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS C REQUIRED. C KM1 = K - 1 ABSAKK = ABS(A(K,K)) C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C COLUMN K. C IMAX = ISAMAX(K-1,A(1,K),1) COLMAX = ABS(A(IMAX,K)) IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 KSTEP = 1 SWAP = .FALSE. GO TO 90 30 CONTINUE C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C ROW IMAX. C ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = AMAX1(ROWMAX,ABS(A(IMAX,J))) 40 CONTINUE IF (IMAX .EQ. 1) GO TO 50 JMAX = ISAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = AMAX1(ROWMAX,ABS(A(JMAX,IMAX))) 50 CONTINUE IF (ABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 KSTEP = 1 SWAP = .TRUE. GO TO 80 60 CONTINUE IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 KSTEP = 1 SWAP = .FALSE. GO TO 80 70 CONTINUE KSTEP = 2 SWAP = IMAX .NE. KM1 80 CONTINUE 90 CONTINUE IF (AMAX1(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 C C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. C KPVT(K) = K INFO = K GO TO 190 100 CONTINUE IF (KSTEP .EQ. 2) GO TO 140 C C 1 X 1 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 120 C C PERFORM AN INTERCHANGE. C CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = A(J,K) A(J,K) = A(IMAX,J) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE C C PERFORM THE ELIMINATION. C DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = MULK CALL SAXPY(J,T,A(1,K),1,A(1,J),1) A(J,K) = MULK 130 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = K IF (SWAP) KPVT(K) = IMAX GO TO 190 140 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 160 C C PERFORM AN INTERCHANGE. C CALL SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = A(J,K-1) A(J,K-1) = A(IMAX,J) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE C C PERFORM THE ELIMINATION. C KM2 = K - 2 IF (KM2 .EQ. 0) GO TO 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) DENOM = 1.0E0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/A(K-1,K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK CALL SAXPY(J,T,A(1,K),1,A(1,J),1) T = MULKM1 CALL SAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 170 CONTINUE 180 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = 1 - K IF (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP GO TO 10 200 CONTINUE RETURN END *STAT1 SUBROUTINE STAT1(Y, N, YMED, YMIN, YMAX, YMIDRG, YRANGE, NCELLS, + YLB, YUB, YDISTR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS COMPUTES STATISTICS FOR A VECTOR Y THAT REQUIRE OR CAN C MAKE USE OF SORTEDNESS IN THE Y VECTOR. C C THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS C CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTED BY C SALLY PEAVY. THE ORIGINAL ADAPTATION TO STARPAC WAS MADE C BY JANET DONALDSON. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YMAX,YMED,YMIDRG,YMIN,YRANGE,YUB INTEGER + N,NCELLS C C ARRAY ARGUMENTS REAL + Y(N),YDISTR(NCELLS) C C LOCAL SCALARS REAL + DELY,YT INTEGER + I,IC,IC1,L,M,M1 C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELY C THE WIDTH OF AN INTERVAL ONE TENTH THE RANGE OF THE C DATA IN Y. C INTEGER I C A LOOP INDEX. C INTEGER IC C PREVIOUS SIGN IN RUNS CALCULATION. C INTEGER IC1 C COUNT IN FREQUENCY DISTRIBUTION CALCULATIONS. C INTEGER L C A LOOP INDEX. C INTEGER M C A LOOP INDEX. C INTEGER M1 C WHEN N IS EVEN, M1 IS M + 1, OTHERWISE IT IS M. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y AND WT. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION. C REAL Y(N) C INPUT PARAMETER. A SET OF N DATA POINTS, SORTED C INTO ASCENDING ORDER. C REAL YDISTR(NCELLS) C OUTPUT PARAMETER. THE NUMBERS OF Y VALUES WITH C POSITIVE WEIGHTS IN EACH OF NCELLS EQUAL LENGTH INTERVALS C THAT DIVIDE THE RANGE OF Y VALUES. C REAL YLB C THE LOWER BOUND FOR THE FREQUENCY DISTRIBUTION. C IF YLB = YUB, THE MINIMUM OBSERVATION WILL BE USED. C REAL YMAX C OUTPUT PARAMETER. THE MAXIMUM OF THE OBSERVATIONS Y HAVING C POSITIVE WEIGHT. C REAL YMED C OUTPUT PARAMETER. THE MEDIAN OF THE OBSERVATIONS Y. C REAL YMIDRG C OUTPUT PARAMETER. THE MIDRANGE OF THE OBSERVATIONS Y. C REAL YMIN C OUTPUT PARAMETER. THE MINIMUM OF THE OBSERVATIONS Y HAVING C POSITIVE WEIGHT. C REAL YRANGE C THE RANGE OF THE OBSERVATIONS Y. C REAL YT C THE MAXIMUM VALUE IN EACH INTERVAL IN THE FREQUENCY C DISTRIBUTIONS CALCULATIONS. C REAL YUB C THE UPPER BOUND FOR THE FREQUENCY DISTRIBUTION. C IF YLB = YUB, THE MAXIMUM OBSERVATION WILL BE USED. C C CALCULATE THE MEDIAN, MIDRANGE, RANGE, AND EXTREMA. C M = (N+1)/2 M1 = M IF (MOD(N,2).EQ.0) M1 = M1 + 1 YMED = (Y(M)+Y(M1))/2.0E0 YMIDRG = (Y(1)+Y(N))/2.0E0 YRANGE = Y(N) - Y(1) YMIN = Y(1) YMAX = Y(N) C C COMPUTE FREQUENCY DISTRIBUTION. C IF (NCELLS.LE.0) RETURN IC1 = 0 IF (NCELLS.EQ.1) GO TO 40 C DELY = YRANGE YT = YMIN IF (YLB.GE.YUB) GO TO 5 DELY = YUB - YLB YT = YLB 5 CONTINUE DELY = DELY / NCELLS YT = YT + DELY L = 0 DO 30 I=2,NCELLS IC = 0 10 L = L + 1 IF (L.GT.N) GO TO 20 IF (Y(L).GT.YT) GO TO 20 IC = IC + 1 IC1 = IC1 + 1 GO TO 10 20 YDISTR(I-1) = IC L = L - 1 YT = YT + DELY 30 CONTINUE 40 YDISTR(NCELLS) = N - IC1 RETURN END *STAT1W SUBROUTINE STAT1W(Y, WT, N, YMED, YMIN, YMAX, YMIDRG, YRANGE, + NCELLS, YLB, YUB, YDISTR, NNZW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS COMPUTES STATISTICS FOR A VECTOR Y THAT REQUIRE OR CAN C MAKE USE OF SORTEDNESS IN THE VECTOR. WEIGHTS ARE USED. C C THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS C CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTED BY C SALLY PEAVY. THE ORIGINAL ADAPTATION TO STARPAC WAS MADE C BY JANET DONALDSON. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + YLB,YMAX,YMED,YMIDRG,YMIN,YRANGE,YUB INTEGER + N,NCELLS,NNZW C C ARRAY ARGUMENTS REAL + WT(N),Y(N),YDISTR(NCELLS) C C LOCAL SCALARS REAL + DELY,YT INTEGER + I,IC,IC1,KK,L,M,M1,MAX,MAXY,MINY,N2 C C INTRINSIC FUNCTIONS INTRINSIC MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELY C THE WIDTH OF AN INTERVAL ONE TENTH THE RANGE OF THE C DATA IN Y. C INTEGER I C A LOOP INDEX. C INTEGER IC C PREVIOUS SIGN IN RUNS CALCULATION. C INTEGER IC1 C COUNT IN FREQUENCY DISTRIBUTION CALCULATIONS. C INTEGER KK C A BACKWARDS, BOULDER, COLORADO LOOP INDEX. C INTEGER L C A LOOP INDEX. C INTEGER M C A LOOP INDEX. C INTEGER MAX C INDEX OF A MAXIMUM ELEMENT. C INTEGER MAXY C LAST ELEMENT OF Y, THE LARGEST ONE. C INTEGER MINY C FIRST ELEMENT OF Y, THE LEAST ONE. C INTEGER M1 C ... C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y AND WT. C INTEGER NCELLS C THE NUMBER OF CELLS IN THE FREQUENCY DISTRIBUTION. C INTEGER NNZW C INPUT PARAMETER. THE NUMBER OF POSITIVE ELEMENTS IN WT. C INTEGER N2 C (NNZW + 1)/2 C REAL WT(N) C INPUT PARAMETER. THE VECTOR OF WEIGHTS FOR THE C Y OBSERVATIONS. C REAL Y(N) C INPUT PARAMETER. A SET OF N DATA POINTS, SORTED C INTO ASCENDING ORDER. C REAL YDISTR(NCELLS) C OUTPUT PARAMETER. THE NUMBERS OF Y VALUES WITH C POSITIVE WEIGHTS IN EACH OF TEN EQUAL LENGTH INTERVALS. C THAT DIVIDE THE RANGE OF Y VALUES. C REAL YLB C THE LOWER BOUND FOR THE FREQUENCY DISTRIBUTION. C IF YLB = YUB, THE MINIMUM OBSERVATION WILL BE USED. C REAL YMAX C OUTPUT PARAMETER. THE MAXIMUM OF THE OBSERVATIONS Y HAVING C POSITIVE WEIGHT. C REAL YMED C OUTPUT PARAMETER. THE MEDIAN OF THE OBSERVATIONS Y. C REAL YMIDRG C OUTPUT PARAMETER. THE MIDRANGE OF THE OBSERVATIONS Y. C REAL YMIN C OUTPUT PARAMETER. THE MINIMUM OF THE OBSERVATIONS Y HAVING C POSITIVE WEIGHT. C REAL YRANGE C OUTPUT PARAMETER. THE RANGE OF THE OBSERVATIONS Y. C REAL YT C THE MAXIMUM VALUE IN EACH INTERVAL IN THE FREQUENCY C DISTRIBUTIONS CALCULATIONS. C REAL YUB C THE UPPER BOUND FOR THE FREQUENCY DISTRIBUTION. C IF YLB = YUB, THE MAXIMUM OBSERVATION WILL BE USED. C C CALCULATE THE MEDIAN. C N2 = (NNZW+1)/2 M = 1 DO 10 I=1,N IF (I.GT.N2) GO TO 20 M = I IF (WT(M).LE.0.0E0) N2 = N2 + 1 10 CONTINUE 20 M1 = M IF (MOD(NNZW,2).NE.0) GO TO 40 DO 30 M1=M,N IF (WT(M1).GT.0.0E0) GO TO 40 30 CONTINUE 40 YMED = (Y(I)+Y(M1))/2.0E0 C C CALCULATE THE MIDRANGE, RANGE, MINIMUM, AND MAXIMUM. C MAX = N - NNZW + 1 DO 50 I=1,MAX MINY = I IF (WT(MINY).GT.0.0E0) GO TO 60 50 CONTINUE 60 DO 70 I=1,MAX KK = N + 1 - I MAXY = KK IF (WT(MAXY).GT.0.0E0) GO TO 80 70 CONTINUE 80 YMIDRG = (Y(MINY)+Y(MAXY))/2.0E0 YRANGE = Y(MAXY) - Y(MINY) YMIN = Y(MINY) YMAX = Y(MAXY) C C COMPUTE FREQUENCY DISTRIBUTION C DELY = YRANGE YT = YMIN IF (YLB.GE.YUB) GO TO 5 DELY = YUB - YLB YT = YLB 5 CONTINUE DELY = DELY / NCELLS YT = YT + DELY L = 0 IC1 = 0 DO 110 I=2,NCELLS IC = 0 90 L = L + 1 IF (L.GT.N) GO TO 100 IF (WT(L).LE.0.0E0) GO TO 90 IF (Y(L).GT.YT) GO TO 100 IC = IC + 1 IC1 = IC1 + 1 GO TO 90 100 YDISTR(I-1) = IC L = L - 1 YT = YT + DELY 110 CONTINUE YDISTR(NCELLS) = NNZW - IC1 RETURN END *STAT2 SUBROUTINE STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES FOR A VECTOR Y THE STATISTICS THAT DO C NOT REQUIRE SORTING OF THE VECTOR, THAT IS, THOSE NOT COMPUTED C BY STAT1. NO WEIGHTS ARE USED. C C THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS C CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTEN BY C SALLY PEAVY. THE ORIGINAL ADAPTATION TO STARPAC WAS C DONE BY JANET DONALDSON. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMD2,SUMD3,SUMD4,SUMDA,SUMDI INTEGER + N C C ARRAY ARGUMENTS REAL + STS(53),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + DIF,T,TA,TK1,TK2 INTEGER + I,IC,ICI,IDRUNS,IMINUS,IPLUS,IRUN C C EXTERNAL FUNCTIONS REAL + CDFF,PPFCHS,PPFT EXTERNAL CDFF,PPFCHS,PPFT C C INTRINSIC FUNCTIONS INTRINSIC ABS,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DIF C THE SUM OF THE DIFFERENCES BETWEEN SUCCEEDING ELEMENTS C IN Y. C INTEGER I C A LOOP INDEX. C INTEGER IC C PREVIOUS SIGN IN RUNS CALCULATION. C INTEGER ICI C CURRENT SIGN IN RUNS CALCULATION. C INTEGER IDRUNS C THE NUMBER OF RUNS. C INTEGER IERR C AN ERROR FLAG SET IN COMMON ERRCHK. C INTEGER IMINUS, IPLUS C COUNTS OF SIGNS OF DEVIATIONS. C INTEGER IRUN C THE NUMBER OF RUNS UP AND DOWN. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y AND WT. C REAL STS(53) C OUTPUT PARAMETER. THE VECTOR OF 53 STATISTICS COMPUTED. C ROW STATISTIC ROW STATISTIC C 1 LENGTH OF VECTOR TESTS FOR NONRANDOMNESS C 2 NUMBER OF NONZERO WEIGHTS 23 NUMBER OF RUNS UP AND DOWN C MEASURES OF LOCATION 24 EXPECTED NUMBER OF RUNS C 3 UNWEIGHTED MEAN 25 S.D. OF NUMBER OF RUNS C 4 WEIGHTED MEAN 26 MEAN SQR. SUCCESSIVE DIFF. C 5 MEDIAN 27 MEAN SQR. SUCC. DIFF./VAR. C 6 MID-RANGE DEVIATIONS FROM WTD MEAN C 7 25 P.C. UNWTD. TRIMMED MEAN 28 NUMBER OF + SIGNS C 8 25 P.C. WTD. TRIMMED MEAN 29 NUMBER OF - SIGNS C MEASURES OF DISPERSION 30 NUMBER OF RUNS C 9 STANDARD DEVIATION (S.D.) 31 EXPECTED NUMBER OF RUNS C 10 S.D. OF MEAN 32 S.D. OF RUNS C 11 RANGE 33 DIFF./S.D. OF RUNS C 12 MEAN VARIATION OTHER STATISTICS C 13 VARIANCE (VAR.) 34 MINIMUM C 14 COEFFICIENT OF VARIATION 35 MAXIMUM C CONFIDENCE INTERVALS 36 BETA 1 C 15 LOWER CONFIDENCE LIMIT, MEAN 37 BETA 2 C 16 UPPER CONFIDENCE LIMIT, MEAN 38 WTD. SUM OF VALUES C 17 LOWER CONFIDENCE LIMIT, S.D. 39 WTD. SUM OF SQUARES C 18 UPPER CONFIDENCE LIMIT, S.D. 40 WTD. SUM OF SQRD. DEVS. C LINEAR TREND STATISTICS 41 STUDENTS T C 19 SLOPE 42 WTD. SUM OF ABS. VALUES C 20 S.D. OF SLOPE 43 WTD. AVG. ABS. VALUES C 21 SLOPE/S.D. OF SLOPE = T 44-53 FREQ. DISTRIBUTION C 22 PROB ( X .GT. ABS(OBS. T)) C REAL SUMDA C INPUT PARAMETER. THE SUM OF THE ABSOLUTE VALUES OF THE C DIFFERENCES DIFF. C REAL SUMDI C INPUT PARAMETER. THE SUM OF THE PRODUCTS OF I AND THE C ITH DIFFERENCE DIFF. C REAL SUMD2 C INPUT PARAMETER. THE SUM OF THE SQUARES OF THE C DIFFERENCES DIFF. C REAL SUMD3 C INPUT PARAMETER. THE SUM OF THE CUBES OF THE C DIFFERENCES DIFF. C REAL SUMD4 C INPUT PARAMETER. THE SUM OF THE HYPERCUBES OF THE C DIFFERENCES DIFF. C REAL T C A RESIDUAL (Y(I) - MEANY) C REAL TA C A TEMPORARY VARIABLE IN THE RUNS CALCULATION. C REAL TK1, TK2 C CHI-SQUARED VALUES. C REAL Y(N) C INPUT PARAMETER. A SET OF N DATA POINTS, SORTED C INTO ASCENDING ORDER. C C C BEGIN STORAGE OF STATISTICS. C STS(1) = N STS(2) = STS(1) STS(24) = (2.0E0*STS(1)-1.0E0)/3.0E0 STS(25) = SQRT((16.0E0*STS(1)-29.0E0)/90.0E0) STS(43) = STS(42)/STS(1) C C COMPUTE RESIDUALS AND STANDARD DEVIATIONS. C ICI = 0 IPLUS = 0 IMINUS = 0 IDRUNS = 0 IC = 0 DO 30 I=1,N T = Y(I) - STS(4) IF (T.LT.0.0E0) GO TO 10 IPLUS = IPLUS + 1 ICI = +1 GO TO 20 10 IMINUS = IMINUS + 1 ICI = -1 20 IF (IC.EQ.ICI) GO TO 30 IC = ICI IDRUNS = IDRUNS + 1 30 CONTINUE STS(28) = IPLUS STS(29) = IMINUS STS(31) = 1.0E0 + (2.0E0*STS(28)*STS(29)/STS(1)) STS(32) = SQRT((2.0E0*STS(28)*STS(29)* + (2.0E0*STS(28)*STS(29) - + STS(28)-STS(29)))/ + ((STS(28)+STS(29))**2*(STS(1)-1.0E0))) STS(30) = IDRUNS STS(33) = 0.0E0 IF (STS(32).NE.0.0E0) + STS(33) = (STS(30)-STS(31))/STS(32) STS(13) = SUMD2/(STS(1)-1.0E0) STS(9) = SQRT(STS(13)) STS(10) = STS(9)/SQRT(STS(1)) IF (STS(4).NE.0.0E0) + STS(14) = 100.0E0*ABS(STS(9)/STS(4)) IF (STS(4).EQ.0.0E0) STS(14) = 0.0E0 STS(36) = 0.0E0 IF (SUMD2.GT.0.0E0) + STS(36) = (SUMD3/STS(1))**2/((SUMD2/STS(1))**3) STS(37) = 0.0E0 IF (SUMD2.GT.0.0E0) + STS(37) = (SUMD4/STS(1))/((SUMD2/STS(1))**2) STS(40) = SUMD2 STS(19) = (12.0E0*SUMDI)/(STS(1)*(STS(1)**2-1.0E0)) STS(20) = (1.0E0/(STS(1)-2.0E0)* + (12.0E0*(SUMD2/(STS(1)*(STS(1)**2-1.0E0)))- + STS(19)**2)) IF (STS(20).LE.0.0E0) STS(20) = 0.0E0 STS(20) = SQRT(STS(20)) IF (STS(20).EQ.0.0E0) STS(21) = 0.0E0 IF (STS(20).GT.0.0E0) STS(21) = STS(19)/STS(20) C STS(22) = 1.0E0 - CDFF(STS(21)*STS(21), 1.0E0, STS(1)-2.0E0) C C COMPUTE NUMBER OF RUNS IN THE DATA. C DIF = 0.0E0 IRUN = 1 TA = 0.0E0 DO 40 I=1,N IF (I.GE.N) GO TO 50 TA = Y(I+1) - Y(I) IF (TA.NE.0.0E0) GO TO 50 40 CONTINUE 50 DO 60 I=1,N IF (I.EQ.N) GO TO 60 T = Y(I+1) - Y(I) DIF = DIF + T*T IF (TA*T.GE.0.0E0) GO TO 60 TA = T IRUN = IRUN + 1 60 CONTINUE STS(23) = IRUN STS(26) = DIF/(STS(1)-1.0E0) STS(27) = 0.0E0 IF (STS(13).NE.0.0E0) + STS(27) = STS(26)/STS(13) STS(41) = 0.0E0 IF (STS(9).NE.0.0E0) + STS(41) = (STS(4)*SQRT(STS(1)))/STS(9) STS(12) = SUMDA/STS(1) T = PPFT(0.975E0, N-1) TK1 = PPFCHS(0.975E0, N-1) TK2 = PPFCHS(0.025E0, N-1) STS(15) = STS(4) - T*STS(10) STS(16) = STS(4) + T*STS(10) STS(17) = SQRT((STS(1)-1.0E0)/TK1)*STS(9) STS(18) = SQRT((STS(1)-1.0E0)/TK2)*STS(9) RETURN END *STAT2W SUBROUTINE STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2, + SUMD2, SUMD3, SUMD4, SUMW) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES FOR A VECTOR Y THE STATISTICS THAT DO C NOT REQUIRE SORTING OF THE VECTOR, THAT IS, THOSE NOT COMPUTED C BY STAT1W. WEIGHTS ARE USED IN THE CALCULATIONS. C C THIS SUBROUTINE IS BASED ON A MODIFICATION OF THE STATIS C CODE USED IN OMNITAB, VERSION 5 (6/16/72), WRITTEN BY C SALLY PEAVY. THE ORIGINAL ADAPTATION TO STARPAC WAS C DONE BY JANET DONALDSON. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMW,SUMWD2 INTEGER + N,NNZW C C ARRAY ARGUMENTS REAL + STS(53),WT(N),Y(N) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + DIF,T,TA,TK1,TK2 INTEGER + I,IC,ICI,ICOUNT,IDRUNS,IMINUS,IPLUS,IRUN,J C C EXTERNAL FUNCTIONS REAL + CDFF,PPFCHS,PPFT EXTERNAL CDFF,PPFCHS,PPFT C C INTRINSIC FUNCTIONS INTRINSIC ABS,SQRT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DIF C THE SUM OF THE DIFFERENCES BETWEEN SUCCEEDING ELEMENTS C IN Y. C INTEGER I C A LOOP INDEX. C INTEGER IC C PREVIOUS SIGN IN RUNS CALCULATION. C INTEGER ICI C CURRENT SIGN IN RUNS CALCULATION. C INTEGER ICOUNT C USED IN RUNS CALCULATIONS. C INTEGER IDRUNS C THE NUMBER OF RUNS. C INTEGER IERR C AN ERROR FLAG SET IN COMMON ERRCHK. C INTEGER IMINUS, IPLUS C COUNTS OF SIGNS OF DEVIATIONS. C INTEGER IRUN C THE NUMBER OF RUNS UP AND DOWN. C INTEGER J C A LOOP INDEX. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y AND WT. C INTEGER NNZW C INPUT PARAMETER. THE NUMBER OF POSITIVE ELEMENTS IN WT. C REAL STS(53) C OUTPUT PARAMETER. THE VECTOR OF 53 STATISTICS COMPUTED. C ROW STATISTIC ROW STATISTIC C 1 LENGTH OF VECTOR TESTS FOR NONRANDOMNESS C 2 NUMBER OF NONZERO WEIGHTS 23 NUMBER OF RUNS UP AND DOWN C MEASURES OF LOCATION 24 EXPECTED NUMBER OF RUNS C 3 UNWEIGHTED MEAN 25 S.D. OF NUMBER OF RUNS C 4 WEIGHTED MEAN 26 MEAN SQR. SUCCESSIVE DIFF. C 5 MEDIAN 27 MEAN SQR. SUCC. DIFF./VAR. C 6 MID-RANGE DEVIATIONS FROM WTD MEAN C 7 25 P.C. UNWTD. TRIMMED MEAN 28 NUMBER OF + SIGNS C 8 25 P.C. WTD. TRIMMED MEAN 29 NUMBER OF - SIGNS C MEASURES OF DISPERSION 30 NUMBER OF RUNS C 9 STANDARD DEVIATION (S.D.) 31 EXPECTED NUMBER OF RUNS C 10 S.D. OF MEAN 32 S.D. OF RUNS C 11 RANGE 33 DIFF./S.D. OF RUNS C 12 MEAN VARIATION OTHER STATISTICS C 13 VARIANCE (VAR.) 34 MINIMUM C 14 COEFFICIENT OF VARIATION 35 MAXIMUM C CONFIDENCE INTERVALS 36 BETA 1 C 15 LOWER CONFIDENCE LIMIT, MEAN 37 BETA 2 C 16 UPPER CONFIDENCE LIMIT, MEAN 38 WTD. SUM OF VALUES C 17 LOWER CONFIDENCE LIMIT, S.D. 39 WTD. SUM OF SQUARES C 18 UPPER CONFIDENCE LIMIT, S.D. 40 WTD. SUM OF SQRD. DEVS. C LINEAR TREND STATISTICS 41 STUDENTS T C 19 SLOPE 42 WTD. SUM OF ABS. VALUES C 20 S.D. OF SLOPE 43 WTD. AVG. ABS. VALUES C 21 SLOPE/S.D. OF SLOPE = T 44-53 FREQ. DISTRIBUTION C 22 PROB ( X .GT. ABS(OBS. T)) C REAL SUMDA C INPUT PARAMETER. THE SUM OF THE ABSOLUTE VALUES OF THE C DIFFERENCES DIFF. C REAL SUMDI C INPUT PARAMETER. THE SUM OF THE PRODUCTS OF I AND THE C ITH DIFFERENCE DIFF. C REAL SUMD2 C INPUT PARAMETER. THE SUM OF THE SQUARES OF THE C DIFFERENCES DIFF. C REAL SUMD3 C INPUT PARAMETER. THE SUM OF THE CUBES OF THE C DIFFERENCES DIFF. C REAL SUMD4 C INPUT PARAMETER. THE SUM OF THE HYPERCUBES OF THE C DIFFERENCES DIFF. C REAL SUMW C INPUT PARAMETER. THE SUM OF THE WEIGHTS VECTOR WT. C REAL SUMWD2 C INPUT PARAMETER. THE WEIGHTED SUM OF THE SQUARED C DIFFERENCES DIFF. C REAL T C A RESIDUAL (Y(I) - MEANY) C REAL TA C A TEMPORARY VARIABLE IN THE RUNS CALCULATION. C REAL TK1, TK2 C CHI-SQUARED VALUES. C REAL WT(N) C INPUT PARAMETER. THE VECTOR OF WEIGHTS FOR THE C Y OBSERVATIONS. C REAL Y(N) C INPUT PARAMETER. A SET OF N DATA POINTS, SORTED C INTO ASCENDING ORDER. C C C BEGIN STORAGE OF STATISTICS. C STS(1) = N STS(2) = NNZW STS(24) = (2.0E0*STS(2)-1.0E0)/3.0E0 STS(25) = SQRT((16.0E0*STS(2)-29.0E0)/90.0E0) STS(43) = STS(42)/SUMW C C COMPUTE RESIDUALS AND STANDARD DEVIATIONS. C ICI = 0 IPLUS = 0 IMINUS = 0 IDRUNS = 0 IC = 0 DO 30 I=1,N IF (WT(I).LE.0.0E0) GO TO 30 T = Y(I) - STS(4) IF (T.LT.0.0E0) GO TO 10 IPLUS = IPLUS + 1 ICI = 1 GO TO 20 10 IMINUS = IMINUS + 1 ICI = -1 20 IF (IC.EQ.ICI) GO TO 30 IC = ICI IDRUNS = IDRUNS + 1 30 CONTINUE STS(28) = IPLUS STS(29) = IMINUS STS(31) = 1.0E0 + (2.0E0*STS(28)*STS(29)/STS(2)) STS(32) = + SQRT((2.0E0*STS(28)*STS(29)*(2.0E0*STS(28)*STS(29)- + STS(28)-STS(29)))/ + ((STS(28)+STS(29))**2*(STS(2)-1.0E0))) STS(30) = IDRUNS STS(33) = 0.0E0 IF (STS(32).NE.0.0E0) + STS(33) = (STS(30)-STS(31))/STS(32) STS(13) = SUMWD2/(STS(2)-1.0E0) STS(9) = SQRT(STS(13)) STS(10) = STS(9)/(SQRT(SUMW)) IF (STS(4).NE.0.0E0) + STS(14) = 100.0E0*ABS(STS(9)/STS(4)) IF (STS(4).EQ.0.0E0) STS(14) = 0.0E0 STS(36) = 0.0E0 IF (SUMD2.NE.0.0E0) + STS(36) = (SUMD3/STS(2))**2/((SUMD2/STS(2))**3) STS(37) = 0.0E0 IF (SUMD2.NE.0.0E0) + STS(37) = (SUMD4/STS(2))/((SUMD2/STS(2))**2) STS(40) = SUMWD2 STS(19) = (12.0E0*SUMDI)/(STS(2)*(STS(2)**2-1.0E0)) STS(20) = (1.0E0/(STS(2)-2.0E0)* + (12.0E0*(SUMD2/(STS(2)*(STS(2)**2-1.0E0)))- + STS(19)**2)) IF (STS(20).LE.0.0E0) STS(20) = 0.0E0 STS(20) = SQRT(STS(20)) IF (STS(20).EQ.0.0E0) STS(21) = 0.0E0 IF (STS(20).GT.0.0E0) STS(21) = STS(19)/STS(20) C STS(22) = 1.0E0 - CDFF(STS(21)*STS(21), 1.0E0, STS(2)-2.0E0) C C COMPUTE NUMBER OF RUNS IN THE DATA. C DIF = 0.0E0 IRUN = 1 TA = 0.0E0 DO 50 I=1,N IF (I.GE.N) GO TO 60 IF (WT(I).LE.0.0E0) GO TO 50 J = I 40 J = J + 1 IF (J.GE.N) GO TO 60 IF (WT(J).LE.0.0E0) GO TO 40 TA = Y(J) - Y(I) IF (TA.NE.0.0E0) GO TO 60 50 CONTINUE 60 ICOUNT = 0 DO 80 I=1,N IF (WT(I).LE.0.0E0) GO TO 80 ICOUNT = ICOUNT + 1 IF (ICOUNT.GE.NNZW) GO TO 80 J = I 70 J = J + 1 IF (WT(J).LE.0.0E0) GO TO 70 T = Y(J) - Y(I) DIF = DIF + T*T IF (TA*T.GE.0.0E0) GO TO 80 TA = T IRUN = IRUN + 1 80 CONTINUE STS(23) = IRUN STS(26) = DIF/(STS(2)-1.0E0) STS(27) = 0.0E0 IF (STS(13).NE.0.0E0) + STS(27) = STS(26)/STS(13) STS(41) = 0.0E0 IF (STS(9).NE.0.0E0) + STS(41) = (STS(4)*SQRT(SUMW))/STS(9) STS(12) = SUMDA/STS(2) T = PPFT(0.975E0, NNZW-1) TK1 = PPFCHS(0.975E0, NNZW-1) TK2 = PPFCHS(0.025E0, NNZW-1) STS(15) = STS(4) - T*STS(10) STS(16) = STS(4) + T*STS(10) STS(17) = SQRT((STS(2)-1.0E0)/TK1)*STS(9) STS(18) = SQRT((STS(2)-1.0E0)/TK2)*STS(9) RETURN END *STATER SUBROUTINE STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE CHECKS INPUT PARAMETERS TO THE USER C CALLABLE MEMBERS OF THE STAT FAMILY OF ROUTINES C FOR ERRORS AND REPORTS ANY THAT IT FINDS, BESIDES C RETURNING A FLAG INDICATING THAT ERRORS HAVE BEEN C FOUND. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IERR,LDSTAK,N,NNZW LOGICAL + STACK,WTS C C ARRAY ARGUMENTS REAL + WT(*) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS INTEGER + LDSMIN,NZW LOGICAL + HEAD,IER1,IER2,IER3 C C LOCAL ARRAYS CHARACTER + LLDS(8)*1,LN(8)*1,LTHREE(8)*1,LWT(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERVWT,LDSCMP 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 IERR C OUTPUT PARAMETER. A FLAG INDICATING WHETHER OR C NOT AN ERROR HAS BEEN FOUND. 0 = OK, 1 = ERROR. C LOGICAL IER1 C TRUE IF N .LT. 3 C LOGICAL IER2 C TRUE IF LDSTAK .LT. (N + 13)/2.0E0 C LOGICAL IER3 C TRUE IF SOME WT .LT. 0.0E0 OR NNZW .LT. 3 C INTEGER LDSMIN C MINIMUM LENGTH OF FRAMEWORK AREA IN DOUBLE C PRECISION ELEMENTS. C INTEGER LDSTAK C INPUT PARAMETER. THE NUMBER OF LOCATIONS PROVIDED IN C THE FRAMEWORK AREA. C CHARACTER*1 LLDS(8), LN(8), LTHREE(8), LWT(8) C THE ARRAY(S) CONTAINING THE NAME(S) FO THE VARIALBE(S) CHECKED C FOR ERRORS C INTEGER N C INPUT PARAMETER. THE NUMBER OF ELEMENTS IN Y AND WT. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE C INTEGER NNZW C OUTPUT PARAMETER. IF WTS, THEN SET EQUAL TO THE C NUMBER OF VALUES IN WT WHICH ARE POSITIVE. ELSE, C UNDEFINED. C INTEGER NZW C THE NUMBER OF ZERO WEIGHTS. C LOGICAL STACK C A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE) C OR NOT (FALSE). C REAL WT(N) C INPUT PARAMETER. THE VECTOR OF WEIGHTS CORRESPONDING C TO THE VECTOR Y. C LOGICAL WTS C INPUT PARAMETER. A FLAG INDICATING WHETHER OR NOT C THERE IS REALLY A VECTOR WT (TRUE), OR ONLY A DUMMY PARAMETER C (FALSE). C C INITIALIZE NAME VECTORS C DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) / 'L', 'D', 'S', 'T', 'A', 'K', ' ', ' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), + LN(7), LN(8) / 'N', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ DATA LTHREE(1),LTHREE(2),LTHREE(3),LTHREE(4),LTHREE(5),LTHREE(6), + LTHREE(7), LTHREE(8) / 'T', 'H', 'R', 'E', 'E', ' ', ' ', ' '/ DATA LWT(1), LWT(2), LWT(3), LWT(4), LWT(5), LWT(6), + LWT(7), LWT(8) / 'W', 'T', ' ', ' ', ' ', ' ', ' ', ' '/ C C INITIALIZE ERROR FLAGS C IER1 = .FALSE. IER2 = .FALSE. IER3 = .FALSE. C IERR = 0 C HEAD = .TRUE. C C CHECK TO SEE THAT THERE ARE AT LEAST THREE DATA POINTS. C CALL EISGE(NMSUB, LN, N, 3, 2, HEAD, IER1, LTHREE) C C CHECK TO SEE THAT AN AMOUNT OF WORK AREA EQUAL C IN LENGTH TO THE REQUIREMENTS OF THE PERMUTATION C VECTOR WILL BE AVAILABLE. C IF (STACK) THEN CALL LDSCMP(1, 0, N, 0, 0, 0, 'S', 0, LDSMIN) CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, IER2, LLDS) END IF C C IF THERE ARE WEIGHTS C CHECK TO SEE THAT AT LEAST THREE DATA ITEMS HAVE NONZERO WEIGHTS. C NNZW = N IF (WTS) THEN CALL ERVWT(NMSUB, LWT, WT, N, 3, HEAD, NNZW, NZW, 1, IER3, + LTHREE) END IF C C SEE IF ANY ERRORS WERE FOUND. C IF (IER1 .OR. IER2 .OR. IER3) IERR = 1 RETURN END *STAT SUBROUTINE STAT(Y, N, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR C Y, WITH NO WEIGHTS SPECIFIED. ONE PAGE OF AUTOMATIC C PRINTOUT IS PRODUCED. C C WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C (EXTENSIVE REVISION OF OLDER VERSION) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1 INTEGER + IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW LOGICAL + STACK,WTS C C LOCAL ARRAYS REAL + STS(53),WT(1) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,STAT2,STATER,STKCLR,STKSET, + SUMBS,SUMDS,SUMID,SUMOT,SUMSS,SUMTS C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE PERCENTAGE TO BE TRIMMED OFF EACH END OF Y FOR THE C TRIMMED MEANS CALCULATIONS. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IDP C THE CODE VALUE FOR DOUBLE PRECISION FOR FRAMEWORK. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION C VECTOR. C INTEGER MID C THE INDEX OF THE (AN) ELEMENT OF Y CLOSEST TO ZERO, WHEN C Y HAS BEEN SORTED. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NNZW C NUMBER OF NONZERO WEIGHTS. C LOGICAL STACK C A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE) C OR NOT (FALSE). C REAL STS(53) C THE VECTOR OF THE 53 STATISTICS COMPUTED. C REAL SUMDA C THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN. C REAL SUMDI C THE SUM OF THE PRODUCTS OF THE INDICES AND THE DIFFERENCES. C REAL SUMD2 C THE SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMD3 C THE SUM OF THE CUBES OF THE DIFFERENCES. C REAL SUMD4 C THE SUM OF THE 4TH POWERS OF THE DIFFERENCES. C REAL SUMT1 C THE SUM OF THE ALPHA TRIMMED ARRAY Y. C REAL WT(1) C THE DUMMY WEIGHTS VECTOR. C LOGICAL WTS C A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE) C OR NOT (FALSE). C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'T', 'A', 'T', ' ', ' '/ C DATA ALPHA /0.25E0/ DATA IDP /4/ DATA IINT /2/ DATA WTS /.FALSE./ DATA STACK /.TRUE./ C C CHECK FOR ERRORS IN THE INPUT PARAMETERS C CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR) IF (IERR.NE.0) THEN C C PRINT ERROR MESSAGE. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN END IF C C SET UP FRAMEWORK AREA. C CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP LSORT, THE PERMUTATION VECTOR. C LSORT = STKGET(N,IINT) CALL GENI(ISTAK(LSORT), N, 1, 1) C C SORT THE VECTOR Y. C CALL SRTIR(ISTAK(LSORT), N, Y) C C COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY. C CALL STAT1(Y, N, STS(5), STS(34), STS(35), STS(6), + STS(11), 10, 0.0E0, 0.0E0, STS(44)) C C CALCULATE SUMS OF THE SORTED ARRAY. C CALL SUMBS(Y, N, 1, MID, N) CALL SUMSS(Y, N, 1, MID, N, STS(38), STS(39), STS(42), + STS(3)) STS(4) = STS(3) CALL SUMTS(Y, N, ALPHA, SUMT1, STS(7)) STS(8) = STS(7) CALL SUMDS(Y, N, 1, MID, N, STS(3), SUMDA, SUMD2, SUMD3, SUMD4) C C RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER. C CALL SRTRI(Y, N, ISTAK(LSORT)) C C COMPUTE REST OF STATISTICS. C CALL SUMID(Y, N, STS(3), SUMDI) CALL STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4) CALL SUMOT(STS, N, N, WTS) C C RETURN THE VECTOR LSORT. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STAT (Y, N, LDSTAK)') END *STATS SUBROUTINE STATS(Y, N, LDSTAK, STS, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR C Y, WITH NO WEIGHTS SPECIFIED. ONE PAGE OF AUTOMATIC C PRINTOUT IS PRODUCED. C C WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C (EXTENSIVE REVISION OF OLDER VERSION) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N,NPRT C C ARRAY ARGUMENTS REAL + STS(53),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1 INTEGER + IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW LOGICAL + STACK,WTS C C LOCAL ARRAYS REAL + WT(1) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,SRTIR,SRTRI,STAT1,STAT2,STATER,STKCLR,STKSET, + SUMBS,SUMDS,SUMID,SUMOT,SUMSS,SUMTS C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE PERCENTAGE TO TRIM FROM EACH END IN THE TRIMMED C MEANS. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IDP C FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK. 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION C VECTOR. C INTEGER MID C IN THE SORTED ARRAY Y, A POINT EQUAL TO OR THE POINT C CLOSEST TO, ZERO. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C INPUT PARAMETER. FLAG TO CONTROL OUTPUT. C 0 MEANS NO OUTPUT. OTHER VALUES MEAN OUTPUT. C INTEGER NNZW C NUMBER OF NONZERO WEIGHTS. C LOGICAL STACK C A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE) C OR NOT (FALSE). C REAL STS(53) C OUTPUT PARAMETER. THE VECTOR OF THE 53 STATISTICS COMPUTED. C REAL SUMDA C THE SUM OF THE ABSOLUTE VALUES OF THE DIFFERENCES FROM C THE MEAN. C REAL SUMDI C THE SUM OF THE PRODUCTS OF THE INDEX AND DIFFERENCES. C REAL SUMD2 C THE SUM OF THE SQUARE OF THE DIFFERENCES. C REAL SUMD3 C THE SUM OF THE CUBE OF THE DIFFERENCES. C REAL SUMD4 C THE SUM OF THE 4TH POWERS OF THE DIFFERENCES. C REAL SUMT1 C THE TRIMMED UNWEIGHTED SIMPLE SUM OF ELEMENTS IN Y. C REAL WT(1) C THE DUMMY WEIGHTS VECTOR. C LOGICAL WTS C A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE) C OR NOT (FALSE). C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'T', 'A', 'T', 'S', ' '/ C DATA ALPHA /0.25E0/ DATA IDP /4/ DATA IINT /2/ DATA WTS /.FALSE./ DATA STACK /.TRUE./ C C CHECK FOR ERRORS IN THE INPUT PARAMETERS. C CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR) IF (IERR.NE.0) THEN C C SET UP THE OUTPUT UNIT NUMBER. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN END IF C C SET UP FRAMEWORK AREA C CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP LSORT, THE PERMUTATION VECTOR. C LSORT = STKGET(N,IINT) CALL GENI(ISTAK(LSORT), N, 1, 1) C C SORT THE VECTOR Y. C CALL SRTIR(ISTAK(LSORT), N, Y) C C COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY. C CALL STAT1(Y, N, STS(5), STS(34), STS(35), STS(6), + STS(11), 10, 0.0E0, 0.0E0, STS(44)) C C CALCULATE SUMS OF THE SORTED ARRAY. C CALL SUMBS(Y, N, 1, MID, N) CALL SUMSS(Y, N, 1, MID, N, STS(38), STS(39), STS(42), + STS(3)) STS(4) = STS(3) CALL SUMTS(Y, N, ALPHA, SUMT1, STS(7)) STS(8) = STS(7) CALL SUMDS(Y, N, 1, MID, N, STS(3), SUMDA, SUMD2, SUMD3, SUMD4) C C RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER. C CALL SRTRI(Y, N, ISTAK(LSORT)) C C COMPUTE REST OF STATISTICS. C CALL SUMID(Y, N, STS(3), SUMDI) CALL STAT2(Y, N, STS, SUMDA, SUMDI, SUMD2, SUMD3, SUMD4) IF (NPRT.NE.0) CALL SUMOT(STS, N, N, WTS) C C RETURN THE VECTOR LSORT. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STATS (Y, N, LDSTAK, STS, NPRT)') END *STATW SUBROUTINE STATW(Y, WT, N, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A C VECTOR Y, WITH WEIGHTS SPECIFIED. ONE PAGE OF AUTOMATIC C PRINTOUT IS PRODUCED. C C WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C (EXTENSIVE REVISION OF OLDER VERSION) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N C C ARRAY ARGUMENTS REAL + WT(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,SUM1,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1,SUMW,SUMWD2, + SUMWT1 INTEGER + IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW LOGICAL + STACK,WTS C C LOCAL ARRAYS REAL + STS(53) INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,SRTIRR,SRTRRI,STAT1W,STAT2W,STATER,STKCLR, + STKSET,SUMBS,SUMIDW,SUMOT,SUMWDS,SUMWSS,SUMWTS C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE PERCENTAGE OF POINTS TO BE TRIMMED FROM EITHER END OF C Y IN CALCULATING THE TRIMMED MEANS. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IDP C FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK. 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION C VECTOR. C INTEGER MID C THE INDEX OF A ZERO ELEMENT IN THE SORTED Y, OR OF THE C ELEMENT CLOSEST TO ZERO. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NNZW C NUMBER OF NONZERO WEIGHTS. C LOGICAL STACK C A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE) C OR NOT (FALSE). C REAL STS(53) C THE VECTOR OF THE 53 STATISTICS COMPUTED. C REAL SUMDA C THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN. C REAL SUMDI C THE SUM OF THE PRODUCTS OF THE INDICES AND THE C DIFFERENCES. C REAL SUMD2 C THE SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMD3 C THE SUM OF THE CUBES OF THE DIFFERENCES. C REAL SUMD4 C THE SUM OF THE 4TH POWERS OF THE DIFFERENCES. C REAL SUMT1 C THE SUM OF THE ALPHA TRIMMED ARRAY Y. C REAL SUMW C THE SUM OF THE WEIGHTS VECTOR WT. C REAL SUMWD2 C THE WEIGHTED SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMWT1 C THE WEIGHTED SUM OF THE ALPHA TRIMMED ARRAY. C REAL SUM1 C THE UNWEIGHTED SUM OF THE ELEMENTS OF Y. C REAL WT(N) C INPUT PARAMETER. THE WEIGHTS VECTOR. C LOGICAL WTS C A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE) C OR NOT (FALSE). C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'T', 'A', 'T', 'W', ' '/ C DATA ALPHA /0.25E0/ DATA IDP /4/ DATA IINT /2/ DATA WTS /.TRUE./ DATA STACK /.TRUE./ C C CHECK FOR ERRORS IN THE INPUT PARAMETERS. C CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR) IF (IERR.NE.0) THEN C C PRINT ERROR MESSAGE. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN END IF C C SET UP FRAMEWORK AREA. C CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP LSORT, THE PERMUTATION VECTOR. C LSORT = STKGET(N,IINT) CALL GENI(ISTAK(LSORT), N, 1, 1) C C SORT THE VECTOR Y. C CALL SRTIRR(ISTAK(LSORT), WT, N, Y) C C COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY. C CALL STAT1W(Y, WT, N, STS(5), STS(34), STS(35), STS(6), + STS(11), 10, 0.0E0, 0.0E0, STS(44), NNZW) C C COMPUTED VARIOUS SUMS IN THE SORTED ARRAY Y. C CALL SUMBS(Y, N, 1, MID, N) CALL SUMWSS(Y, WT, N, 1, MID, N, NNZW, SUM1, STS(38), STS(39), + STS(42), SUMW, STS(3), STS(4)) CALL SUMWTS(Y, WT, N, NNZW, ALPHA, SUMT1, SUMWT1, STS(7), + STS(8)) CALL SUMWDS(Y, WT, N, 1, MID, N, STS(4), SUMDA, SUMWD2, SUMD2, + SUMD3, SUMD4) C C RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER. C CALL SRTRRI(Y, WT, N, ISTAK(LSORT)) C C COMPUTE REST OF STATISTICS. C CALL SUMIDW(Y, WT, N, STS(4), SUMDI) CALL STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2, SUMD2, + SUMD3, SUMD4, SUMW) CALL SUMOT(STS, N, NNZW, WTS) C C RETURN THE VECTOR LSORT. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STATW (Y, WT, N, LDSTAK)') END *STATWS SUBROUTINE STATWS(Y, WT, N, LDSTAK, STS, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE COMPUTES 53 DIFFERENT STATISTICS FOR A VECTOR C Y, WITH WEIGHTS SPECIFIED. ONE PAGE OF AUTOMATIC C PRINTOUT IS PRODUCED. C C WRITTEN BY - JANET R. DONALDSON, JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C (EXTENSIVE REVISION OF OLDER VERSION) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + LDSTAK,N,NPRT C C ARRAY ARGUMENTS REAL + STS(53),WT(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,SUM1,SUMD2,SUMD3,SUMD4,SUMDA,SUMDI,SUMT1,SUMW,SUMWD2, + SUMWT1 INTEGER + IDP,IINT,IPRT,LSORT,MID,NALL0,NNZW LOGICAL + STACK,WTS C C LOCAL ARRAYS INTEGER + ISTAK(12) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL GENI,IPRINT,SRTIRR,SRTRRI,STAT1W,STAT2W,STATER,STKCLR, + STKSET,SUMBS,SUMIDW,SUMOT,SUMWDS,SUMWSS,SUMWTS C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C THE PERCENTAGE TO BE TRIMMED FROM EACH END OF THE C SORTED ARRAY Y. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C INTEGER IDP C FRAMEWORK CODE VALUE FOR DOUBLE PRECISION NUMBERS. C INTEGER IERR C THE CODE INDICATING WHETHER OR NOT AN ERROR HAS C BEEN DISCOVERED. 0 MEANS NO ERROR, NOT 0 MEANS C SOME ERROR EXISTS. C INTEGER IINT C THE CODE VALUE FOR INTEGER FOR FRAMEWORK. 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 LDSTAK C INPUT PARAMETER. THE NUMBER OF DOUBLE PRECISION C ELEMENTS DIMENSIONED FOR DSTAK IN THE USER PROGRAM. C INTEGER LSORT C THE STARTING LOCATION IN ISTAK OF THE PERMUTATION VECTOR. C INTEGER MID C THE INDEX OF A ZERO ELEMENT IN THE SORTED Y, OR OF THE C ELEMENT CLOSEST TO ZERO. C INTEGER N C INPUT PARAMETER. THE LENGTH OF Y. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THIS ROUTINE C WAS CALLED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C INPUT PARAMETER. THE CODE INDICATING WHETHER PRINTOUT C IS DESIRED. 0 MEANS NO PRINTOUT, NOT 0 MEANS PRINTOUT. C INTEGER NNZW C NUMBER OF NONZERO WEIGHTS. C LOGICAL STACK C A FLAG INDICATING WHETHER THIS ROUTINE USES THE STACK (TRUE) C OR NOT (FALSE). C REAL STS(53) C OUTPUT PARAMETER. THE VECTOR OF THE 53 STATISTICS COMPUTED. C REAL SUMDA C THE SUM OF THE ABSOLUTE DIFFERENCES FROM THE MEAN. C REAL SUMDI C THE SUM OF THE PRODUCTS OF THE INDICES AND THE C DIFFERENCES. C REAL SUMD2 C THE SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMD3 C THE SUM OF THE CUBES OF THE DIFFERENCES. C REAL SUMD4 C THE SUM OF THE 4TH POWERS OF THE DIFFERENCES. C REAL SUMT1 C THE SUM OF THE ALPHA TRIMMED ARRAY Y. C REAL SUMW C THE SUM OF THE WEIGHTS VECTOR WT. C REAL SUMWD2 C THE WEIGHTED SUM OF THE SQUARES OF THE DIFFERENCES. C REAL SUMWT1 C THE WEIGHTED SUM OF THE ALPHA TRIMMED ARRAY. C REAL SUM1 C THE SUM OF THE ELEMENTS OF X. A DUMMY VARIABLE. C REAL WT(N) C INPUT PARAMETER. THE WEIGHTS VECTOR. C LOGICAL WTS C A FLAG INDICATING WHETHER THERE ARE WEIGHTS (TRUE) C OR NOT (FALSE). C REAL Y(N) C INPUT PARAMETER. THE VECTOR OF DATA POINTS ON WHICH C THE STATISTICS ARE COMPUTED. Y IS SORTED, BUT RESTORED C TO ITS ORIGINAL ORDER AFTERWARDS. C C C INITIALIZE NAME VECTORS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'T', 'A', 'T', 'W', 'S'/ C DATA ALPHA /0.25E0/ DATA IDP /4/ DATA IINT /2/ DATA WTS /.TRUE./ DATA STACK /.TRUE./ C C CHECK FOR ERRORS IN THE INPUT PARAMETERS. C CALL STATER(NMSUB, WT, N, LDSTAK, WTS, NNZW, STACK, IERR) IF (IERR.NE.0) THEN C C PRINT ERROR MESSAGE. C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN END IF C C SET UP FRAMEWORK AREA. C CALL STKSET (LDSTAK, IDP) NALL0 = STKST(1) C C SET UP LSORT, THE PERMUTATION VECTOR. C LSORT = STKGET(N,IINT) CALL GENI(ISTAK(LSORT), N, 1, 1) C C SORT THE VECTOR Y CARRYING ALONG THE CONTENTS OF THE VECTOR C ISTAK(LSORT). C CALL SRTIRR(ISTAK(LSORT), WT, N, Y) C C COMPUTE THE STATISTICS WHICH USE A SORTED ARRAY. C CALL STAT1W(Y, WT, N, STS(5), STS(34), STS(35), STS(6), + STS(11), 10, 0.0E0, 0.0E0, STS(44), NNZW) C C COMPUTED VARIOUS SUMS IN THE SORTED ARRAY Y. C CALL SUMBS(Y, N, 1, MID, N) CALL SUMWSS(Y, WT, N, 1, MID, N, NNZW, SUM1, STS(38), STS(39), + STS(42), SUMW, STS(3), STS(4)) CALL SUMWTS(Y, WT, N, NNZW, ALPHA, SUMT1, SUMWT1, STS(7), + STS(8)) CALL SUMWDS(Y, WT, N, 1, MID, N, STS(4), SUMDA, SUMWD2, SUMD2, + SUMD3, SUMD4) C C RESTORE THE VECTOR Y TO ITS ORIGINAL ORDER. C CALL SRTRRI(Y, WT, N, ISTAK(LSORT)) C C COMPUTE REST OF STATISTICS. C CALL SUMIDW(Y, WT, N, STS(4), SUMDI) CALL STAT2W(Y, WT, N, NNZW, STS, SUMDA, SUMDI, SUMWD2, SUMD2, + SUMD3, SUMD4, SUMW) IF (NPRT.NE.0) CALL SUMOT(STS, N, NNZW, WTS) C C RETURN THE VECTOR LSORT. C CALL STKCLR(NALL0) RETURN C C FORMAT STATEMENTS. C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STATWS (Y, WT, N, LDSTAK, STS, NPRT)') 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 COMMENCE BODY OF ROUTINE C NALLN = STKST(1) CALL STKREL (NALLN - NALL0) RETURN 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,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED C C LOCAL ARRAYS INTEGER + ISIZE(5),ISTAK(12) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 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 CALL IPRINT(IPRT) WRITE(IPRT, 1000) 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 1000 FORMAT(20H DSTAK IS TOO SHORT.) C 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 + IN,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED C C LOCAL ARRAYS INTEGER + ISTAK(12) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 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 CALL IPRINT(IPRT) WRITE (IPRT, 1000) RETURN C 30 IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT, 1010) RETURN C 40 IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT, 1020) LOUT RETURN C C FORMAT STATEMENTS C 1000 FORMAT (///18H ***** ERROR *****// + 50H DSTAK BOOKKEEPING ELEMENTS HAVE BEEN OVERWRITTEN.) 1010 FORMAT (///18H ***** ERROR *****// + 52H ATTEMPT HAS BEEN MADE TO DE-ALLOCATE A NON-EXISTANT, + 21H ALLOCATION IN DSTAK.) 1020 FORMAT (///18H ***** ERROR *****// + 35H THE POINTER FOR ALLOCATION NUMBER , I3, 9H HAS BEEN, + 13H OVERWRITTEN.) 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 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 REAL 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 *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 INTEGER + IPRT C C LOCAL ARRAYS INTEGER + ISTAK(12),ISTATS(4) C C EXTERNAL SUBROUTINES 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 C COMMENCE BODY OF ROUTINE C IF (NFACT .GT. 0 .AND. NFACT .LT. 6) GO TO 10 C C REPORT ERROR STATUS C CALL IPRINT (IPRT) WRITE (IPRT, 1000) IPRT 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 1000 FORMAT (///18H ***** ERROR *****// + 24H ILLEGAL STACK STATISTIC, I5, 11H REQUESTED.) 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 C STOPX = .FALSE. RETURN 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 REAL + ABSTOL,RELTOL,STP,STPLOW,STPMID,STPUP INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS REAL + 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 REAL + Q C C LOCAL SCALARS REAL + FACTOR,STPNEW,TEMP INTEGER + NCOUNT LOGICAL + DONE,FIRST C C EXTERNAL SUBROUTINES EXTERNAL CMPFD,ICOPY,RELCOM,SCOPY C C INTRINSIC FUNCTIONS INTRINSIC ABS,SIGN C C COMMON BLOCKS COMMON /NOTOPT/Q C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 REAL FACTOR C A FACTOR USED IN COMPUTING THE STEP SIZE. C REAL FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C REAL 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL 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 REAL Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C REAL RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C REAL STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C REAL STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C REAL STPNEW C THE VALUE OF THE NEW STEP SIZE BEING TESTED. C REAL STPUP C THE UPPER LIMIT ON THE STEP SIZE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. 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.0E0, PAR(J)) FACTOR = 10.0E0 ELSE C STPNEW = STPLOW * SIGN(1.0E0, PAR(J)) FACTOR = 0.1E0 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 SCOPY(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.0E0 .AND. ABS(STPNEW).GT.ABS(STP)) + .OR. + (FACTOR.LT.1.0E0 .AND. ABS(STPNEW).LT.ABS(STP))) + DONE = .TRUE. END IF C IF (DONE) THEN RETURN ELSE GO TO 60 END IF C 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 REAL + EXM INTEGER + ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT LOGICAL + HEAD,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + 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 REAL 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 REAL 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL 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 RETURN C END *STPCNT SUBROUTINE STPCNT(XM, N, M, IXM, MDL, PAR, NPAR, STP, + EXMPT, NETA, SCALE, LSCALE, NPRT, HDR, PAGE, WIDE, ISUBHD, + HLFRPT, PRTFXD, IFIXED, LIFIXD) 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 REAL + EXMPT INTEGER + ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),SCALE(LSCALE),STP(NPAR),XM(IXM,M) INTEGER + IFIXED(LIFIXD) C C SUBROUTINE ARGUMENTS EXTERNAL HDR,MDL C C SCALARS IN COMMON REAL + Q INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + 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 REAL + RSTAK(12) INTEGER + ISTAK(12) C C EXTERNAL FUNCTIONS REAL + R1MACH INTEGER + STKGET,STKST EXTERNAL R1MACH,STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN,STPOUT C C INTRINSIC FUNCTIONS INTRINSIC ABS,INT,LOG10,MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR 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 REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL 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 REAL EXMPT C THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED C NUMERICAL DRVATIVES 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 REAL 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 STEP SIZE SELECTION C ROUTINE HAS ALREADY PRINTED PART OF THE INITIAL SUMMARY (TRUE) C 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 .EQ. 1, ERRORS HAVE BEEN 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 ISTAK OF C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE C PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED. 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 C IFIXED(I).EQ.0, 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 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 THE INDEPENDENT VARIABLE ARRAY. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER LIFIXD C THE LENGTH OF THE VECTOR IFIXED. C INTEGER LSCALE C THE LENGTH 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 THE NUMBER OF STACK ALLOCATIONS ON ENTRY. C INTEGER NDD C THE NUMBER OF DECIMAL DIGITS CARRIED FOR A REAL C NUMBERS. 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 USER SUPPLIED 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 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 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 A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. 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 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 REAL Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL SCL C THE ACTUAL TYPICAL SIZE USED. C REAL STP(NPAR) C THE SELECTED STEP SIZES. C REAL 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 REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C C NALL0 = STKST(1) C FPLRS = R1MACH(4) IFP = 3 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(MAX(N,NPAR), IFP) FD = STKGET(N, IFP) FDLAST = STKGET(N, IFP) FDSAVE = STKGET(N, IFP) PV = STKGET(N, IFP) PVMCD = STKGET(N, IFP) PVNEW = STKGET(N, IFP) PVPCD = STKGET(N, IFP) PVSTP = STKGET(N, IFP) PVTEMP = STKGET(N, IFP) C IF (IERR .EQ. 1) RETURN C PARTMP = CD C C SET UP IFIXD C IF (IFIXED(1).LT.0) THEN CALL SETIV(ISTAK(IFIXD), NPAR, 0) ELSE CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1) END IF 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.0E0 ** (-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.25E0), 0.01E0) C EXM = EXMPT IF ((EXM.LT.0.0E0) .OR. (EXM.GT.1.0E0)) EXM = 0.10E0 NEXMPT = EXM * N IF (EXM .NE. 0.0E0) 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 IF (ISTAK(IFIXD-1+J).EQ.0) THEN IF (SCALE(1).LE.0.0E0) THEN IF (PAR(J).EQ.0.0E0) THEN SCL = 1.0E0 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 ELSE STP(J) = 0.0 END IF 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)) NFAILJ = NFAILJ + 1 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 *STPDRV SUBROUTINE STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, + STP, NETA, EXMPT, SCALE, LSCALE, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE DRIVER ROUTINE FOR SELECTING STEP SIZES C TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES C OF THE NUMERICAL DERIVATIVES. 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 REAL + EXMPT INTEGER + IXM,LDSTAK,LSCALE,M,N,NETA,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),STP(*),XM(*) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + ISUBHD,LIFIXD LOGICAL + HLFRPT,PAGE,PRTFXD,WIDE C C LOCAL ARRAYS INTEGER + IFIXED(1) C C EXTERNAL SUBROUTINES EXTERNAL STKSET,STPCNT,STPER,STPHDR C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL EXMPT C THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED C NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXCEPTED C FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. C LOGICAL HLFRPT C THE VARIABLE WHICH INDICATES WHETHER THE STEP SIZE SELECTION C ROUTINE HAS ALREADY PRINTED PART OF THE INITIAL SUMMARY (TRUE) C 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 .EQ. 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. IF C IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED. IF C IFIXED(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED. C INTEGER ISUBHD C AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LIFIXD C THE LENGTH OF THE VECTOR IFIXED. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. 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 A GIVEN SECTION OF C THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN 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 REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C REAL STP(NPAR) C THE SELECTED STEP SIZES. C EXTERNAL STPHDR C THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING C LOGICAL WIDE C THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD C BE FULL WIDTH (TRUE) OR NOT (FALSE). C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE ARRAY C C C PERFORM ERROR CHECKING C CALL STPER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE) C IF (IERR.NE.0) RETURN C CALL STKSET(LDSTAK, 4) C PAGE = .FALSE. WIDE = .TRUE. ISUBHD = 0 C PRTFXD = .FALSE. IFIXED(1) = -1 LIFIXD = 1 C C PASS CONTROL OF STEP SIZE SELECTION TO SUBROUTINE STPCNT C CALL STPCNT(XM, N, M, IXM, MDL, PAR, NPAR, STP, EXMPT, NETA, + SCALE, LSCALE, NPRT, STPHDR, PAGE, WIDE, ISUBHD, HLFRPT, + PRTFXD, IFIXED, LIFIXD) C RETURN C END *STPER SUBROUTINE STPER(NMSUB, N, M, IXM, NPAR, LDSTAK, SCALE, LSCALE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR STEP SIZE SELECTION C 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 + IXM,LDSTAK,LSCALE,M,N,NPAR C C ARRAY ARGUMENTS REAL + SCALE(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,LDSMIN,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERROR(10) CHARACTER + LIXM(8)*1,LLDS(8)*1,LM(8)*1,LN(8)*1,LNPAR(8)*1, + LONE(8)*1,LSCL(8)*1,LZERO(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,ERVGT,LDSCMP C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR(10) 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 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 WERE DETECTED. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. 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 LIXM(8), LLDS(8), LM(8), LN(8), LNPAR(8), LONE(8), C + LSCL(8), LZERO(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S) C CHECKED FOR ERRORS. C INTEGER LSCALE C THE LENGTH OF VECTOR SCALE. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND. C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C C SET UP NAME ARRAYS C DATA LIXM(1), LIXM(2), LIXM(3), LIXM(4), LIXM(5), LIXM(6), + LIXM(7), LIXM(8) /'I','X','M',' ',' ',' ',' ',' '/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LM(1), LM(2), LM(3), LM(4), LM(5), LM(6), LM(7), LM(8) /'M', + ' ',' ',' ',' ',' ',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ 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) /' ',' ','O','N','E',' ',' ', + ' '/ DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5), + LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ', + ' '/ 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,10 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, LM, M, 1, 2, HEAD, ERROR(2), LONE) C CALL EISGE(NMSUB, LIXM, IXM, N, 3, HEAD, ERROR(3), LN) C CALL EISGE(NMSUB, LNPAR, NPAR, 1, 2, HEAD, ERROR(4), LONE) C CALL LDSCMP(14, 0, 2*(N+NPAR), 0, 0, 0, 'S', 9*N + MAX(N,NPAR), + LDSMIN) C IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(4))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(5), + LLDS) C CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0E0, 0, HEAD, 6, NV, + ERROR(9), LZERO) C C DO 20 I=1,10 IF (ERROR(I)) GO TO 30 20 CONTINUE RETURN C 30 CONTINUE IERR = 1 RETURN C END *STPHDR SUBROUTINE STPHDR(PAGE, WIDE, ISUBHD) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE C STEP SIZE SELECTION 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 + ISUBHD LOGICAL + PAGE,WIDE C C LOCAL SCALARS INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 FULL WIDTH (TRUE) OR NOT (FALSE). C CALL IPRINT(IPRT) IF (PAGE) WRITE (IPRT, 1020) CALL VERSP(WIDE) IF (PAGE) WRITE (IPRT,1000) IF (.NOT.PAGE) WRITE (IPRT,1010) PAGE = .TRUE. C IF (ISUBHD.EQ.0) RETURN C GO TO (10), ISUBHD C 10 WRITE (IPRT, 1030) C RETURN C C FORMAT STATEMENTS FOR PAGE HEADINGS C 1000 FORMAT (32H+DERIVATIVE STEP SIZE SELECTION,, + 10H CONTINUED) 1010 FORMAT ('+', 34(1H*)/ 35H * DERIVATIVE STEP SIZE SELECTION */ + 1X, 34(1H*)) 1020 FORMAT ('1') 1030 FORMAT (//30H SUMMARY OF INITIAL CONDITIONS/ 1X, 30('-')) END *STPLS1 SUBROUTINE STPLS1(N, M, IXM, PAR, NPAR, NETA, EXMPT, SCALE, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE C ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY. 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 REAL + EXMPT INTEGER + IXM,M,N,NETA,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(10),SCALE(10) C C LOCAL SCALARS INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL 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 IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY. C INTEGER M C THE NUMBER OF INDEPENDENT VARIABLES. C INTEGER N C THE NUMBER OF OBSERVATIONS. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C INTEGER NPRT C THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS C TO BE PROVIDED. C REAL PAR(10) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL SCALE(10) C A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS. C PAR(1) = 0.0E0 PAR(2) = 3.125E0 PAR(3) = 1.0E0 PAR(4) = 2.0E0 C N = 101 M = 1 IXM = 200 NPAR = 4 DO 10 I=1,10 SCALE(I) = 1.0E0 10 CONTINUE NETA = 0 EXMPT = 0.0E0 NPRT = 1 C RETURN C END *STPLS2 SUBROUTINE STPLS2(NPAR, STP) C C LATEST REVISION - 03/15/90 (JRD) C C SET UP PROBLEM SPECIFICATION FOR TESTING THE USER CALLABLE C ROUTINES IN THE (LEAST SQUARES) STEP SIZE SELECTION FAMILY. 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 + NPAR C C ARRAY ARGUMENTS REAL + STP(NPAR) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C 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 WERE DETECTED. C INTEGER NPAR C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C REAL STP(NPAR) C THE STEP SIZE ARRAY. C DO 10 I=1,NPAR STP(I) = -1.0E0 10 CONTINUE C IERR = -1 C RETURN C END *STPLSC SUBROUTINE STPLSC(XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP, + NETA, EXMPT, SCALE, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR SELECTING STEP SIZES C TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES C OF THE NUMERICAL DERIVATIVES FOR THE NONLINEAR LEAST SQUARES C ROUTINES (LONG CALL). 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 REAL + EXMPT INTEGER + IXM,LDSTAK,M,N,NETA,NPAR,NPRT C C ARRAY ARGUMENTS REAL + PAR(*),SCALE(*),STP(*),XM(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS INTEGER + IPRT,LSCALE C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,STPDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL 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 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 WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C REAL SCALE(NPAR) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL STP(NPAR) C THE SELECTED STEP SIZES. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE ARRAY C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'S','T','P','L','S','C'/ C C SET LENGTH OF VECTOR SCALE. C LSCALE = NPAR C C PASS CONTROL TO STEP SIZE SELECTION DRIVER C CALL STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP, + NETA, EXMPT, SCALE, LSCALE, NPRT) C IF (IERR.NE.1) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STPLSC (XM, N, M, IXM, NLSMDL, PAR, NPAR, LDSTAK,', + ' STP,'/ + ' + NETA, EXMPT, SCALE, NPRT)') END *STPLS SUBROUTINE STPLS(XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE SUBROUTINE FOR SELECTING STEP SIZES C TO BE USED IN COMPUTING FORWARD DIFFERENCE QUOTIENT ESTIMATES C OF THE NUMERICAL DERIVATIVES FOR THE NONLINEAR LEAST SQUARES C ROUTINES (SHORT CALL). 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,LDSTAK,M,N,NPAR C C ARRAY ARGUMENTS REAL + PAR(*),STP(*),XM(*) C C SUBROUTINE ARGUMENTS EXTERNAL MDL C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + EXMPT INTEGER + IPRT,LSCALE,NETA,NPRT C C LOCAL ARRAYS REAL + SCALE(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,STPDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL EXMPT C THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED C NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXCEPTED C FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA. 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 WERE DETECTED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IXM C THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM. C INTEGER LDSTAK C THE LENGTH OF THE ARRAY DSTAK. C INTEGER LSCALE C THE LENGTH 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 N C THE NUMBER OF OBSERVATIONS. C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL. C CHARACTER*1 NMSUB(6) C THE NAME OF THE SUBROUTINE CALLING THE ERROR CHECKING C SUBROUTINES. C INTEGER NPAR C THE NUMBER OF PARAMETERS IN THE MODEL. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C REAL SCALE(1) C A DUMMY VECTOR USED TO DESIGNATE USE OF THE DEFAULT VALUES OF C THE TYPICAL SIZE OF THE PARAMETERS. C REAL STP(NPAR) C THE SELECTED STEP SIZES. C REAL XM(IXM,M) C THE INDEPENDENT VARIABLE ARRAY C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'S','T','P','L','S',' '/ C C SET UP DEFAULT VALUES C EXMPT = 0.1E0 NETA = 0 SCALE(1) = 0.0E0 LSCALE = 1 NPRT = 1 C C PASS CONTROL TO STEP SIZE SELECTION DRIVER C CALL STPDRV(NMSUB, XM, N, M, IXM, MDL, PAR, NPAR, LDSTAK, STP, + NETA, EXMPT, SCALE, LSCALE, NPRT) C IF (IERR.NE.1) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL STPLS (XM, N, M, IXM, NLSMDL, PAR, NPAR, LDSTAK,', + ' STP)') 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 REAL + ETA,RELTOL,SCALE,STP INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS REAL + 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 REAL + Q C C LOCAL SCALARS REAL + ABSTOL,CURVE,ETA3,FPLRS,PARMX,PVMEAN,PVTYP,STPCD,STPLOW, + STPMID,STPUP,TAUABS,TEMP,THIRD INTEGER + I C C EXTERNAL FUNCTIONS REAL + R1MACH EXTERNAL R1MACH 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 REAL ABSTOL C THE ABSOLUTE AGREEMENT TOLERANCE. C REAL CD(N) C THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER. C REAL CURVE C A MEASURE OF THE CURVATURE OF THE MODEL. C REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL ETA3 C THE CUBE ROOT OF ETA. C REAL FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C REAL 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 REAL 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 REAL 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL 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 REAL PVMEAN C THE MEAN OF A FUNCTION OF THE PREDICTED VALUES. C REAL 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 REAL 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 REAL 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 REAL PVTEMP(N) C A TEMPORARY STORAGE VECTOR FOR PREDICTED VALUES. C REAL PVTYP C THE TYPICAL SIZE OF THE PREDICTED VALUES OF THE MODEL. C REAL Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C REAL SCALE C THE TYPICAL SIZE OF THE JTH PARAMETER. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C REAL STPCD C THE STEP SIZE USED FOR THE CENTRAL DIFFERENCE QUOTIENT. C REAL STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C REAL STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C REAL STPUP C THE UPPER LIMIT ON THE STEP SIZE. C REAL RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C REAL TAUABS C THE ABSOLUTE AGREEMENT TOLERANCE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL THIRD C THE VALUE ONE THIRD. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C FPLRS = R1MACH(4) C C SET VARIOUS PARAMETERS NECESSARY FOR COMPUTING THE C OPTIMUM STEP SIZE C THIRD = 1.0E0 / 3.0E0 C ETA3 = ETA ** THIRD C write ( *, * ) 'DEBUG: FPLRS = ', fplrs write ( *, * ) 'DEBUG: STPMN: PAR(J) = ', par(j) write ( *, * ) 'DEBUG: STPMN: SCALE = ', scale PARMX = MAX(ABS(PAR(J)), ABS(SCALE)) IF (PARMX .EQ. 0.0E0) PARMX = 1.0E0 C STPCD = ((3.0E0 ** THIRD) * ETA3 * PARMX * SIGN(1.0E0, 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.0E0) THEN IF (PV(I).EQ.0.0E0) 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.0E0) THEN IF (PV(I).EQ.0.0E0) 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.0E0) 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.0E0) THEN STP = PARMX * SIGN(1.0E0, PAR(J)) ELSE STP = (2.0E0 * SQRT(ETA) * SQRT(PVTYP) / SQRT(CURVE)) * + SIGN(1.0E0,PAR(J)) END IF C IF (ABS(STP).GT.PARMX) STP = PARMX * SIGN(1.0E0,PAR(J)) C Q = STP + PAR(J) STP = Q - PAR(J) C IF (STP.EQ.0.0E0) THEN STP = FPLRS * PAR(J) IF (STP.EQ.0.0E0) STP = FPLRS C 30 CONTINUE Q = STP + PAR(J) STP = Q - PAR(J) C IF (STP.EQ.0.0E0) THEN STP = 2.0E0 * STP GO TO 30 END IF END IF C C COMPUTE THE ABSOLUTE TOLERANCES C ABSTOL = 10.0E0 * ETA * PVTYP C TAUABS = 2.0E0 * SQRT(ETA) * SQRT(PVTYP) IF (CURVE .NE. 0.0E0) 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.0E0*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 write ( *, * ) 'DEBUG: STPMN: RELTOL = ', reltol write ( *, * ) 'DEBUG: STPMN: ABSTOL = ', abstol CALL RELCOM(N, FD, CD, RELTOL, ABSTOL, NFAIL, IFAIL) write ( *, * ) 'DEBUG: STPMN: NFAIL = ', nfail 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 write ( *, * ) 'DEBUG: STPMN: STP=',stp, ' PARMX = ', parmx STP = ABS(STP) / PARMX C RETURN C END *STPOUT SUBROUTINE STPOUT(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 SUBROUTINE PRINTS THE RESULTS OF THE STEP SIZE SELECTING C 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 REAL + EXM INTEGER + ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT LOGICAL + HEAD,PAGE,PRTFXD,WIDE C C ARRAY ARGUMENTS REAL + PAR(NPAR),SCALE(LSCALE),STP(NPAR) INTEGER + IFAIL(N),IFIXD(NPAR),NFAIL(NPAR) C C SUBROUTINE ARGUMENTS EXTERNAL HDR C C LOCAL SCALARS INTEGER + I,IPRT,K,NFLABS,NK,NPERL LOGICAL + SAMELN CHARACTER + BLANK*1,C*1,F*1,PLUS*1 C C LOCAL ARRAYS INTEGER + INDEX(25) CHARACTER + FIXED(3)*1 C C EXTERNAL SUBROUTINES EXTERNAL FIXPRT,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC IABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER*1 BLANK C THE CHARACTER BLANK. C CHARACTER*1 C C THE CHARACTER FLAG INDICATING HIGH CURVATURE. C REAL 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 CHARACTER*1 F C THE CHARACTER FLAG INDICATING NUMBER OF OBSERVATIONS C FAILING SELECTION CRITERIA EXCEEDED EXEMPTED NUMBER. C CHARACTER*1 FIXED(3) C THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT. 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 I C AN INDEX VARIABLE. 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 INDEX(25) C THE ROW NUMBERS OF OBSERVATIONS FOR WHICH THE STEP SIZE C SELECTED FAILED. C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. 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 J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER K C AN INDEX VARIABLE. 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 NFLABS C THE ABSOLUTE VALUE OF NFAIL. C INTEGER NK C AN INDEX VARIABLE. C INTEGER NPERL C THE NUMBER OF OBSERVATIONS TO BE PRINTED PER LINE. 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE C PARAMETERS ARE STORED. C CHARACTER*1 PLUS C THE CHARACTER PLUS. 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 LOGICAL SAMELN C AN INDICATOR VALUE TO DESIGNATE WHETHER THE LINE IS TO BE C PRINTED ON THE SAME LINE AS THE PREVIOUS LINE PRINTED (TRUE) C OR NOT (FALSE). C REAL SCALE(LSCALE) C THE TYPICAL SIZE OF THE PARAMETERS. C REAL 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 DATA BLANK /' '/, PLUS /'+'/ CALL IPRINT(IPRT) C C INITIALIZE ARRAY FIXED C DO 10 K=1,3 FIXED(K) = BLANK 10 CONTINUE C IF (HEAD) THEN C C PRINT HEADING C HEAD = .FALSE. C CALL HDR(PAGE, WIDE, ISUBHD) IF (PRTFXD) THEN WRITE (IPRT,1000) ELSE WRITE (IPRT,1010) END IF C C PRINT INFORMATION OTHERWISE SUPPRESSED BY PRINT CONTROL C DO 20 I=1,J-1 IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED) IF (IFIXD(I).EQ.0) THEN F = BLANK C = BLANK NFLABS = IABS(NFAIL(I)) IF (NFLABS.GT.NEXMPT) F = PLUS IF (NFAIL(I).LT.0) C = PLUS IF (SCALE(1).GT.0.0E0) THEN WRITE (IPRT,1020) I, (FIXED(K),K=1,3), PAR(I), + SCALE(I), + STP(I), NFLABS, F, C ELSE WRITE (IPRT,1040) I, (FIXED(K),K=1,3), PAR(I), + STP(I), NFLABS, F, C END IF IF (NFLABS.GT.NEXMPT) WRITE (IPRT,1030) ELSE WRITE (IPRT,1045) I, (FIXED(K),K=1,3), PAR(I) END IF 20 CONTINUE END IF C C PRINT INFORMATION FOR CURRENT PARAMETER C I = J IF (PRTFXD) CALL FIXPRT(IFIXD(I), FIXED) IF (IFIXD(I).EQ.0) THEN F = BLANK C = BLANK NFLABS = IABS(NFAIL(I)) IF (NFLABS.GT.NEXMPT) F = PLUS IF (NFAIL(I).LT.0) C = PLUS IF (SCALE(1).GT.0.0E0) THEN WRITE (IPRT,1020) I, (FIXED(K),K=1,3), PAR(I), + SCALE(I), + STP(I), NFLABS, F, C ELSE WRITE (IPRT,1040) I, (FIXED(K),K=1,3), PAR(I), + STP(I), NFLABS, F, C END IF IF (NFLABS.GE.1) THEN IF ((NPRT.EQ.0) .AND. (NFLABS.LE.NEXMPT)) THEN WRITE (IPRT,1030) ELSE C C PRINT ROW NUMBERS C NPERL = 7 C SAMELN = .TRUE. NK = 0 DO 60 I=1,N IF (IFAIL(I).EQ.0) GO TO 60 NK = NK + 1 INDEX(NK) = I IF (NK.LT.NPERL) GO TO 60 IF (SAMELN) THEN WRITE (IPRT,1050) (INDEX(K),K=1,NK) ELSE WRITE (IPRT,1060) (INDEX(K),K=1,NK) END IF SAMELN = .FALSE. NK = 0 60 CONTINUE IF (SAMELN) THEN WRITE (IPRT,1050) (INDEX(K),K=1,NK) ELSE WRITE (IPRT,1060) (INDEX(K),K=1,NK) END IF END IF END IF ELSE WRITE (IPRT,1045) I, (FIXED(K),K=1,3), PAR(I) END IF IF (J.LT.NPAR) RETURN C C PRINT FINAL NOTES AND SUMMARY C WRITE (IPRT,1070) IF (NPRT.NE.0) GO TO 100 DO 90 I=1,NPAR IF (IFIXD(I).EQ.0) THEN IF (IABS(NFAIL(I)).GT.NEXMPT) GO TO 90 WRITE (IPRT,1080) GO TO 100 END IF 90 CONTINUE C 100 CONTINUE C C PRINT CONTROL VALUES USED. C WRITE (IPRT,1090) NETA WRITE (IPRT,1100) EXM WRITE (IPRT,1110) NEXMPT WRITE (IPRT,1120) N C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (//50X, 13HSTEP SIZE FOR, 4X, 25HOBSERVATIONS FAILING STEP, + 24H SIZE SELECTION CRITERIA/50X, 13HAPPROXIMATING, 21X, 1H*/7X, + 24HPARAMETER STARTING VALUE, 6X, 5HSCALE, 10X, 10HDERIVATIVE, + 7X, 5HCOUNT, 5X, 5HNOTES, 5X, 10HROW NUMBER/1X, 5HINDEX, 2X, + 5HFIXED, 6X, 5H(PAR), 12X, 7H(SCALE), 11X, 5H(STP), 21X, 3HF C/ + ) 1010 FORMAT (//50X, 13HSTEP SIZE FOR, 4X, 25HOBSERVATIONS FAILING STEP, + 24H SIZE SELECTION CRITERIA/18X, 9HPARAMETER, 23X, 9HAPPROXIMA, + 4HTING, 21X, 1H*/16X, 14HSTARTING VALUE, 7X, 5HSCALE, 10X, + 10HDERIVATIVE, 7X, 5HCOUNT, 5X, 5HNOTES, 5X, 13HROW NUMBER(S)/ + 1X, 5HINDEX, 13X, 5H(PAR), 12X, 7H(SCALE), 11X, 5H(STP), 21X, + 3HF C/) 1020 FORMAT (1X, I3, 5X, 3A1, 3G17.8, 5X, I5, 7X, A1, 1X, A1) 1030 FORMAT ('+', 89X, 2H**) 1040 FORMAT (1X, I3, 5X, 3A1, G17.8, 7X, 7HDEFAULT, 3X, G17.8, 5X, I5, + 7X, A1, 1X, A1) 1045 FORMAT (1X, I3, 5X, 3A1, G17.8, 9X, '---', 14X, '---', + 14X, '-') 1050 FORMAT ('+', 86X, 7I5) 1060 FORMAT (87X, 7I5) 1070 FORMAT (//1X, 36H* NOTES. A PLUS (+) IN THE COLUMNS, 8H HEADED , + 33HF OR C HAS THE FOLLOWING MEANING.//4X, 17HF - NUMBER OF OBS, + 27HERVATIONS FAILING STEP SIZE, 27H SELECTION CRITERIA EXCEEDS/ + 8X, 29HNUMBER OF EXEMPTIONS ALLOWED.//4X, 17HC - HIGH CURVATUR, + 30HE IN THE MODEL IS SUSPECTED AS, 13H THE CAUSE OF/8X, + 19HALL FAILURES NOTED.) 1080 FORMAT (//46H ** ROW NUMBERS ARE ONLY LISTED WHEN NUMBER OF, + 26H OBSERVATIONS FAILING STEP/4X, 25HSIZE SELECTION CRITERIA E, + 27HXCEEDS NUMBER OF EXEMPTIONS, 9H ALLOWED.) 1090 FORMAT (/43H NUMBER OF RELIABLE DIGITS IN MODEL RESULTS, 25X, + 6H(NETA), 1X, I5) 1100 FORMAT (/41H PROPORTION OF OBSERVATIONS EXEMPTED FROM, 8H SELECTI, + 11HON CRITERIA, 7X, 7H(EXMPT), 2X, F6.4) 1110 FORMAT (/37H NUMBER OF OBSERVATIONS EXEMPTED FROM, 11H SELECTION , + 8HCRITERIA, 19X, I5) 1120 FORMAT (/23H NUMBER OF OBSERVATIONS, 48X, 3H(N), 1X, I5) 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 REAL + ABSTOL,ETA3,RELTOL,STP,STPLOW,STPMID,STPUP,TAUABS INTEGER + IXM,J,M,N,NEXMPT,NFAIL,NPAR C C ARRAY ARGUMENTS REAL + 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 REAL + Q C C LOCAL SCALARS REAL + FACTOR,STP1,STP2,STPNEW,TEMP INTEGER + NCOUNT LOGICAL + FAIL,FIRST,FORWRD,HICURV,SUCCES C C EXTERNAL SUBROUTINES EXTERNAL ABSCOM,CMPFD,ICOPY,RELCOM,SCOPY,STPADJ C C INTRINSIC FUNCTIONS INTRINSIC ABS C C COMMON BLOCKS COMMON /NOTOPT/Q C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ABSTOL C THE ABSOLUTE AGREEMENT TOLERANCE. C REAL ETA3 C THE CUBE ROOT OF THE RELATIVE NOISE IN THE MODEL C REAL 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 REAL FD(N) C THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE C DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER C REAL 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 REAL 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 REAL PAR(NPAR) C THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN C PARAMETERS ARE STORED. C REAL PV(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL 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 REAL Q C A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO C OPTIMIZATION), TO COMPUTE THE STEP SIZE. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD C DIFFERENCE APPROXIMATION TO THE DERIVATIVE. C REAL STPLOW C THE LOWER LIMIT ON THE STEP SIZE. C REAL STPMID C THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE. C REAL STPNEW C THE VALUE OF THE NEW STEP SIZE BEING TESTED. C REAL STPUP C THE UPPER LIMIT ON THE STEP SIZE. C REAL 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 REAL RELTOL C THE RELATIVE AGREEMENT TOLERANCE. C REAL TAUABS C THE ABSOLUTE AGREEMENT TOLERANCE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL XM(IXM,M) C THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY C IS STORED. C CALL SCOPY(N, FD, 1, FDSAVE, 1) C FACTOR = 10.0E0 IF (ABS(STP) .GT. STPMID) FACTOR = 0.1E0 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 SCOPY(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.0E0 .AND. ABS(STPNEW).GT.STPUP) .OR. + (FACTOR.LT.1.0E0 .AND. ABS(STPNEW).LT.STPLOW)) THEN IF (FORWRD) THEN FORWRD = .FALSE. FACTOR = 1.0E0 / FACTOR STPNEW = STP * FACTOR Q = STPNEW + PAR(J) STPNEW = Q - PAR(J) CALL SCOPY(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 *STRCO SUBROUTINE STRCO(T,LDT,N,RCOND,Z,JOB) C***BEGIN PROLOGUE STRCO C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,TRIANGULAR C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX. C***DESCRIPTION C STRCO ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX. C ON ENTRY C T REAL(LDT,N) C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C N INTEGER C N IS THE ORDER OF THE SYSTEM. C JOB INTEGER C = 0 T IS LOWER TRIANGULAR. C = NONZERO T IS UPPER TRIANGULAR. C ON RETURN C RCOND REAL C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS C IN T AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN T MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C Z REAL(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SASUM,SAXPY,SSCAL C***END PROLOGUE STRCO C...SCALAR ARGUMENTS REAL RCOND INTEGER + JOB,LDT,N C...ARRAY ARGUMENTS REAL T(LDT,*),Z(*) C...LOCAL SCALARS REAL EK,S,SM,TNORM,W,WK,WKM,YNORM INTEGER + I1,J,J1,J2,K,KK,L LOGICAL + LOWER C...EXTERNAL FUNCTIONS REAL SASUM EXTERNAL + SASUM C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY,SSCAL C...INTRINSIC FUNCTIONS INTRINSIC + ABS,AMAX1,SIGN C***FIRST EXECUTABLE STATEMENT STRCO LOWER = JOB .EQ. 0 C COMPUTE 1-NORM OF T TNORM = 0.0E0 DO 10 J = 1, N L = J IF (LOWER) L = N + 1 - J I1 = 1 IF (LOWER) I1 = J TNORM = AMAX1(TNORM,SASUM(L,T(I1,J),1)) 10 CONTINUE C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . C TRANS(T) IS THE TRANSPOSE OF T . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF Y . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C SOLVE TRANS(T)*Y = E EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 KK = 1, N K = KK IF (LOWER) K = N + 1 - KK IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30 S = ABS(T(K,K))/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (T(K,K) .EQ. 0.0E0) GO TO 40 WK = WK/T(K,K) WKM = WKM/T(K,K) GO TO 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE IF (KK .EQ. N) GO TO 90 J1 = K + 1 IF (LOWER) J1 = 1 J2 = N IF (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + ABS(Z(J)+WKM*T(K,J)) Z(J) = Z(J) + WK*T(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*T(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = 1.0E0 C SOLVE T*Z = Y DO 130 KK = 1, N K = N + 1 - KK IF (LOWER) K = KK IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110 S = ABS(T(K,K))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE IF (T(K,K) .NE. 0.0E0) Z(K) = Z(K)/T(K,K) IF (T(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 I1 = 1 IF (LOWER) I1 = K + 1 IF (KK .GE. N) GO TO 120 W = -Z(K) CALL SAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END *STRDI SUBROUTINE STRDI(T,LDT,N,DET,JOB,INFO) C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER INFO,JOB,LDT,N C C ARRAY ARGUMENTS REAL DET(2),T(LDT,*) C C LOCAL SCALARS REAL TEMP,TEN INTEGER I,J,K,KB,KM1,KP1 C C EXTERNAL SUBROUTINES EXTERNAL SAXPY,SSCAL C C INTRINSIC FUNCTIONS INTRINSIC ABS,MOD C C C STRDI COMPUTES THE DETERMINANT AND INVERSE OF A REAL C TRIANGULAR MATRIX. C C ON ENTRY C C T REAL(LDT,N) C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C C N INTEGER C N IS THE ORDER OF THE SYSTEM. C C JOB INTEGER C = 010 NO DET, INVERSE OF LOWER TRIANGULAR. C = 011 NO DET, INVERSE OF UPPER TRIANGULAR. C = 100 DET, NO INVERSE. C = 110 DET, INVERSE OF LOWER TRIANGULAR. C = 111 DET, INVERSE OF UPPER TRIANGULAR. C C ON RETURN C C T INVERSE OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE UNCHANGED. C C DET REAL(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C INFO INTEGER C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR C AND THE INVERSE IS REQUESTED. C OTHERWISE INFO CONTAINS THE INDEX OF C A ZERO DIAGONAL ELEMENT OF T. C C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL C FORTRAN ABS,MOD C C BEGIN BLOCK PERMITTING ...EXITS TO 180 C C COMPUTE DETERMINANT C IF (JOB/100 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N DET(1) = T(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE OF UPPER TRIANGULAR C IF (MOD(JOB/10,10) .EQ. 0) GO TO 170 IF (MOD(JOB,10) .EQ. 0) GO TO 120 C BEGIN BLOCK PERMITTING ...EXITS TO 110 DO 100 K = 1, N INFO = K C ......EXIT IF (T(K,K) .EQ. 0.0E0) GO TO 110 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) CALL SSCAL(K-1,TEMP,T(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N TEMP = T(K,J) T(K,J) = 0.0E0 CALL SAXPY(K,TEMP,T(1,K),1,T(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE INFO = 0 110 CONTINUE GO TO 160 120 CONTINUE C C COMPUTE INVERSE OF LOWER TRIANGULAR C DO 150 KB = 1, N K = N + 1 - KB INFO = K C ............EXIT IF (T(K,K) .EQ. 0.0E0) GO TO 180 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) IF (K .NE. N) CALL SSCAL(N-K,TEMP,T(K+1,K),1) KM1 = K - 1 IF (KM1 .LT. 1) GO TO 140 DO 130 J = 1, KM1 TEMP = T(K,J) T(K,J) = 0.0E0 CALL SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE INFO = 0 160 CONTINUE 170 CONTINUE 180 CONTINUE RETURN END *SUMBS SUBROUTINE SUMBS(X, N, LO, MID, HI) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO FIND A ZERO OR VALUE CLOSEST TO ZERO IN C A SORTED VECTOR. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + HI,LO,MID,N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS INTEGER + CURHI,CURLO C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C INTEGER HI C INPUT PARAMETER. THE UPPER BOUND OF THE INITIAL C INTERVAL. C INTEGER LO C INPUT PARAMETER. THE LOWER BOUND OF THE INITIAL C INTERVAL. C INTEGER MID C OUTPUT PARAMETER. THE MIDPOINT OF THE CURRENT C INTERVAL, AND ON EXIT THE POINT IN THE INITIAL C INTERVAL CLOSEST TO ZERO. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C REAL X(N) C INPUT PARAMETER. THE ARRAY X IN WHICH THE SEARCH FOR C A (NEAR) ZERO VALUE IS MADE. C C BINARY SEARCH OF X FOR 0.0E0 OR CLOSEST TO IT. C CURLO = LO CURHI = HI C C SEE IF ZERO IS OUT OF THE RANGE X(LO) TO X(HI). C IF (X(CURLO).LT.0.0E0) GO TO 10 MID = CURLO GO TO 50 10 IF (X(CURHI).GT.0.0E0) GO TO 20 MID = CURHI GO TO 50 C C LOCATE EITHER A ZERO OR A PAIR OF ADJACENT VALUES BETWEEN C WHICH THERE LIES A ZERO. C 20 IF (CURLO+1.EQ.CURHI) GO TO 30 MID = (CURLO+CURHI)/2 IF (0.0E0.LT.X(MID)) CURHI = MID IF (0.0E0.GT.X(MID)) CURLO = MID IF (0.0E0.EQ.X(MID)) GO TO 50 GO TO 20 C C PICK AS MIDPOINT THE CURRENT ENDPOINT CLOSEST TO ZERO. C 30 IF (X(CURHI)+X(CURLO).GT.0.0E0) GO TO 40 MID = CURHI GO TO 50 40 MID = CURLO 50 RETURN END *SUMDS SUBROUTINE SUMDS(X, N, LO, MID, HI, XMEANW, SUMDA, SUMD2, SUMD3, + SUMD4) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE UNWEIGHTED SUMS OF POWERS OF C DIFFERENCES FROM THE WEIGHTED MEAN FOR A SORTED C VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT C CLOSEST TO ZERO. USED BY THE STAT FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMD2,SUMD3,SUMD4,SUMDA,XMEANW INTEGER + HI,LO,MID,N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS REAL + DIFF INTEGER + CURHI,CURLO,I,IREV C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C REAL DIFF C THE DIFFERENCES BETWEEN X(I) AND XMEANW. C INTEGER HI C INPUT PARAMETER. THE UPPER BOUND OF THE INITIAL C INTERVAL. C INTEGER I C A LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER LO C INPUT PARAMETER. THE LOWER BOUND OF THE INITIAL C INTERVAL. C INTEGER MID C INPUT PARAMETER. THE INDEX OF THE ELEMENT IN X CLOSEST TO C ZERO IN VALUE. THE POINT OUT FROM WHICH THE SUMMING IS C DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C REAL SUMDA C OUTPUT PARAMETER. THE SUM OF THE ABSOLUTE VALUES OF THE C DIFFERENCES DIFF. C REAL SUMD2 C OUTPUT PARAMETER. THE SUM OF THE SQUARES OF THE C DIFFERENCES DIFF. C REAL SUMD3 C OUTPUT PARAMETER. THE SUM OF THE CUBES OF THE C DIFFERENCES DIFF. C REAL SUMD4 C OUTPUT PARAMETER. THE SUM OF THE HYPERCUBES OF THE C DIFFERENCES DIFF. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN. C REAL XMEANW C INPUT PARAMETER. THE WEIGHTED MEAN OF X. C C INITIALIZE SUMMATION VARIABLES. C DIFF = X(MID) - XMEANW SUMDA = ABS(DIFF) SUMD2 = DIFF*DIFF SUMD3 = DIFF*DIFF*DIFF SUMD4 = DIFF*DIFF*DIFF*DIFF CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS FROM THE VALUE NEAREST ZERO. THAT IS, SUM FROM C THE LEAST IN MAGNITUDE TO THE GREATEST. C 10 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 30 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20 DIFF = X(CURLO) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF CURLO = CURLO - 1 GO TO 10 20 DIFF = X(CURHI) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF CURHI = CURHI + 1 GO TO 10 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 30 IF (CURHI.GT.HI) GO TO 50 DO 40 I=CURHI,HI DIFF = X(I) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 40 CONTINUE 50 IF (CURLO.LT.LO) GO TO 70 DO 60 IREV=LO,CURLO I = LO - IREV + CURLO DIFF = X(I) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 60 CONTINUE 70 RETURN END *SUMID SUBROUTINE SUMID(X, N, XMEAN, SUMDI) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE THE SUM OF THE PRODUCTS OF I AND THE I TH C DIFFERENCE AMONG THE ELEMENTS OF THE VECTOR X - XMEAN. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMDI,XMEAN INTEGER + N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS REAL + DIFF INTEGER + I C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DIFF C THE DIFFERENCE OF A VALUE OF X AND THE WEIGHTED MEAN OF X. C INTEGER I C A LOOP INDEX. C INTEGER N C INPUT PARAMETER. THE NUMBER OF ELEMENTS IN X. C REAL SUMDI C OUTPUT PARAMETER. THE SUM OF THE PRODUCTS OF I AND THE C ELEMENTS OF THE VECTOR X - XMEAN. C REAL X(N) C INPUT PARAMETER. THE VECTOR OF N DATA VALUES. C REAL XMEAN C INPUT PARAMETER. THE MEAN OF X. C SUMDI = 0.0E0 DO 10 I=1,N DIFF = X(I) - XMEAN SUMDI = SUMDI + I*DIFF 10 CONTINUE RETURN END *SUMIDW SUBROUTINE SUMIDW(X, W, N, XMEANW, SUMDI) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE THE SUM OF THE PRODUCTS OF I AND THE I TH C DIFFERENCE AMONG THE ELEMENTS OF THE VECTOR X - XMEANW WHICH C ARE NOT WEIGHTED ZERO. (ELEMENTS WEIGHTED ZERO DO NOT C PRODUCE AN INCREMENT IN I.) C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMDI,XMEANW INTEGER + N C C ARRAY ARGUMENTS REAL + W(N),X(N) C C LOCAL SCALARS REAL + DIFF,I INTEGER + K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DIFF C THE DIFFERENCE OF A VALUE OF X AND THE WEIGHTED MEAN OF X. C REAL I C I COUNTS FROM 1 TO THE NUMBER OF NON-ZERO WEIGHTED ELEMENTS C FOUND IN X. C INTEGER K C A LOOP INDEX. C INTEGER N C INPUT PARAMETER. THE NUMBER OF ELEMENTS IN X. C REAL SUMDI C OUTPUT PARAMETER. THE SUM OF THE PRODUCTS OF I AND THE C NON-ZERO WEIGHTED ELEMENTS OF THE VECTOR X - XMEANW. C REAL W(N) C INPUT PARAMETER. THE WEIGHTS VECTOR FOR X. C REAL X(N) C INPUT PARAMETER. THE VECTOR OF N DATA VALUES. C REAL XMEANW C INPUT PARAMETER. THE WEIGHTED MEAN OF X. C I = 0.0E0 SUMDI = 0.0E0 DO 10 K=1,N IF (W(K).EQ.0.0E0) GO TO 10 DIFF = X(K) - XMEANW I = I + 1.0E0 SUMDI = SUMDI + I*DIFF 10 CONTINUE RETURN END *SUMOT SUBROUTINE SUMOT(STS, N, NNZW, WTS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE REPORTS THE RESULTS OF A STAT FAMILY C COMPUTATION OF 53 SELECTED STATISTICS. THERE MAY OR C MAY NOT BE WEIGHTS. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NNZW LOGICAL + WTS C C ARRAY ARGUMENTS REAL + STS(53) C C LOCAL SCALARS INTEGER + I,IPRT C C LOCAL ARRAYS INTEGER + ITEMP(10) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C LOOP INDEX. C INTEGER IPRT C THE OUTPUT UNIT. C INTEGER ITEMP(10) C A TEMPORARY VECTOR OF INTEGER STORAGE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ORIGINAL DATA VECTOR. C INTEGER NNZW C INPUT PARAMETER. THE NUMBER OF VALUES IN THE ORIGINAL DATA C VECTOR WITH WEIGHTS GREATER THAN 0.0E0. C REAL STS(53) C INPUT PARAMETER. THE VECTOR OF 53 STATISTICS COMPUTED. C ROW STATISTIC ROW STATISTIC C 1 LENGTH OF VECTOR TESTS FOR NONRANDOMNESS C 2 NUMBER OF NONZERO WEIGHTS 23 NUMBER OF RUNS UP AND DOWN C MEASURES OF LOCATION 24 EXPECTED NUMBER OF RUNS C 3 UNWEIGHTED MEAN 25 S.D. OF NUMBER OF RUNS C 4 WEIGHTED MEAN 26 MEAN SQR. SUCCESSIVE DIFF. C 5 MEDIAN 27 MEAN SQR. SUCC. DIFF./VAR. C 6 MID-RANGE DEVIATIONS FROM WTD MEAN C 7 25 P.C. UNWTD. TRIMMED MEAN 28 NUMBER OF + SIGNS C 8 25 P.C. WTD. TRIMMED MEAN 29 NUMBER OF - SIGNS C MEASURES OF DISPERSION 30 NUMBER OF RUNS C 9 STANDARD DEVIATION (S.D.) 31 EXPECTED NUMBER OF RUNS C 10 S.D. OF MEAN 32 S.D. OF RUNS C 11 RANGE 33 DIFF./S.D. OF RUNS C 12 MEAN VARIATION OTHER STATISTICS C 13 VARIANCE (VAR.) 34 MINIMUM C 14 COEFFICIENT OF VARIATION 35 MAXIMUM C CONFIDENCE INTERVALS 36 BETA 1 C 15 LOWER CONFIDENCE LIMIT, MEAN 37 BETA 2 C 16 UPPER CONFIDENCE LIMIT, MEAN 38 WTD. SUM OF VALUES C 17 LOWER CONFIDENCE LIMIT, S.D. 39 WTD. SUM OF SQUARES C 18 UPPER CONFIDENCE LIMIT, S.D. 40 WTD. SUM OF SQRD. DEVS. C LINEAR TREND STATISTICS 41 STUDENTS T C 19 SLOPE 42 WTD. SUM OF ABS. VALUES C 20 S.D. OF SLOPE 43 WTD. AVG. ABS. VALUES C 21 SLOPE/S.D. OF SLOPE = T 44-53 FREQ. DISTRIBUTION C 22 PROB ( X .GT. ABS(OBS. T)) C LOGICAL WTS C INPUT PARAMETER. A FLAG TO INDICATE WHETHER OR NOT THERE ARE C WEIGHTS. C C BEGIN PRINTOUT C CALL IPRINT(IPRT) C C PRINT HEADING C CALL VERSP(.TRUE.) C C PRINT NUMBERS OF OBSERVATIONS, RAW AND NONZERO WEIGHTED. C IF (.NOT.WTS) WRITE (IPRT,1000) IF (WTS) WRITE (IPRT,1010) IF (NNZW.NE.N) GO TO 10 WRITE (IPRT,1020) NNZW GO TO 20 10 WRITE (IPRT,1030) NNZW, N WRITE (IPRT,1040) C C PRINT FREQUENCY DISTRIBUTIONS C 20 DO 30 I=1,10 ITEMP(I) = STS(I+43) 30 CONTINUE WRITE (IPRT,1050) (ITEMP(I),I=1,10) C C PRINT MEASURES OF LOCATION AND DISPERSION C WRITE (IPRT,1060) IF (STS(4).NE.0.0E0) + WRITE (IPRT,1070) (STS(I+2),STS(I+8),I=1,6) IF (STS(4).EQ.0.0E0) + WRITE (IPRT,1080) (STS(I+2),STS(I+8),I=1,5), STS(8) C C PRINT CONFIDENCE INTERVALS C WRITE (IPRT,1090) (STS(I),I=15,18) C C PRINT LINEAR TREND AND OTHER STATISTICS, AND PRINT HEADING FOR C TESTS FOR NONRANDOMNESS C WRITE (IPRT,1100) + (STS(I),STS(I+15),I=19,22), (STS(I),I=38,41) ITEMP(1) = STS(23) ITEMP(2) = STS(28) ITEMP(3) = STS(29) ITEMP(4) = STS(30) C C PRINT TESTS FOR NONRANDOMNESS C WRITE (IPRT,1110) ITEMP(1), STS(42), STS(24), STS(43), + (STS(I),I=25,27), (ITEMP(I),I=2,4), (STS(I),I=31,33) C C PRINT FOOTNOTE C WRITE (IPRT,1120) RETURN C 1000 FORMAT('+STATISTICAL ANALYSIS') 1010 FORMAT('+WEIGHTED STATISTICAL ANALYSIS') 1020 FORMAT(//5X, 4HN = , I5) 1030 FORMAT(//5X, 4HN = , I5, 32H (NO. OF NON-ZERO WTS) LENGTH, + 2H =, I5) 1040 FORMAT(/5X, 45HALL COMPUTATIONS ARE BASED ON OBSERVATIONS WI, + 19HTH NON-ZERO WEIGHTS) 1050 FORMAT(//5X, 28HFREQUENCY DISTRIBUTION (1-6), 7X, 10I6) 1060 FORMAT(//5X, 26HMEASURES OF LOCATION (2-2), 34X, 10HMEASURES O, + 18HF DISPERSION (2-6)) 1070 FORMAT(/10X, 26HUNWEIGHTED MEAN =, 1PE15.7, 20X, + 26HWTD STANDARD DEVIATION =, E15.7/10X, 17HWEIGHTED MEAN , + 9H =, E15.7, 20X, 26HWEIGHTED S.D. OF MEAN =, + E15.7/10X, 26HMEDIAN =, E15.7, 20X, 6HRANGE , + 20H =, E15.7/10X, 23HMID-RANGE , + 3H =, E15.7, 20X, 26HMEAN DEVIATION =, E15.7/10X, + 26H25 PCT UNWTD TRIMMED MEAN=, E15.7, 20X, 16HVARIANCE , + 10H =, E15.7/10X, 26H25 PCT WTD TRIMMED MEAN =, + E15.7, 20X, 26HCOEF. OF. VAR. (PERCENT) =, E15.7) 1080 FORMAT(/10X, 26HUNWEIGHTED MEAN =, 1PE15.7, 20X, + 26HWTD STANDARD DEVIATION =, E15.7/10X, 17HWEIGHTED MEAN , + 9H =, E15.7, 20X, 26HWEIGHTED S.D. OF MEAN =, + E15.7/10X, 26HMEDIAN =, E15.7, 20X, 6HRANGE , + 20H =, E15.7/10X, 23HMID-RANGE , + 3H =, E15.7, 20X, 26HMEAN DEVIATION =, E15.7/10X, + 26H25 PCT UNWTD TRIMMED MEAN=, E15.7, 20X, 16HVARIANCE , + 10H =, E15.7/10X, 26H25 PCT WTD TRIMMED MEAN =, + E15.7, 20X, 26HCOEFFICIENT OF VARIATION =, 13H UNDEFINED/ + 98X, 14H(MEAN IS ZERO)) 1090 FORMAT(///20X, 46HA TWO-SIDED 95 PCT CONFIDENCE INTERVAL FOR MEA, + 4HN IS, 1PE14.7, 4H TO , E14.7, 6H (2-2)/20X, 13HA TWO-SIDED 9, + 37H5 PCT CONFIDENCE INTERVAL FOR S.D. IS, E14.7, 4H TO , + E14.7, 6H (2-7)) 1100 FORMAT(///5X, 30HLINEAR TREND STATISTICS (5-1) , 30X, 6HOTHER , + 10HSTATISTICS//10X, 5HSLOPE, 20X, 1H=, 1PE15.7, 20X, 7HMINIMUM, + 18X, 1H=, E15.7/10X, 13HS.D. OF SLOPE, 12X, 1H=, E15.7, 20X, + 7HMAXIMUM, 18X, 1H=, E15.7/10X, 26HSLOPE/S.D. OF SLOPE = T =, + E15.7, 20X, 8HBETA ONE, 17X, 1H=, E15.7/10X, 14HPROB EXCEEDING, + 21H ABS VALUE OF OBS T =, 0PF6.3, 20X, 8HBETA TWO, 17X, 1H=, + 1PE15.7/71X, 17HWTD SUM OF VALUES, 8X, 1H=, E15.7/71X, 7HWTD SUM, + 11H OF SQUARES, 7X, 1H=, E15.7/5X, 24HTESTS FOR NON-RANDOMNESS, + 42X, 22HWTD SUM OF DEV SQUARED, 4H =, E15.7/71X, 9HSTUDENTS , + 'T', 15X, 1H=, E15.7) 1110 FORMAT(10X, 26HNO. OF RUNS UP AND DOWN =, I5, 30X, 9HWTD SUM A, + 17HBSOLUTE VALUES =, 1PE15.7/ + 10X, 26HEXPECTED NO. OF RUNS =, + 0PF7.1, 28X, 26HWTD AVE ABSOLUTE VALUES =, 1PE15.7/ + 10X, 26HS.D. OF NO. OF RUNS =, 0PF8.2/ + 10X, 26HMEAN SQ SUCCESSIVE DIFF =, 1X, 1PE16.7/ + 10X, 26HMEAN SQ SUCC DIFF/VAR =, 0PF9.3/// + 10X, 24HDEVIATIONS FROM WTD MEAN// + 15X, 21HNO. OF + SIGNS =, I5/ + 15X, 21HNO. OF - SIGNS =, I5/ + 15X, 21HNO. OF RUNS =, I5/ + 15X, 21HEXPECTED NO. OF RUNS=, F7.1/ + 15X, 12HS.D. OF RUNS, 8X, 1H=, F8.2/ + 15X, 21HDIFF./S.D. OF RUNS =, F9.3) 1120 FORMAT(///49H NOTE - ITEMS IN PARENTHESES REFER TO PAGE NUMBER, + 36H IN NBS HANDBOOK 91 (NATRELLA, 1966)) END *SUMSS SUBROUTINE SUMSS(X, N, LO, MID, HI, SUM1, SUM2, SUMA, XMEAN) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE SUMS OF POWERS AND THE MEAN C FOR A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS C THE ELEMENT CLOSEST TO ZERO. USED BY THE STAT C FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUM1,SUM2,SUMA,XMEAN INTEGER + HI,LO,MID,N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS INTEGER + CURHI,CURLO,I,IREV C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C INTEGER HI C INPUT PARAMETER. THE UPPER BOUND OF THE INITIAL C INTERVAL. C INTEGER I C LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER LO C INPUT PARAMETER. THE LOWER BOUND OF THE INITIAL INTERVAL. C INTEGER MID C INPUT PARAMETER. THE INDEX OF THE ELEMENT IN X CLOSEST TO C ZERO IN VALUE. THE POINT OUT FROM WHICH THE SUMMING IS C DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C REAL SUMA C OUTPUT PARAMETER. THE SUM OF THE ABSOLUTE VALUES OF THE C ELEMENTS OF X. C REAL SUM1 C OUTPUT PARAMETER. THE SUM OF THE ELEMENTS OF X. C REAL SUM2 C OUTPUT PARAMETER. THE SUM OF THE SQUARES OF THE C ELEMENTS OF X. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X OVER WHICH THE SUMS ARE C TAKEN. C REAL XMEAN C OUTPUT PARAMETER. THE UNWEIGHTED MEAN OF X. C C INITIALIZE SUMMATION VARIABLES. C SUM1 = X(MID) SUM2 = X(MID)*X(MID) SUMA = ABS(X(MID)) CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS FROM THE VALUE NEAREST ZERO. THAT IS, SUM FROM C THE LEAST IN MAGNITUDE TO THE GREATEST. C 10 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 30 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20 SUM1 = SUM1 + X(CURLO) SUM2 = SUM2 + X(CURLO)*X(CURLO) SUMA = SUMA + ABS(X(CURLO)) CURLO = CURLO - 1 GO TO 10 20 SUM1 = SUM1 + X(CURHI) SUM2 = SUM2 + X(CURHI)*X(CURHI) SUMA = SUMA + ABS(X(CURHI)) CURHI = CURHI + 1 GO TO 10 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 30 IF (CURHI.GT.HI) GO TO 50 DO 40 I=CURHI,HI SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I)*X(I) SUMA = SUMA + ABS(X(I)) 40 CONTINUE 50 IF (CURLO.LT.LO) GO TO 70 DO 60 IREV=LO,CURLO I = LO - IREV + CURLO SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I)*X(I) SUMA = SUMA + ABS(X(I)) 60 CONTINUE 70 XMEAN = SUM1/(HI-LO+1) RETURN END *SUMTS SUBROUTINE SUMTS(X, N, ALPHA, SUMT1, XTRM) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE THE UNWEIGHTED TRIMMED MEAN FOR C A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT C CLOSEST TO ZERO. USED BY THE STAT FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + ALPHA,SUMT1,XTRM INTEGER + N C C ARRAY ARGUMENTS REAL + X(N) C C LOCAL SCALARS INTEGER + CURHI,CURLO,I,IREV,ITHI,ITLO,MID,NALPHA C C EXTERNAL SUBROUTINES EXTERNAL SUMBS C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C INPUT PARAMETER. THE PERCENTAGE OF POINTS TO TRIM C FROM EACH END OF THE ARRAY X FOR THE TRIMMED MEAN. C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C INTEGER I C LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER ITHI C THE COMPUTED UPPER BOUND SUCH THAT ALPHA PER C CENT OF THE POSITIVELY WEIGHTED POINTS ARE C OMITTED. C INTEGER ITLO C THE COMPUTED LOWER BOUND SUCH THAT ALPHA PER C CENT OF THE POSITIVELY WEIGHTED POINTS ARE C OMITTED. C INTEGER MID C THE INDEX OF THE ELEMENT IN X CLOSEST TO ZERO IN VALUE. C THE POINT OUT FROM WHICH THE SUMMING IS DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C INTEGER NALPHA C THE INTEGER WHICH IS ALPHA PER CENT OF N. C REAL SUMT1 C OUTPUT PARAMETER. THE UNWEIGHTED SUM OF THE TRIMMED C ARRAY. ZERO-WEIGHTED ELEMENTS ARE OMITTED. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN. C REAL XTRM C OUTPUT PARAMETER. THE UNWEIGHTED, TRIMMED MEAN OF X. C C SET UP LIMITS TRIMMING THE NUMBER OF VALUES AT EACH END C BY ALPHA PER CENT. C NALPHA = ALPHA*N ITLO = NALPHA + 1 ITHI = N - NALPHA CALL SUMBS(X, N, ITLO, MID, ITHI) C C INITIALIZE SUMMATION VARIABLES. C SUMT1 = X(MID) CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS FROM THE VALUE NEAREST ZERO. THAT IS, SUM FROM C THE LEAST IN MAGNITUDE TO THE GREATEST. C 10 IF (CURHI.GT.ITHI .OR. CURLO.LT.ITLO) GO TO 30 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 20 SUMT1 = SUMT1 + X(CURLO) CURLO = CURLO - 1 GO TO 10 20 SUMT1 = SUMT1 + X(CURHI) CURHI = CURHI + 1 GO TO 10 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 30 IF (CURHI.GT.ITHI) GO TO 50 CURHI = MAX(CURHI,ITLO) DO 40 I=CURHI,ITHI SUMT1 = SUMT1 + X(I) 40 CONTINUE 50 IF (CURLO.LT.ITLO) GO TO 70 CURLO = MIN(CURLO,ITHI) DO 60 IREV=ITLO,CURLO I = ITLO - IREV + CURLO SUMT1 = SUMT1 + X(I) 60 CONTINUE 70 XTRM = SUMT1/(N-2*NALPHA) RETURN END *SUMWDS SUBROUTINE SUMWDS(X, W, N, LO, MID, HI, XMEANW, SUMDA, SUMWD2, + SUMD2, SUMD3, SUMD4) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE WEIGHTED AND UNWEIGHTED SUMS C OF POWERS OF DIFFERENCES FROM THE WEIGHTED MEAN FOR A C SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE ELEMENT C CLOSEST TO ZERO. USED BY THE STAT FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUMD2,SUMD3,SUMD4,SUMDA,SUMWD2,XMEANW INTEGER + HI,LO,MID,N C C ARRAY ARGUMENTS REAL + W(N),X(N) C C LOCAL SCALARS REAL + DIFF INTEGER + CURHI,CURLO,I,IREV C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C REAL DIFF C THE DIFFERENCES BETWEEN X(I) AND XMEANW. C INTEGER HI C INPUT PARAMETER. THE UPPER BOUND OF THE INITIAL C INTERVAL. C INTEGER I C A LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER LO C INPUT PARAMETER. THE LOWER BOUND OF THE INITIAL C INTERVAL. C INTEGER MID C INPUT PARAMETER. THE INDEX OF THE ELEMENT IN X CLOSEST TO C ZERO IN VALUE. THE POINT OUT FROM WHICH THE SUMMING IS C DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C REAL SUMDA C OUTPUT PARAMETER. THE SUM OF THE ABSOLUTE VALUES OF THE C DIFFERENCES DIFF. C REAL SUMD2 C OUTPUT PARAMETER. THE SUM OF THE SQUARES OF THE C DIFFERENCES DIFF. C REAL SUMD3 C OUTPUT PARAMETER. THE SUM OF THE CUBES OF THE C DIFFERENCES DIFF. C REAL SUMD4 C OUTPUT PARAMETER. THE SUM OF THE HYPERCUBES OF THE C DIFFERENCES DIFF. C REAL SUMWD2 C OUTPUT PARAMETER. THE WEIGHTED SUM OF THE SQUARES OF C THE DIFFERENCES DIFF. C REAL W(N) C INPUT PARAMETER. THE ARRAY OF WEIGHTS. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN. C REAL XMEANW C INPUT PARAMETER. THE WEIGHTED MEAN OF X. C C INITIALIZE SUMMATION VARIABLES. C SUMDA = 0.0E0 SUMWD2 = 0.0E0 SUMD2 = 0.0E0 SUMD3 = 0.0E0 SUMD4 = 0.0E0 IF (W(MID).EQ.0.0E0) GO TO 10 DIFF = X(MID) - XMEANW SUMDA = ABS(DIFF) SUMWD2 = W(MID)*DIFF*DIFF SUMD2 = DIFF*DIFF SUMD3 = DIFF*DIFF*DIFF SUMD4 = DIFF*DIFF*DIFF*DIFF 10 CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS, BOULDER, COLORADO FROM THE VALUE NEAREST ZERO. THAT C THE LEAST IN MAGNITUDE TO THE GREATEST. C 20 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 60 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 40 IF (W(CURLO).EQ.0.0E0) GO TO 30 DIFF = X(CURLO) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMWD2 = SUMWD2 + W(CURLO)*DIFF*DIFF SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 30 CURLO = CURLO - 1 GO TO 20 40 IF (W(CURHI).EQ.0.0E0) GO TO 50 DIFF = X(CURHI) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMWD2 = SUMWD2 + W(CURHI)*DIFF*DIFF SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 50 CURHI = CURHI + 1 GO TO 20 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 60 IF (CURHI.GT.HI) GO TO 80 DO 70 I=CURHI,HI IF (W(I).EQ.0.0E0) GO TO 70 DIFF = X(I) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMWD2 = SUMWD2 + W(I)*DIFF*DIFF SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 70 CONTINUE 80 IF (CURLO.LT.LO) GO TO 100 DO 90 IREV=LO,CURLO I = LO - IREV + CURLO IF (W(I).EQ.0.0E0) GO TO 90 DIFF = X(I) - XMEANW SUMDA = SUMDA + ABS(DIFF) SUMWD2 = SUMWD2 + W(I)*DIFF*DIFF SUMD2 = SUMD2 + DIFF*DIFF SUMD3 = SUMD3 + DIFF*DIFF*DIFF SUMD4 = SUMD4 + DIFF*DIFF*DIFF*DIFF 90 CONTINUE 100 RETURN END *SUMWSS SUBROUTINE SUMWSS(X, W, N, LO, MID, HI, NNZW, SUM1, SUMW1, SUMW2, + SUMWA, SUMW, XMEAN, XMEANW) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE WEIGHTED AND UNWEIGHTED SUMS OF C POWERS AND THE MEAN FOR A SORTED VECTOR IN WHICH THE MID TH C ELEMENT IS THE ELEMENT CLOSEST TO ZERO. USED BY THE STAT C FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + SUM1,SUMW,SUMW1,SUMW2,SUMWA,XMEAN,XMEANW INTEGER + HI,LO,MID,N,NNZW C C ARRAY ARGUMENTS REAL + W(N),X(N) C C LOCAL SCALARS INTEGER + CURHI,CURLO,I,IREV C C INTRINSIC FUNCTIONS INTRINSIC ABS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C INTEGER HI C INPUT PARAMETER. THE UPPER BOUND OF THE INITIAL C INTERVAL. C INTEGER I C LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER LO C INPUT PARAMETER. THE LOWER BOUND OF THE INITIAL C INTERVAL. C INTEGER MID C INPUT PARAMETER. THE INDEX OF THE ELEMENT IN X CLOSEST TO C ZERO IN VALUE. THE POINT OUT FROM WHICH THE SUMMING IS C DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C INTEGER NNZW C INPUT PARAMETER. THE NUMBER OF POSITIVELY WEIGHTED VALUES C IN X. C REAL SUMW C OUTPUT PARAMETER. THE SUM OF THE WEIGHTS WT(I). C REAL SUMWA C OUTPUT PARAMETER. THE WEIGHTED SUM OF THE ABSOLUTE C VALUES OF THE ELEMENTS OF X. C REAL SUMW1 C OUTPUT PARAMETER. THE WEIGHTED SUM OF THE ELEMENTS OF C X. C REAL SUMW2 C OUTPUT PARAMETER. THE WEIGHTED SUM OF THE SQUARES OF C THE ELEMENTS OF X. C REAL SUM1 C OUTPUT PARAMETER. THE UNWEIGHTED SUM OF THE ELEMENTS OF X. C REAL W(N) C INPUT PARAMETER. THE ARRAY OF WEIGHTS. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN. C REAL XMEAN C OUTPUT PARAMETER. THE UNWEIGHTED MEAN OF X. C REAL XMEANW C OUTPUT PARAMETER. THE WEIGHTED MEAN OF X. C C INITIALIZE SUMMATION VARIABLES. C SUM1 = 0.0E0 SUMW1 = 0.0E0 SUMW2 = 0.0E0 SUMWA = 0.0E0 SUMW = 0.0E0 IF (W(MID).EQ.0.0E0) GO TO 10 SUM1 = X(MID) SUMW1 = W(MID)*X(MID) SUMW2 = W(MID)*X(MID)*X(MID) SUMWA = W(MID)*ABS(X(MID)) SUMW = W(MID) 10 CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS, FROM THE VALUE NEAREST ZERO. THAT IS, FROM C THE LEAST IN MAGNITUDE TO THE GREATEST. C 20 IF (CURHI.GT.HI .OR. CURLO.LT.LO) GO TO 60 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 40 IF (W(CURLO).EQ.0.0E0) GO TO 30 SUM1 = SUM1 + X(CURLO) SUMW1 = SUMW1 + W(CURLO)*X(CURLO) SUMW2 = SUMW2 + W(CURLO)*X(CURLO)*X(CURLO) SUMWA = SUMWA + W(CURLO)*ABS(X(CURLO)) SUMW = SUMW + W(CURLO) 30 CURLO = CURLO - 1 GO TO 20 40 IF (W(CURHI).EQ.0.0E0) GO TO 50 SUM1 = SUM1 + X(CURHI) SUMW1 = SUMW1 + W(CURHI)*X(CURHI) SUMW2 = SUMW2 + W(CURHI)*X(CURHI)*X(CURHI) SUMWA = SUMWA + W(CURHI)*ABS(X(CURHI)) SUMW = SUMW + W(CURHI) 50 CURHI = CURHI + 1 GO TO 20 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 60 IF (CURHI.GT.HI) GO TO 80 DO 70 I=CURHI,HI IF (W(I).EQ.0.0E0) GO TO 70 SUM1 = SUM1 + X(I) SUMW1 = SUMW1 + W(I)*X(I) SUMW2 = SUMW2 + W(I)*X(I)*X(I) SUMWA = SUMWA + W(I)*ABS(X(I)) SUMW = SUMW + W(I) 70 CONTINUE 80 IF (CURLO.LT.LO) GO TO 100 DO 90 IREV=LO,CURLO I = LO - IREV + CURLO IF (W(I).EQ.0.0E0) GO TO 90 SUM1 = SUM1 + X(I) SUMW1 = SUMW1 + W(I)*X(I) SUMW2 = SUMW2 + W(I)*X(I)*X(I) SUMWA = SUMWA + W(I)*ABS(X(I)) SUMW = SUMW + W(I) 90 CONTINUE 100 XMEAN = SUM1/NNZW XMEANW = SUMW1/SUMW RETURN END *SUMWTS SUBROUTINE SUMWTS(X, W, N, NNZW, ALPHA, SUMT1, SUMTW1, XTRM, + XTRMW) C C LATEST REVISION - 03/15/90 (JRD) C C A ROUTINE TO CALCULATE THE WEIGHTED AND UNWEIGHTED MEANS C FOR A SORTED VECTOR IN WHICH THE MIDTH ELEMENT IS THE C ELEMENT CLOSEST TO ZERO. USED BY THE STAT FAMILY. C C WRITTEN BY - JOHN E. KOONTZ C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - MAY 17, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + ALPHA,SUMT1,SUMTW1,XTRM,XTRMW INTEGER + N,NNZW C C ARRAY ARGUMENTS REAL + W(N),X(N) C C LOCAL SCALARS REAL + SUMW INTEGER + CURHI,CURLO,I,IREV,ITHI,ITLO,MID,NALPHA,NUM C C EXTERNAL SUBROUTINES EXTERNAL SUMBS C C INTRINSIC FUNCTIONS INTRINSIC ABS,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALPHA C INPUT PARAMETER. THE PERCENTAGE OF POINTS TO TRIM C FROM EACH END OF THE ARRAY X FOR THE TRIMMED MEAN. C INTEGER CURHI C THE UPPER BOUND OF THE CURRENT INTERVAL. C INTEGER CURLO C THE LOWER BOUND OF THE CURRENT INTERVAL. C INTEGER I C LOOP PARAMETER. C INTEGER IREV C A VARIABLE WHICH RUNS IN THE SAME INTERVAL AS I, BUT C IN THE REVERSE ORDER. C INTEGER ITHI C THE COMPUTED UPPER BOUND SUCH THAT ALPHA PER C CENT OF THE POSITIVELY WEIGHTED POINTS ARE C OMITTED. C INTEGER ITLO C THE COMPUTED LOWER BOUND SUCH THAT ALPHA PER C CENT OF THE POSITIVELY WEIGHTED POINTS ARE C OMITTED. C INTEGER MID C THE INDEX OF THE ELEMENT IN X CLOSEST TO ZERO IN VALUE. C THE POINT OUT FROM WHICH THE SUMMING IS DONE. C INTEGER N C INPUT PARAMETER. THE LENGTH OF THE ARRAY X. C INTEGER NALPHA C THE INTEGER WHICH IS ALPHA PER CENT OF N. C INTEGER NNZW C INPUT PARAMETER. THE NUMBER OF POSITIVELY WEIGHTED C VALUES IN X. C INTEGER NUM C THE NUMBER OF POINTS OMITTED SO FAR. C REAL SUMTW1 C OUTPUT PARAMETER. THE WEIGHTED SUM OF THE TRIMMED ARRAY C X. C REAL SUMT1 C OUTPUT PARAMETER. THE UNWEIGHTED SUM OF THE TRIMMED C ARRAY. ZERO-WEIGHTED ELEMENTS ARE OMITTED. C REAL SUMW C THE SUM OF THE WEIGHTS W(I). C REAL W(N) C INPUT PARAMETER. THE ARRAY OF WEIGHTS. C REAL X(N) C INPUT PARAMETER. THE DATA ARRAY X IN WHICH THE SUMS ARE TAKEN. C REAL XTRM C OUTPUT PARAMETER. THE UNWEIGHTED, TRIMMED MEAN OF X. C REAL XTRMW C OUTPUT PARAMETER. THE WEIGHTED, TRIMMED MEAN OF X. C C SET UP LIMITS TRIMMING THE NUMBER OF NON-ZERO WEIGHTED C VALUES BY ALPHA PER CENT AT EACH END OF THE RANGE OF C VALUES. C NALPHA = ALPHA*NNZW NUM = 0 DO 10 I=1,N IF (W(I).EQ.0.0E0) GO TO 10 NUM = NUM + 1 IF (NUM.EQ.NALPHA+1) GO TO 20 10 CONTINUE 20 ITLO = I NUM = 0 DO 30 I=1,N IREV = N - I + 1 IF (W(IREV).EQ.0.0E0) GO TO 30 NUM = NUM + 1 IF (NUM.EQ.NALPHA+1) GO TO 40 30 CONTINUE 40 ITHI = IREV CALL SUMBS(X, N, ITLO, MID, ITHI) C C INITIALIZE SUMMATION VARIABLES. C SUMT1 = 0.0E0 SUMTW1 = 0.0E0 SUMW = 0.0E0 IF (W(MID).EQ.0.0E0) GO TO 50 SUMT1 = X(MID) SUMTW1 = W(MID)*X(MID) SUMW = W(MID) 50 CURLO = MID - 1 CURHI = MID + 1 C C SUM OUTWARDS, BOULDER, COLORADO FROM THE VALUE NEAREST ZERO. THAT C THE LEAST IN MAGNITUDE TO THE GREATEST. C 60 IF (CURHI.GT.ITHI .OR. CURLO.LT.ITLO) GO TO 100 IF (ABS(X(CURHI)).LT.ABS(X(CURLO))) GO TO 80 IF (W(CURLO).EQ.0.0E0) GO TO 70 SUMT1 = SUMT1 + X(CURLO) SUMTW1 = SUMTW1 + W(CURLO)*X(CURLO) SUMW = SUMW + W(CURLO) 70 CURLO = CURLO - 1 GO TO 60 80 IF (W(CURHI).EQ.0.0E0) GO TO 90 SUMT1 = SUMT1 + X(CURHI) SUMTW1 = SUMTW1 + W(CURHI)*X(CURHI) SUMW = SUMW + W(CURHI) 90 CURHI = CURHI + 1 GO TO 60 C C SUM UP ANY VALUES WHICH MAY REMAIN BECAUSE OF AN OFF C CENTER ZERO POINT. C 100 IF (CURHI.GT.ITHI) GO TO 120 CURHI = MAX(CURHI,ITLO) DO 110 I=CURHI,ITHI IF (W(I).EQ.0.0E0) GO TO 110 SUMT1 = SUMT1 + X(I) SUMTW1 = SUMTW1 + W(I)*X(I) SUMW = SUMW + W(I) 110 CONTINUE 120 IF (CURLO.LT.ITLO) GO TO 140 CURLO = MIN(CURLO,ITHI) DO 130 IREV=ITLO,CURLO I = ITLO - IREV + CURLO IF (W(I).EQ.0.0E0) GO TO 130 SUMT1 = SUMT1 + X(I) SUMTW1 = SUMTW1 + W(I)*X(I) SUMW = SUMW + W(I) 130 CONTINUE 140 XTRM = SUMT1/(NNZW-2*NALPHA) XTRMW = SUMTW1/SUMW RETURN END *SVPC SUBROUTINE SVPC(YM, N, NS, ISYM, ILOG, ISIZE, IRLIN, IBAR, + YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH USER CONTROL OF THE PLOT SYMBOLS USED (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IRLIN,ISIZE,N,NS C C ARRAY ARGUMENTS REAL + YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', 'C', ' ', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ISCHCK = 1 MISS = .FALSE. LISYM = N C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVPC (Y, N, NS, ISYM, ILOG,'/ + ' + ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)') END *SVP SUBROUTINE SVP(YM, N, NS, ISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH USER CONTROL OF THE PLOT SYMBOLS USED (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NS C C ARRAY ARGUMENTS REAL + YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', ' ', ' ', ' '/ C C DEFINE CONSTANTS C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 1 ISIZE = -1 MISS = .FALSE. LISYM = N IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVP (Y, N, NS, ISYM)') END *SVPL SUBROUTINE SVPL(YM, N, NS, ISYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH USER CONTROL OF THE PLOT SYMBOL USED (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N,NS C C ARRAY ARGUMENTS REAL + YM(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', 'L', ' ', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 1 ISIZE = -1 MISS = .FALSE. LISYM = N IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YM, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVPL (Y, N, NS, ISYM, ILOG)') END *SVPMC SUBROUTINE SVPMC(YM, YMMISS, N, NS, ISYM, ILOG, ISIZE, + IRLIN, IBAR, YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED 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 - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IRLIN,ISIZE,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', 'M', 'C', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ISCHCK = 1 MISS = .TRUE. LISYM = N C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVPMC (Y, YMISS, N, NS, ISYM, ILOG,'/ + ' + ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)') END *SVPM SUBROUTINE SVPM(YM, YMMISS, N, NS, ISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED C (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', 'M', ' ', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 1 ISIZE = -1 MISS = .TRUE. LISYM = N IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVPM (Y, YMISS, N, NS, ISYM)') END *SVPML SUBROUTINE SVPML(YM, YMMISS, N, NS, ISYM, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA AND USER CONTROL OF THE PLOT SYMBOL USED C (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) INTEGER + ISYM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(N) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'S', 'V', 'P', 'M', 'L', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 1 ISIZE = -1 MISS = .TRUE. LISYM = N IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL SVPML (Y, YMISS, N, NS, ISYM, ILOG)') END *TAPER SUBROUTINE TAPER (Y, N, TAPERP, YT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER ROUTINE FOR APPLYING A SPLIT-COSINE-BELL C TAPER TO THE (CENTERED) OBSERVED SERIES Y, RETURNING THE TAPERED C SERIES IN YT. THIS ROUTINE IS ADAPTED FROM BLOOMFIELDS C ROUTINE TAPER. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + TAPERP INTEGER + N C C ARRAY ARGUMENTS REAL + Y(*),YT(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + PI,WEIGHT INTEGER + I,IPRT,J,M LOGICAL + ERR01,HEAD C C LOCAL ARRAYS CHARACTER + LN(8)*1,NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL CENTER,EISGE,GETPI,IPRINT C C INTRINSIC FUNCTIONS INTRINSIC COS,INT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR01 C VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT C (FALSE). C LOGICAL HEAD C A VARIABLE USED TO INDICARE WHETHER A HEADING IS NEEDED FOR C ERROR MESSAGES (TRUE) OR NOT (FALSE). C INTEGER I C AN INDEXING VARIABLE. 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 LOGICAL UNIT NUMBER USED FOR OUTPUT. C INTEGER J C AN INDEXING VARIABLE. C CHARACTER*1 LN(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE PARAMETER(S) CHECKED C FOR ERRORS. C INTEGER M C THE NUMBER OF POINTS AT EACH END OF THE SERIES TO BE C TAPERED. 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 REAL PI C THE VALUE OF PI. C REAL TAPERP C THE TOTAL PERCENTAGE OF THE DATA TO BE TAPERED. C REAL WEIGHT C THE ITH TAPER WEIGHT. C REAL Y(N) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES. C REAL YT(N) C THE VECTOR IN WHICH THE TAPERED SERIES IS RETURNED. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'T', 'A', 'P', 'E', 'R', ' '/ 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, 17, 1, HEAD, ERR01, LN) IF (.NOT. ERR01) GO TO 5 C IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN C 5 CONTINUE C CALL CENTER (Y, N, YT) C IF ((TAPERP .LE. 0.0E0) .OR. (TAPERP .GT. 1.0E0)) RETURN C CALL GETPI(PI) C M = INT(TAPERP * N + 0.5E0) / 2 IF (M .EQ. 0) RETURN C DO 20 I = 1, M WEIGHT = 0.5E0 - 0.5E0 * COS(PI * (I-0.5E0) / M) YT(I) = WEIGHT * YT(I) J = N + 1 - I YT(J) = WEIGHT * YT(J) 20 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 36H CALL TAPER (Y, N, TAPERP, YT)) END subroutine timestamp ( ) c******************************************************************************* c cc TIMESTAMP prints out the current YMDHMS date as a timestamp. c c Discussion: c c This FORTRAN77 version is made available for cases where the c FORTRAN90 version cannot be used. c c Modified: c c 16 September 2005 c c Author: c c John Burkardt c c Parameters: c c None c implicit none character ( len = 8 ) date character ( len = 10 ) time call date_and_time ( date, time ) write ( *, '(a8,2x,a10)' ) date, time return end *UASCFT SUBROUTINE UASCFT (ACOV, LAGMAX, LACOV, IAR, PHI, N, VAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE AUTOREGRESSIVE MODEL COEFFICIENTS C FOR AN ORDER IAR MODEL USING DURBINS RECURSIVE METHOD. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + VAR INTEGER + IAR,LACOV,LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(LACOV),PHI(IAR) C C LOCAL SCALARS REAL + RSS INTEGER + L C C EXTERNAL SUBROUTINES EXTERNAL ARCOEF C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE ARRAY OF AUTOCOVARIANCE ESTIMATES. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER L C AN INDEX VARIABLE. C INTEGER LACOV C THE LENGTH OF THE ARRAY ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C REAL PHI(IAR) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RSS, VAR C C PHI(1) = ACOV(2) / ACOV(1) RSS = ACOV(1) * N * (1.0E0 - PHI(1)*PHI(1)) C IF (IAR .LE. 1) GO TO 20 C DO 10 L = 2, IAR CALL ARCOEF(ACOV(2), PHI, RSS, L, LAGMAX, ACOV(1)) 10 CONTINUE C 20 VAR = RSS / (N-IAR-1) C RETURN C END *UASDV SUBROUTINE UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, + FREQ, N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT, + ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, + WINDOW, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN DRIVER FOR COMPUTING THE AUTOREGRESSIVE C (AND FOURIER) SPECTRUMS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALPHA,DELTA,FMAX,FMIN,VAR INTEGER + IAR,LACOV,LAG,LAGMAX,LAIC,LPCV,LPHI,LSPC,LWORK,N,NF,NPRT C C ARRAY ARGUMENTS REAL + ACOV(LACOV),AIC(LAIC),FREQ(NF),FTEST(2,LAGMAX),PHI(LPHI), + SPCA(LSPC),SPCF(LSPC),WORK(LWORK),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISORT(NF),ISYM(LPCV) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL WINDOW C C LOCAL SCALARS REAL + ALOW,AUP,BW,DF,SPCAMN,SPCAMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX, + YPLTMN,YPLTMX INTEGER + ISPCER,NPTS,NSPCA,NSPCF,NW LOGICAL + AICPRT C C LOCAL ARRAYS INTEGER + LAGS(1),NLPPA(1) C C EXTERNAL SUBROUTINES EXTERNAL AOS,SETFRQ,SPCCK,UASCFT,UASEST,UASORD,UASOUT,UFSLAG,UFSMN C C INTRINSIC FUNCTIONS INTRINSIC IABS,INT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS. C REAL AIC(LAIC) C THE ARRAY CONTAINING THE AKAIKES CRITERIA FOR EACH ORDER(?). C LOGICAL AICPRT C AN INDICATOR VARIABLE USED TO DETERMINE IF THE AKIAKE C INFORMATION CRITERIA AND CHI SQUARED STATISTICS SHOULD C BE PRINTED. C REAL ALOW C A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL AUP C A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS. C REAL BW C THE BANDWIDTH. C REAL DELTA C THE SAMPLING INTERVAL. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL FTEST(2,LAGMAX) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER ISORT(NF) C AN ARRAY USED FOR SORTING. C INTEGER LSPC C THE ACTUAL FIRST DIMENSION FOR THE SPECTRUM ARRAYS. C INTEGER ISPCER C AN ERROR FLAG USED FOR THE SPECTRUM PLOTS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(1) C THE LAG WINDOW TRUNCATION POINT RETURNED FROM UFSLAG. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LWORK C THE ACTUAL LENGTH OF THE WORK ARRAY. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NLPPA(1) C A DUMMY ARRAY C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C INTEGER NSPCA, NSPCF C THE NUMBER OF VALID SPECTRUM ESTIMATES FOR THE AUTOREGRESSIVE C AND FOURIER SPECTRUMS, RESPECTIVELY. C INTEGER NW C THE NUMBER OF LAG WINDOW TRUNCATION POINTS SELCTED. C REAL PHI(LPHI) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL SPCA(LSPC) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCAMN, SPCAMX C THE MINIMUM AND MAXIMUM AUTOREGRESSIVE SPECTRUM VALUE TO BE C PLOTTED. C REAL SPCF(LSPC) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL SPCFMN, SPCFMX C THE MINIMUM AND MAXIMUM FOURIER SPECTRUM VALUE TO BE PLOTTED. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C EXTERNAL WINDOW C THE TYPE OF WINDOW TO BE USED. C REAL WORK(LWORK) C THE WORK ARRAY. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C NW = 1 C IF (LAG.LE.0) THEN C C SET THE LAG WINDOW TRUNCATION POINT TO BE USED FOR THE C FOURIER SPECTRUM ESTIMATES. C CALL UFSLAG(ACOV, LAGMAX, LAGS, N, NW, NW, LACOV) LAG = LAGS(1)/2 END IF C C SET FREQUENCIES FOR THE SPECTRUM. C CALL SETFRQ(FREQ, NF, 1, FMIN, FMAX, DELTA) C C COMPUTE THE FOURIER SPECTRUM ESTIMATES C CALL UFSMN(ACOV, NLPPA, LAG, DF, NF, FREQ, ALPHA, BW, SPCF, + ALOW, AUP, LACOV, LSPC, WINDOW, WORK, LWORK, N, DELTA, + .FALSE., 1) C AICPRT = .FALSE. C IF (IAR.LT.0) THEN C C USER HAS CHOSEN ORDER. C COMPUTE COEFFICIENTS AND VARIANCE USING DURBINS RECURSIVE METHOD. C CALL UASCFT(ACOV, LAGMAX, LACOV, IABS(IAR), PHI, N, VAR) C ELSE IF (IAR.EQ.0) THEN C C SELECT MODEL ORDER AND COMPUTE COEFFICIENTS AND VARIANCE. C AICPRT = .TRUE. CALL AOS(N, LAGMAX, ACOV, WORK, IAR, VAR, PHI, + WORK, AIC, FTEST, LACOV, LAIC) END IF C C COMPUTE THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C CALL UASEST(IABS(IAR), VAR, PHI, NF, FREQ, DELTA, SPCA, LPHI, + LSPC) C IF (NPRT.EQ.0) RETURN C C SET PLOTTING VECTORS. C XPLTMN = FMIN XPLTMX = FMAX C YPLTMN = 0.0E0 YPLTMX = 0.0E0 C CALL SPCCK(SPCF, ISORT, NF, SPCFMN, SPCFMX, NSPCF, ISPCER) IF (ISPCER.NE.0) GO TO 40 CALL SPCCK(SPCA, ISORT, NF, SPCAMN, SPCAMX, NSPCA, ISPCER) IF (ISPCER.NE.0) GO TO 40 C CALL UASORD(SPCF, SPCA, SPCFMN, SPCFMX, SPCAMN, SPCAMX, FREQ, NF, + XAXIS, YAXIS, ISYM, NPTS, LSPC, LPCV, NSPCF, NSPCA, BW, ALOW, + AUP, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT) C C PRINT RESULTS C 40 CALL UASOUT(XAXIS, YAXIS, ISYM, NPTS, BW, INT(DF+0.5E0), LAG, + IABS(IAR), PHI, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX, + FTEST, AIC, LAIC, VAR, NPRT, LAGMAX, AICPRT, N, NMSUB) C RETURN END *UASER SUBROUTINE UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES C FOURIER UNIVARIATE SPECTRUM ANALYSIS 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 (JRD) C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + IAR,LACOV,LAG,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NF,NFFT C C ARRAY ARGUMENTS REAL + ACOV(*),PHI(*) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERR(20) CHARACTER + L1(8)*1,LACV(8)*1,LACV1M(8)*1,LACV1P(8)*1,LIAR(8)*1, + LLACOV(8)*1,LLAG(8)*1,LLDS(8)*1,LLGMX(8)*1,LLGMX1(8)*1, + LLGMXM(8)*1,LLGMXP(8)*1,LLYFFT(8)*1,LN(8)*1,LNF(8)*1, + LNM1(8)*1,LPHI(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,ERVII C C INTRINSIC FUNCTIONS INTRINSIC ABS,IABS C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE FUNCTION. C LOGICAL ERR(20) 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 IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C CHARACTER*1 LACV(8), LACV1M(8), LACV1P(8), C * LIAR(8), LLACOV(8), LLAG(8), LLGMX(8), LLGMXM(8), C * LLGMXP(8), LLGMX1(8), LLDS(8), LN(8), LNF(8), LNM1(8), C * LLYFFT(8), LPHI(8), L1(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S) C CHECKED FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C REAL PHI(IAR) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C C C SET UP NAME ARRAYS C DATA LACV(1), LACV(2), LACV(3), LACV(4), LACV(5), LACV(6), + LACV(7), LACV(8) /'A','C','O','V',' ',' ',' ',' '/ DATA LACV1M(1), LACV1M(2), LACV1M(3), LACV1M(4), LACV1M(5), + LACV1M(6), LACV1M(7), LACV1M(8) /'-','A','C','O','V','(','1', + ')'/ DATA LACV1P(1), LACV1P(2), LACV1P(3), LACV1P(4), LACV1P(5), + LACV1P(6), LACV1P(7), LACV1P(8) /'+','A','C','O','V','(','1', + ')'/ DATA LIAR(1), LIAR(2), LIAR(3), LIAR(4), LIAR(5), + LIAR(6), LIAR(7), LIAR(8) /'I','A','R',' ',' ',' ',' ', + ' '/ DATA LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5), + LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ', + ' '/ DATA LLAG(1), LLAG(2), LLAG(3), LLAG(4), LLAG(5), LLAG(6), + LLAG(7), LLAG(8) /'L','A','G',' ',' ',' ',' ',' '/ DATA LLGMX(1), LLGMX(2), LLGMX(3), LLGMX(4), LLGMX(5), + LLGMX(6), LLGMX(7), LLGMX(8) /'L','A','G','M','A','X',' ', + ' '/ DATA LLGMXM(1), LLGMXM(2), LLGMXM(3), LLGMXM(4), LLGMXM(5), + LLGMXM(6), LLGMXM(7), LLGMXM(8) /'-','L','A','G','M','A','X', + ' '/ DATA LLGMXP(1), LLGMXP(2), LLGMXP(3), LLGMXP(4), LLGMXP(5), + LLGMXP(6), LLGMXP(7), LLGMXP(8) /'+','L','A','G','M','A','X', + ' '/ DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5), + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+', + '1'/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), + LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/ DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), + LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/ DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ', + ' '/ DATA LPHI(1), LPHI(2), LPHI(3), LPHI(4), LPHI(5), LPHI(6), + LPHI(7), LPHI(8) /'P','H','I',' ',' ',' ',' ',' '/ DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1', + ' ',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C C IERR = 0 HEAD = .TRUE. C DO 10 I=1,20 ERR(I) = .FALSE. 10 CONTINUE C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR(1), LN) C IF ((.NOT.OPTION(3))) GO TO 15 C CALL ERVII(NMSUB, LACV, ACOV, LAGMAX+1, -ABS(ACOV(1)), + ABS(ACOV(1)), 0, HEAD, 4, NV, ERR(15), LACV1M, LACV1P) C CALL EISII(NMSUB, LLGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2), + L1, LNM1) C IF (OPTION(2)) THEN CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 8, HEAD, ERR(3), + LLGMX1) ELSE CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 7, HEAD, ERR(3), + LLGMX1) END IF C 15 IF (OPTION(1) .AND. (.NOT.ERR(1))) + CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR(4), + LLYFFT) C IF (OPTION(1) .AND. (.NOT.OPTION(4))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(5), LLDS) C IF (OPTION(4)) GO TO 30 C DO 20 I=1,15 IF (ERR(I)) GO TO 50 20 CONTINUE C RETURN C 30 CONTINUE C CALL EISII(NMSUB, LIAR, IAR, -IABS(LAGMAX), IABS(LAGMAX), 1, HEAD, + ERR(6), LLGMXM, LLGMXP) C CALL ERVII(NMSUB, LPHI, PHI, IAR, -1.0E0, 1.0E0, 0, HEAD, 1, NV, + ERR(7), L1, L1) C IF (.NOT.OPTION(3)) + CALL EISII(NMSUB, LLGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2), + L1, LNM1) C CALL EISII(NMSUB, LLAG, LAG, -IABS(LAGMAX), IABS(LAGMAX), 1, HEAD, + ERR(8), LLGMXM, LLGMXP) C CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR(9), LNF) C IF (ERR(1) .OR. ERR(2) .OR. ERR(9)) GO TO 50 C CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(14), LLDS) C DO 40 I=1,15 IF (ERR(I)) GO TO 50 40 CONTINUE C RETURN C 50 CONTINUE IERR = 1 RETURN C END *UASEST SUBROUTINE UASEST (IAR, VAR, PHI, NF, FREQ, DELTA, SPCA, LPHI, + ISPC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE CALCULATES THE AUTOREGRESSIVE SPECTRUM. IT IS C MODELED AFTER SUBROUTINE UASEC BY DICK JONES. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + DELTA,VAR INTEGER + IAR,ISPC,LPHI,NF C C ARRAY ARGUMENTS REAL + FREQ(NF),PHI(LPHI),SPCA(ISPC) C C LOCAL SCALARS REAL + ARG,EI,ER,EXI,EXR,EXRTMP,PI,TI,TR INTEGER + I,J C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC COS,SIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ARG C THE ARGUMENT FOR THE SINE AND COSINE FUNCTIONS USED IN C CALCULATIONS OF THE SPECTRUM. C REAL DELTA C THE SAMPLING INTERVAL. C REAL EI, ER, EXI, EXR, EXRTMP C 'COMPLEX' VARIABLES USED IN THE COMPUTATIONS. C REAL FREQ(NF) C THE ARRAY CONTAINING THE FREQUENCIES AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER ISPC C THE LENGTH OF THE ARRAY SPCA. C INTEGER J C AN INDEX VARIABLE. C INTEGER LPHI C THE LENGTH OF THE ARRAY PHI. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL PHI(LPHI) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL PI C THE VALUE OF PI. C REAL SPCA(ISPC) C THE ARRAY IN WHICH THE AUTOREGRESSIVE SPECTRUM IS STORED. C REAL TI, TR C A VARIABLE USED IN THE COMPUTATIONS. C REAL VAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED ORDER (IAR). C CALL GETPI(PI) C DO 20 J=1,NF SPCA(J) = DELTA * VAR IF (IAR.GE.1) THEN IF (DELTA.EQ.1.0E0) THEN IF (FREQ(J).EQ.0.0E0) THEN ER = 1.0E0 EI = 0.0E0 ELSE IF (FREQ(J).EQ.0.25E0) THEN ER = 0.0E0 EI = 1.0E0 ELSE IF (FREQ(J).EQ.0.5E0) THEN ER = -1.0E0 EI = 0.0E0 ELSE ARG = 2.0E0 * PI * DELTA * FREQ(J) ER = COS(ARG) EI = SIN(ARG) END IF ELSE ARG = 2.0E0 * PI * DELTA * FREQ(J) ER = COS(ARG) EI = SIN(ARG) END IF EXR = 1.0E0 EXI = 0.0E0 TR = 1.0E0 TI = 0.0E0 DO 10 I=1,IAR EXRTMP = EXR*ER - EXI*EI EXI = EXR*EI + EXI*ER EXR = EXRTMP TR = TR - PHI(I) * EXR TI = TI - PHI(I) * EXI 10 CONTINUE SPCA(J) = SPCA(J)/(TR*TR + TI*TI) END IF 20 CONTINUE RETURN END *UAS SUBROUTINE UAS (Y, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,VAR,YMEAN INTEGER + IAR,IPRT,LACOV,LAG,LAGMAX,LAIC,LDSMIN,LDSTAK,LPCV,LPHI, + LSPC,LWORK,NF,NPRT C C LOCAL ARRAYS REAL + ACOV(101),AIC(101),FREQ(101),FTEST(2,100),PHI(100),SPCA(101), + SPCF(101),WORK(101),XAXIS(207),YAXIS(207) INTEGER + ISORT(101),ISYM(207) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ACVF,IPRINT,PARZEN,SETLAG,UASDV,UASER C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS. C REAL AIC(101) C THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL FTEST(2, 100) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISYM(207) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER LWORK C THE LENGTH OF THE VECTOR WORK. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL SPCA(101) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(101) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE FOR THE SELECTED MODEL. C REAL WORK(101) C A REAL WORK AREA USED FOR THE LAG WINDOWS AND FOR C COMPUTING THE AUTOREGRESSIVE COEFFICIENTS. C REAL XAXIS(207) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YAXIS(207) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', ' ', ' ', ' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .FALSE. C LAG = 0 IAR = 0 NF = 101 FMIN = 0.0E0 FMAX = 0.5E0 NPRT = -1 LDSTAK = 0 LDSMIN = 0 C C SET THE MAXIMUM NUMBER OF LAGS TO BE USED. C CALL SETLAG(N, LAGMAX) C C CALL ERROR CHECKING ROUTINE C CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, N, N, OPTION) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = 207 LSPC = 101 LPHI = 100 LAIC = 101 LACOV = 101 LWORK = 101 C ALPHA = .95E0 DELTA = 1.0E0 C C COMPUTE AUTOCOVARIANCES C CALL ACVF (Y, N, YMEAN, ACOV, LAGMAX, LACOV) C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ, + N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT, + ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, + PARZEN, NMSUB) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + 22H CALL UAS (Y, N)) END *UASF SUBROUTINE UASF (YFFT, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION USING THE FFT (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,VAR,YMEAN INTEGER + IAR,IFP,IPRT,LACOV,LAG,LAGMAX,LAIC,LDSMIN,LPCV,LPHI,LSPC, + LWORK,NALL0,NF,NFFT,NPRT,WORK C C LOCAL ARRAYS REAL + ACOV(101),AIC(101),FREQ(101),FTEST(2,100),PHI(100),RSTAK(12), + SPCA(101),SPCF(101),XAXIS(207),YAXIS(207) INTEGER + ISORT(101),ISTAK(12),ISYM(207) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVFF,IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKCLR,STKSET, + UASDV,UASER C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISYM(1),ISORT(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS. C REAL AIC(101) C THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL FTEST(2, 100) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER ISYM(207) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LWORK C THE LENGTH OF THE WORK ARRAY. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCA(101) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(101) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C INTEGER WORK C THE STARTING LOCATION IN RSTAK FOR C THE WORK VECTOR. C REAL XAXIS(207) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YAXIS(207) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', 'F', ' ', ' '/ C IFP = 3 C C SET UP FOR ERROR CHECKING C OPTION(1) = .TRUE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .FALSE. C LAG = 0 IAR = 0 NF = 101 FMIN = 0.0E0 FMAX = 0.5E0 NPRT = -1 C C SET THE MAXIMUM NUMBER OF LAGS TO BE USED. C CALL SETLAG(N, LAGMAX) C C SET LENGTH OF EXTENDED SERIES C CALL SETESL(N+LAGMAX, 4, NFFT) C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET THE SIZE OF THE WORK AREA C CALL STKSET(LDSTAK, 4) C C SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LPCV = 207 LSPC = 101 LPHI = 100 LAIC = 101 LACOV = 101 LWORK = NFFT C ALPHA = 0.95E0 DELTA = 1.0E0 C C SUBDIVIDE THE WORK AREA C WORK = STKGET(LWORK, IFP) C C COMPUTE AUTOCOVARIANCES C CALL ACVFF (YFFT, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, LYFFT, + RSTAK(WORK), LWORK) C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ, + N, LAGMAX, FTEST, AIC, RSTAK(WORK), LACOV, LWORK, DELTA, ISORT, + ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, + PARZEN, NMSUB) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UASF (YFFT, N, LYFFT, LDSTAK)') END *UASFS SUBROUTINE UASFS (YFFT, N, LYFFT, LDSTAK, IAR, PHI, LAGMAX, LAG, + NF, FMIN, FMAX, NPRT, SPCA, SPCF, FREQ) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION USING THE FFT (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + IAR,LAG,LAGMAX,LDSTAK,LYFFT,N,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),PHI(*),SPCA(*),SPCF(*),YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMN,FMX,VAR,YMEAN INTEGER + ACOV,AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC, + LDSMIN,LPCV,LPHI,LSPC,LWORK,NALL0,NFFT,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVFF,AMEAN,IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET, + UASDV,UASER,UASVAR C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN RSTAK FOR THE ARRAY OF C THE AUTOCOVARIANCE ARRAY. C INTEGER AIC C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY CONTAINING THE AIC. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FMN, FMX C THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C INTEGER FTEST C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IA C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR C HAS BEEN PROVIDED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION IN ISTAK FOR C AN ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER LWORK C THE ACTUAL LENGTH OF THE WORK ARRAY. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE C WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCA(NF) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(NF) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C INTEGER WORK C THE STARTING LOCATION IN THE STACK FOR C THE WORK ARRAY. C INTEGER XAXIS C THE STARTING LOCATION IN RSTAK FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C INTEGER YAXIS C THE STARTING LOCATION IN RSTAK FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', 'F', 'S', ' '/ C IFP = 3 C C SET UP FOR ERROR CHECKING C OPTION(1) = .TRUE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .TRUE. C C SET EXTENDED SERIES LENGTH C CALL SETESL(N+LAGMAX, 4, NFFT) C IO = 1 IF (NPRT .EQ. 0) IO = 0 IA = 1 IF (IAR .NE. 0) IA = 0 C CALL LDSCMP(7, 0, IO*(2*NF+5), 0, 0, 0, 'S', + LAGMAX+1+NFFT+IA*(3*LAGMAX+1)+IO*(4*NF+10), LDSMIN) C CALL UASER(NMSUB, N, YFFT, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION) C 5 IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET SIZE OF WORK AREA. C CALL STKSET (LDSTAK, 4) C C SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LSPC = NF LPCV = 2*NF + 5 LPHI = LAGMAX LACOV = LAGMAX + 1 LWORK = NFFT C FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF C ALPHA = 0.95E0 DELTA = 1.0E0 C IF (IAR.GE.1) THEN C C USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS. C COMPUTE RESIDUAL VARIANCE. C CALL AMEAN(YFFT, N, YMEAN) CALL UASVAR (YFFT, YMEAN, N, IAR, PHI, VAR) END IF C C COMPUTE AUTOCOVARIANCES C ACOV = STKGET(LACOV, IFP) WORK = STKGET(LWORK, IFP) C CALL ACVFF (YFFT, N, NFFT, YMEAN, RSTAK(ACOV), LAGMAX, LAGMAX+1, + LYFFT, RSTAK(WORK), NFFT) C C SET UP ADDITIONAL STACK WORK AREA, IF NEEDED. C IF (IAR.EQ.0) THEN LAIC = LAGMAX+1 AIC = STKGET(LAIC, IFP) FTEST = STKGET(2*LAGMAX, IFP) ELSE LAIC = LWORK AIC = WORK FTEST = WORK END IF IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV, IFP) YAXIS = STKGET(LPCV, IFP) ISYM = STKGET(LPCV, 2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = WORK END IF C IF (IERR.EQ.1) GO TO 5 C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(RSTAK(ACOV), SPCA, SPCF, LSPC, IAR, PHI, NF, FMN, + FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK), + LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN, + NMSUB) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UASFS (YFFT, N, LYFFT, LDSTAK,'/ + ' + IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX, NPRT'/ + ' + SPCA, SPCF, FREQ)') END *UASORD SUBROUTINE UASORD (SPCF, SPCA, SPCFMN, SPCFMX, SPCAMN, SPCAMX, + FREQ, NF, XAXIS, YAXIS, ISYM, NPTS, ISPC, LPCV, NSPCF, NSPCA, + BW, ALOW, AUP, XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRUM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALOW,AUP,BW,SPCAMN,SPCAMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX,YPLTMN, + YPLTMX INTEGER + ISPC,LPCV,NF,NPRT,NPTS,NSPCA,NSPCF C C ARRAY ARGUMENTS REAL + FREQ(NF),SPCA(ISPC),SPCF(ISPC),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C LOCAL SCALARS REAL + CILOW,CIMID,CIUP,YMAX INTEGER + I,ISPCA,ISPCF C C EXTERNAL SUBROUTINES EXTERNAL SPPLTC,SPPLTD,SPPLTL C C INTRINSIC FUNCTIONS INTRINSIC LOG10,MAX,MIN C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALOW C THE FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS. C REAL AUP C THE FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS. C REAL BW C THE BANDWIDTH. C REAL CILOW, CIMID, CIUP C THE Y AXIS VALUES FOR THE LOWER, MID AND UPPER CONFIDENCE C INTERVAL POINTS. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C INTEGER I C AN INDEX VARIABLE C INTEGER ISPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER ISPCA, ISPCF C THE INDEX FOR THE FOURIER AND AUTOREGRESSIVE ESTIMATES, C RESPECTIVELY. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C INTEGER NSPCA, NSPCF C THE NUMBER OF VALID SPECTRUM ESTIMATES FOR THE AUTOREGRESSIVE C AND FOURIER SPECTRUMS, RESPECTIVELY. C REAL SPCA(ISPC) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCAMN, SPCAMX C THE MINIMUM AND MAXIMUM AUTOREGRESSIVE SPECTRUM VALUE TO BE C PLOTTED. C REAL SPCF(ISPC) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL SPCFMN, SPCFMX C THE MINIMUM AND MAXIMUM FOURIER SPECTRUM VALUE TO BE PLOTTED. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMAX C THE MAXIMUM ACTUAL SPECTRUM VALUE (IN DECIBLES) TO BE PLOTTED. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAYIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C ISPCF = 0 ISPCA = NSPCF C IF (NPRT.GE.1) GO TO 30 C C SET VARIOUS Y AXIS VALUES FOR DECIBLE PLOTS C CALL SPPLTD (MIN(SPCFMN, SPCAMN), MAX(SPCFMX, SPCAMX), + ALOW, AUP, YPLTMN, YPLTMX, CILOW, CIMID, CIUP, YMAX) C C SET CO-ORDINATES FOR DECIBLE PLOTS C DO 20 I = 1, NF IF (SPCF(I) .LT. SPCFMN) GO TO 10 ISPCF = ISPCF + 1 XAXIS(ISPCF) = FREQ(I) YAXIS(ISPCF) = 10.0E0 * LOG10(SPCF(I)) - YMAX ISYM(ISPCF) = 1 C 10 IF (SPCA(I) .LT. SPCAMN) GO TO 20 ISPCA = ISPCA + 1 XAXIS(ISPCA) = FREQ(I) YAXIS(ISPCA) = 10.0E0 * LOG10(SPCA(I)) - YMAX ISYM(ISPCA) = 2 20 CONTINUE C GO TO 70 30 CONTINUE C C SET VARIOUS Y AXIS VALUES FOR LOG PLOTS C CALL SPPLTL (MIN(SPCFMN, SPCAMN), MAX(SPCFMX, SPCAMX), + ALOW, AUP, YPLTMN, YPLTMX, CILOW, CIMID, CIUP) C C SET CO-ORDINATES FOR LOG PLOTS C DO 60 I = 1, NF IF (SPCF(I) .LT. SPCFMN) GO TO 50 ISPCF = ISPCF + 1 XAXIS(ISPCF) = FREQ(I) YAXIS(ISPCF) = SPCF(I) ISYM(ISPCF) = 1 C 50 IF (SPCA(I) .LT. SPCAMN) GO TO 60 ISPCA = ISPCA + 1 XAXIS(ISPCA) = FREQ(I) YAXIS(ISPCA) = SPCA(I) ISYM(ISPCA) = 2 60 CONTINUE C 70 CONTINUE C NPTS = NSPCA + NSPCF C C SET CO-ORDINATES FOR BANDWIDTH AND CONFIDENCE INTERVAL. C CALL SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW, CILOW, + CIMID, CIUP, LPCV) C RETURN END *UASOUT SUBROUTINE UASOUT (XAXIS, YAXIS, ISYM, NPTS, BW, IDF, LAG, + IAR, PHI, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX, + FTEST, AIC, LAIC, VAR, NPRT, LAGMAX, AICPRT, N, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES THE SPECTRUM PLOTS FOR THE C AUTOREGRESSIVE SPECTRUM ESTIMATES. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + BW,VAR,XPLTMN,XPLTMX,YPLTMN,YPLTMX INTEGER + IAR,IDF,ISPCER,LAG,LAGMAX,LAIC,LPCV,N,NPRT,NPTS LOGICAL + AICPRT C C ARRAY ARGUMENTS REAL + AIC(LAIC),FTEST(2,LAGMAX),PHI(LAGMAX),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) CHARACTER + NMSUB(6)*1 C C LOCAL SCALARS REAL + XMN,XMX,YMN,YMX INTEGER + ILOG,IPRT LOGICAL + ERROR C C LOCAL ARRAYS REAL + PRHO(1) C C EXTERNAL SUBROUTINES EXTERNAL AOSLST,IPRINT,PPLMT,PPMN,VERSP C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL AIC(LAIC) C THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER. C LOGICAL AICPRT C AN INDICATOR VARIABLE USED TO DETERMINE IF THE AKIAKE C INFORMATION CRITERIA AND CHI SQUARED STATISTICS SHOULD C BE PRINTED. C REAL BW C THE BANDWIDTH. C LOGICAL ERROR C AN ERROR FLAG C REAL FTEST(2,LAGMAX) C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER IDF C THE EFFECTIVE DEGREES OF FREEDOM. C INTEGER IPRT C THE LOGICAL UNIT NUMBER FOR THE OUTPUT. C INTEGER ISPCER C A VARIABLE USED TO DESIGNATE AN ERROR IN THE SPECTRAL C ESTIMATES. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR THE FOURIER SPECTRUM. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE SERIES. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE SELECTED C ORDER. C REAL PRHO(1) C A DUMMY VARIABLE. C REAL VAR C THE ONE STEP PREDICTION VARIANCE FOR ORDER IAR. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRAL PLOT. C REAL XMN, XMX C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRAL PLOT. C REAL YMN, YMX C * C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH. C CALL IPRINT (IPRT) C IF (.NOT. AICPRT) GO TO 5 C C PRINT AUTOREGRESSIVE MODEL ORDER SELECTION STATISTICS C CALL VERSP(.TRUE.) WRITE(IPRT, 1007) CALL AOSLST (PRHO, AIC, FTEST, LAGMAX, LAIC, IAR, PHI, VAR, + .FALSE., N) WRITE (IPRT, 1001) C 5 CONTINUE CALL VERSP(.TRUE.) C WRITE(IPRT, 1002) LAG, BW, IDF WRITE(IPRT, 1000) IAR IF (ISPCER .EQ. 0) GO TO 10 WRITE(IPRT, 1006) RETURN C 10 CONTINUE IF (NPRT.LE.0) THEN ILOG = 0 ELSE ILOG = 1 END IF C CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, YPLTMN, + YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB, + .FALSE.) IF (.NOT.ERROR) + CALL PPMN (YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM, + LPCV, 0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG) IF (XPLTMN .NE. 0.0E0 .OR. XPLTMX .NE. 0.5E0) RETURN WRITE (IPRT, 1004) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (11H AND ORDER , I2, 28H AUTOREGRESSIVE SPECTRUM (.)) 1001 FORMAT ('1') 1002 FORMAT (44H FOURIER SPECTRUM (+) (LAG WIND. TRUNC. PT.=, I5, + 1X, 5H/ BW=, F6.4, 1X, 6H/ EDF=, I6, ')') 1004 FORMAT(5H+FREQ/ + 7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, 6H6.6667, 4X, + 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, 3H2.5, 7X, + 6H2.2222, 4X, 2H2.) C1005 FORMAT(5H+FREQ/ C 1 7H PERIOD, 9X, 3HINF, 7X, 3H10., 4X, 2H5., 8X, 6H3.3333, 4X, C 2 3H2.5, 4X, 2H2.) 1006 FORMAT(// + 56H ** THE PLOT HAS BEEN SUPRESSED BECAUSE FEWER THAN **/ + 56H ** FOUR VALID (POSITIVE) SPECTRAL ESTIMATES COULD BE **/ + 56H ** COMPUTED. **) 1007 FORMAT (/42H AUTOREGRESSIVE ORDER SELECTION STATISTICS/) END *UASS SUBROUTINE UASS (Y, N, IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX, + NPRT, SPCA, SPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + IAR,LAG,LAGMAX,LDSTAK,N,NF,NPRT C C ARRAY ARGUMENTS REAL + FREQ(*),PHI(*),SPCA(*),SPCF(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMN,FMX,VAR,YMEAN INTEGER + ACOV,AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC, + LDSMIN,LPCV,LPHI,LSPC,LWORK,NALL0,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ACVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UASDV,UASER, + UASVAR C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN RSTAK FOR THE ARRAY OF C THE AUTOCOVARIANCE ARRAY. C INTEGER AIC C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY CONTAINING THE AIC. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FMN, FMX C THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C INTEGER FTEST C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IA C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR C HAS BEEN PROVIDED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION IN ISTAK FOR C AN ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER LWORK C THE LENGTH OF THE WORK ARRAY. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE C WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCA(NF) C THE ARRAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(NF) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C INTEGER WORK C THE STARTING LOCATION IN THE STACK FOR C THE WORK ARRAY. C INTEGER XAXIS C THE STARTING LOCATION IN RSTAK FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C INTEGER YAXIS C THE STARTING LOCATION IN RSTAK FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', 'S', ' ', ' '/ C IFP = 3 C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .FALSE. OPTION(4) = .TRUE. C IO = 1 IF (NPRT .EQ. 0) IO = 0 IA = 1 IF (IAR .NE. 0) IA = 0 C CALL LDSCMP(7, 0, IO*(2*NF+5), 0, 0, 0, 'S', + 2*LAGMAX+2+IA*(3*LAGMAX+1)+IO*(4*NF+10), LDSMIN) C C CALL ERROR CHECKING ROUTINE C CALL UASER(NMSUB, N, Y, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, N, N, OPTION) C 10 IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET SIZE OF WORK AREA. C CALL STKSET (LDSTAK, 4) C C SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LSPC = NF LPCV = 2*NF + 5 LPHI = LAGMAX LACOV = LAGMAX + 1 LWORK = LAGMAX+1 C FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF C ALPHA = 0.95E0 DELTA = 1.0E0 C C COMPUTE AUTOCOVARIANCES C ACOV = STKGET(LACOV, IFP) C CALL ACVF (Y, N, YMEAN, RSTAK(ACOV), LAGMAX, LACOV) C IF (IAR.GE.1) THEN C C USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS. C COMPUTE RESIDUAL VARIANCE. C CALL UASVAR (Y, YMEAN, N, IAR, PHI, VAR) END IF C C SET UP ADDITIONAL STACK WORK AREA, IF NEEDED. C WORK = STKGET(LWORK, IFP) C IF (IAR.EQ.0) THEN LAIC = LAGMAX+1 AIC = STKGET(LAIC, IFP) FTEST = STKGET(2*LAGMAX, IFP) ELSE LAIC = LWORK AIC = WORK FTEST = WORK END IF IF (NPRT.EQ.0) THEN XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = WORK ELSE XAXIS = STKGET(LPCV, IFP) YAXIS = STKGET(LPCV, IFP) ISYM = STKGET(LPCV, 2) ISORT = ISYM END IF C IF (IERR.EQ.1) GO TO 10 C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(RSTAK(ACOV), SPCA, SPCF, LSPC, IAR, PHI, NF, FMN, + FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK), + LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN, + NMSUB) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UASS (Y, N,'/ + ' + IAR, PHI, LAGMAX, LAG, NF, FMIN, FMAX, NPRT,'/ + ' + SPCA, SPCF, FREQ, LDSTAK)') END *UASVAR SUBROUTINE UASVAR (Y, YMEAN, N, IAR, PHI, VAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE VARIANCE FOR A GIVEN SERIES C AND AUTOREGRESSIVE MODEL. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + VAR,YMEAN INTEGER + IAR,N C C ARRAY ARGUMENTS REAL + PHI(IAR),Y(N) C C LOCAL SCALARS REAL + RES,RSS INTEGER + I,IAR1,J,K C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER I C AN INDEX VARIABLE. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. C INTEGER IAR1 C THE VALUE IAR + 1. C INTEGER J, K C INDEX VALUES. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C REAL PHI(IAR) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RES C * C REAL RSS C THE ONE STEP PREDICTION RESIDUAL SUM OF SQUARES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C RSS = 0.0E0 IAR1 = IAR+1 DO 20 I = IAR1, N RES = Y(I) - YMEAN DO 10 J = 1, IAR K = I-J RES = RES - PHI(J) * (Y(K)-YMEAN) 10 CONTINUE RSS = RSS + RES*RES 20 CONTINUE C VAR = RSS / (N-IAR1) C RETURN C END *UASV SUBROUTINE UASV (ACOV, LAGMAX, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION WHEN THE ACVF HAVE PREVIOUSLY BEEN C COMPUTED AND STORED (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,VAR INTEGER + IAR,IPRT,LACOV,LAG,LAIC,LDSMIN,LDSTAK,LPCV,LPHI,LSPC, + LWORK,NF,NPRT C C LOCAL ARRAYS REAL + AIC(101),FREQ(101),FTEST(2,100),PHI(100),SPCA(101),SPCF(101), + WORK(101),XAXIS(207),YAXIS(207) INTEGER + ISORT(101),ISYM(207) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PARZEN,UASDV,UASER C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE AUTOCOVARIANCE COMPUTED FROM THE LAG PRODUCT PAIRS. C REAL AIC(101) C THE ARRAY CONTANING AKIAKES CRITERIA FOR EACH ORDER. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C REAL FTEST(2, 100) C THE ARRAY CONTAINING THE F RATIO AND F TEST. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISYM(207) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER LWORK C THE LENGTH OF THE WORK ARRAY. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(100) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL SPCA(101) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(101) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C REAL WORK(101) C A WORK AREA USED FOR THE LAG WINDOWS AND FOR C COMPUTING THE AUTOREGRESSIVE COEFFICIENTS. C REAL XAXIS(207) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YAXIS(207) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', 'V', ' ', ' '/ C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .TRUE. OPTION(4) = .FALSE. C LAG = 0 IAR = 0 NF = 101 FMIN = 0.0E0 FMAX = 0.5E0 NPRT = -1 LACOV = LAGMAX+1 LDSTAK = 0 LDSMIN = 0 C C CALL ERROR CHECKING ROUTINE C CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, N, N, OPTION) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET VARIOUS PROGRAM PARAMETERS C LPCV = 207 LAIC = 101 LSPC = 101 LPHI = 100 LWORK = 101 C ALPHA = 0.95E0 DELTA = 1.0E0 C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMIN, FMAX, FREQ, + N, LAGMAX, FTEST, AIC, WORK, LACOV, LWORK, DELTA, ISORT, + ISYM, XAXIS, YAXIS, LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, + PARZEN, NMSUB) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UASV (ACOV, LAGMAX, N)') END *UASVS SUBROUTINE UASVS (ACOV, LAGMAX, Y, N, IAR, PHI, LAG, NF, + FMIN, FMAX, NPRT, SPCA, SPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR AUTOREGRESSIVE C SPECTRUM ESTIMATION WHEN THE ACVF HAVE PREVIOUSLY BEEN C COMPUTED AND STORED (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + IAR,LAG,LAGMAX,LDSTAK,N,NF,NPRT C C ARRAY ARGUMENTS REAL + ACOV(*),FREQ(*),PHI(*),SPCA(*),SPCF(*),Y(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMN,FMX,VAR,YMEAN INTEGER + AIC,FTEST,IA,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAIC,LDSMIN, + LPCV,LPHI,LSPC,LWORK,NALL0,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UASDV,UASER, + UASVAR C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE ARRAY OF AUTOCOVARIANCE ESTIMATES. C INTEGER AIC C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY CONTAINING THE AIC. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY FOR WHICH THE C SPECTRUM ESTIMATES ARE TO BE COMPUTED. C REAL FMN, FMX C THE MAXIMUM AND MINIMUM FREQUENCY ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C ESTIMATED. C INTEGER FTEST C THE STARTING LOCATION IN THE STACK FOR C THE ARRAY IN WHICH THE F RATIO AND PROBABILITY ARE STORED. C INTEGER IA C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON WHETHER OR NOT THE MODEL ORDER IS TO BE SELECTED OR C HAS BEEN PROVIDED. C INTEGER IAR C THE ORDER OF THE AUTOREGRESSIVE PROCESS CHOSEN. 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 .NE. 0, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED, C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION IN ISTAK FOR C AN ARRAY USED FOR SORTING. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN ISTAK FOR C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE COVARIANCE ARRAYS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAIC C THE LENGTH OF THE ARRAY AIC. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LPCV C THE LENGTH OF THE PLOT CO-ORDINATE VECTORS. C INTEGER LPHI C THE LENGTH OF THE VECTOR PHI. C INTEGER LSPC C THE LENGTH OF THE SPECTRUM ARRAYS. C INTEGER LWORK C THE ACTUAL LENGTH OF THE WORK ARRAY. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF STACK ALLOCATIONS OUTSTANDING WHEN THIS ROUTINE C WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES FOR WHICH THE SPECTRUM ESTIMATES C ARE TO BE ESTIMATED. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE TYPE OF WINDOW TO BE USED. C REAL PHI(LAGMAX) C THE ARRAY OF AUTOREGRESSIVE COEFFICIENTS FOR THE C SELECTED ORDER. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCA(NF) C THE ARAY CONTAINING THE AUTOREGRESSIVE SPECTRUM ESTIMATES. C REAL SPCF(NF) C THE ARRAY CONTAINING THE FOURIER SPECTRUM ESTIMATES. C REAL VAR C THE ONE STEP PREDICTION VARIANCE. C INTEGER WORK C THE STARTING LOCATION IN THE STACK FOR C THE WORK ARRAY. C INTEGER XAXIS C THE STARTING LOCATION IN RSTAK FOR C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C INTEGER YAXIS C THE STARTING LOCATION IN RSTAK FOR C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / 'U', 'A', 'S', 'V', 'S', ' '/ C IFP = 3 C C SET UP FOR ERROR CHECKING C OPTION(1) = .FALSE. OPTION(2) = .FALSE. OPTION(3) = .TRUE. OPTION(4) = .TRUE. C LACOV = LAGMAX+1 C IO = 1 IF (NPRT .EQ. 0) IO = 0 IA = 1 IF (IAR .NE. 0) IA = 0 C CALL LDSCMP(6, 0, IO*(2*NF+5), 0, 0, 0, 'S', + LAGMAX + 1 + IA*(3*LAGMAX+1) + IO*(4*NF+10), LDSMIN) C C CALL ERROR CHECKING ROUTINE C CALL UASER(NMSUB, N, ACOV, IAR, PHI, LAGMAX, LAG, LACOV, + NF, LDSTAK, LDSMIN, N, N, OPTION) C 5 IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT (IPRT) WRITE (IPRT, 1000) RETURN END IF C C SET SIZE OF WORK AREA. C CALL STKSET (LDSTAK, 4) C C SAVE NUMBER OF OUTSTANDING STACK ALLOCATIONS. C NALL0 = STKST(1) C C SET VARIOUS PROGRAM PARAMETERS. C LSPC = NF LPCV = 2*NF + 5 LPHI = LAGMAX LWORK = LAGMAX+1 C FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF C ALPHA = 0.95E0 DELTA = 1.0E0 C IF (IAR.GE.1) THEN C C USER HAS CHOSEN ORDER AND SUPPLIED COEFFICIENTS. C COMPUTE RESIDUAL VARIANCE. C CALL AMEAN (Y, N, YMEAN) CALL UASVAR (Y, YMEAN, N, IAR, PHI, VAR) END IF C C SET UP ADDITIONAL STACK WORK AREA, IF NEEDED. C WORK = STKGET(LWORK,IFP) IF (IAR.EQ.0) THEN LAIC = LAGMAX+1 AIC = STKGET(LAIC, IFP) FTEST = STKGET(2*LAGMAX, IFP) ELSE LAIC = LWORK AIC = WORK FTEST = WORK END IF IF (NPRT.EQ.0) THEN XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = WORK ELSE XAXIS = STKGET(LPCV, IFP) YAXIS = STKGET(LPCV, IFP) ISYM = STKGET(LPCV, 2) ISORT = ISYM END IF C IF (IERR.EQ.1) GO TO 5 C C CALL THE MAIN DRIVER FOR AUTOREGRESSIVE SPECTRUM ROUTINES. C CALL UASDV(ACOV, SPCA, SPCF, LSPC, IAR, PHI, NF, FMN, + FMX, FREQ, N, LAGMAX, RSTAK(FTEST), RSTAK(AIC), RSTAK(WORK), + LACOV, LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, LAG, LAIC, LPHI, NPRT, VAR, PARZEN, + NMSUB) C CALL STKCLR(NALL0) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UASVS (ACOV, LAGMAX, Y, N,'/ + ' + IAR, PHI, LAG, NF, FMIN, FMAX, NPRT,'/ + ' + SPCA, SPCF, FREQ, LDSTAK)') END *UFPARM SUBROUTINE UFPARM RETURN END *UFSDRV SUBROUTINE UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, + FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, + DELTA, ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, WINDOW, + NMSUB, LDSMIN, LDSTAK, OPTION, LNLPPA, NFFT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLING ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS . C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALPHA,DELTA,FMAX,FMIN,YMISS INTEGER + ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,N, + NF,NFFT,NPRT,NW C C ARRAY ARGUMENTS REAL + ACOV(*),FREQ(*),SPCF(*),WORK(*),XAXIS(*),Y(*),YAXIS(*) INTEGER + ISORT(*),ISYM(*),LAGS(*),NLPPA(*) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C SUBROUTINE ARGUMENTS EXTERNAL WINDOW C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALOW,AUP,BW,DF,FMN,FMX,SPCFMN,SPCFMX,XPLTMN,XPLTMX,YMEAN, + YPLTMN,YPLTMX INTEGER + I,ILOG,ISPCER,LAG,LAGLST,NFUSED,NPTS,NSPC,NWUSED LOGICAL + NEWPG,UNIVAR C C EXTERNAL FUNCTIONS INTEGER + LSTLAG EXTERNAL LSTLAG C C EXTERNAL SUBROUTINES EXTERNAL ACVF,ACVFF,ACVFM,SETFRQ,SPCCK,UFSER,UFSLAG,UFSMN,UFSOUT, + UFSPCV C C INTRINSIC FUNCTIONS INTRINSIC MAX,MIN,NINT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCE. C REAL ALOW C A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL AUP C A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS. C REAL BW C THE BANDWIDTH. C REAL DELTA C THE SAMPLING INTERVAL. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FMN, FMX C THE MAXIMUM AND MINIMUM FREQUENCES ACTUALLY USED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE 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 ILOG C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF C ILOG = 1 THE PLOT IS LOG/LINEAR, IF C ILOG = 2 THE PLOT IS LINEAR/LOG, AND IF C ILOG = 3 THE PLOT IS LOG/LOG. C INTEGER ISORT(NF) C THE VECTOR USED FOR SORTING. C INTEGER ISPCER C AN ERROR FLAG USED FOR THE SPECTRUM PLOTS. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAG C THE LAG WINDWO TRUNCATION POINT USED FOR A SPECIFIC WINDOW. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED AN ACVF C TO BE UNABLE TO BE COMPUTED. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C LOGICAL NEWPG C THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT C WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NFUSED C THE NUMBER OF FREQUENCIES ACTUALLY USED. C INTEGER NLPPA(LNLPPA) C THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF X, Y CO-ORDINATES TO BE PLOTTED. C INTEGER NSPC C THE NUMBER OF VALID (POSITIVE) SPECTRUM VALUES. C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C INTEGER NWUSED C THE NUMBER OF DIFFERENT BANDWIDTHS ACTUALLY USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL SPCFMN, SPCFMX C THE MINIMUM AND MAXIMUM SPECTRUM VALUE TO BE PLOTTED. C LOGICAL UNIVAR C THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT C IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA. C EXTERNAL WINDOW C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL WORK(LWORK) C THE VECTOR OF LAG WINDOWS. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL Y(LY) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMEAN C THE MEAN OF THE OBSERVED TIME SERIES C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C NFUSED = NF IF (OPTION(4)) THEN FMN = MAX(FMIN, 0.0E0) FMX = MIN(FMAX, 0.5E0) IF (FMN.GE.FMX) THEN FMN = 0.0E0 FMX = 0.5E0 END IF ELSE C C SET VARIOUS VALUES FOR SHORT FORMS OF CALL STATEMENT C NPRT = -1 FMN = 0.0E0 FMX = 0.5E0 END IF C C CHECK FOR ERRORS C CALL UFSER(NMSUB, N, LAGMAX, LACOV, NFUSED, ISPCF, NW, LAGS, + LDSTAK, LDSMIN, LY, NFFT, OPTION) C IF (IERR.EQ.1) RETURN C C SET VARIOUS PROGRAM PARAMETERS. C ALPHA = 0.95E0 DELTA = 1.0E0 C C COMPUTE COVARIANCES C LAGLST = LAGMAX IF (OPTION(1)) THEN CALL ACVFF(Y, N, NFFT, YMEAN, ACOV, LAGMAX, LACOV, + LY, WORK, NFFT) ELSE IF (.NOT.OPTION(3)) THEN IF (OPTION(2)) THEN CALL ACVFM(Y, YMISS, N, YMEAN, ACOV, LAGMAX, LAGLST, + NLPPA, LACOV) ELSE CALL ACVF(Y, N, YMEAN, ACOV, LAGMAX, LACOV) END IF END IF END IF IF (OPTION(2) .AND. OPTION(3)) LAGLST = LSTLAG(NLPPA,LAGMAX,LACOV) C IF (LAGLST.GE.1) GO TO 20 C C AN ERROR HAS BEEN DETECTED C IERR = 2 RETURN C 20 CONTINUE C C COMPUTE THE VECTOR OF LAG WINDOW TRUNCATION POINTS, ORDERED C SMALLEST TO LARGEST. C NWUSED = NW IF (.NOT.OPTION(4)) CALL UFSLAG(ACOV, LAGLST, LAGS, N, NW, + NWUSED, LACOV) C C BEGIN COMPUTING FOURIER SPECTRUM FOR SERIES C UNIVAR = .TRUE. C IF (NPRT.GE.1) THEN ILOG = 1 ELSE ILOG = 0 END IF C XPLTMN = FMN XPLTMX = FMX C C SET FREQUENCIES FOR THE SPECTRUM. C CALL SETFRQ(FREQ, NFUSED, 2, FMN, FMX, DELTA) C C COMPUTE AND PLOT SPECTRUM VALUES. C NEWPG = .FALSE. C DO 50 I=1,NWUSED LAG = LAGS(I) ISPCER = 0 IF (LAG.LE.LAGLST) GO TO 30 ISPCER = 2 DF = 0.0E0 GO TO 40 C 30 CALL UFSMN(ACOV, NLPPA, LAG, DF, NFUSED, FREQ, ALPHA, BW, + SPCF(1+(I-1)*ISPCF), ALOW, AUP, LACOV, ISPCF, + WINDOW, WORK, LAG, N, DELTA, OPTION(2), LNLPPA) C IF (NPRT.EQ.0) GO TO 50 C ISPCER = 0 CALL SPCCK(SPCF(1+(I-1)*ISPCF), ISORT, NFUSED, + SPCFMN, SPCFMX, NSPC, ISPCER) C IF (ISPCER.NE.0) GO TO 40 C CALL UFSPCV(SPCF(1+(I-1)*ISPCF), SPCFMN, SPCFMX, + FREQ, NFUSED, XAXIS, YAXIS, ISYM, NPTS, ISPCF, + NFUSED+5, NSPC, BW, ALOW, AUP, + XPLTMN, XPLTMX, YPLTMN, YPLTMX, NPRT) C 40 CALL UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, NINT(DF), LAG, + LAGLST, NEWPG, ISPCER, NFUSED+5, XPLTMN, XPLTMX, YPLTMN, + YPLTMX, ILOG, YAXIS, XAXIS, NPTS, UNIVAR, NMSUB) C NEWPG = .TRUE. C 50 CONTINUE C RETURN C END *UFSER SUBROUTINE UFSER(NMSUB, N, LAGMAX, LACOV, NF, ISPCF, NW, + LAGS, LDSTAK, LDSMIN, LYFFT, NFFT, OPTION) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE ERROR CHECKING ROUTINE FOR THE TIME SERIES C FOURIER UNIVARIATE SPECTRUM ANALYSIS ROUTINES. 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 + ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LYFFT,N,NF,NFFT,NW C C ARRAY ARGUMENTS INTEGER + LAGS(*) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + I,NV LOGICAL + HEAD C C LOCAL ARRAYS LOGICAL + ERR(15) CHARACTER + L1(8)*1,LISPCF(8)*1,LLACOV(8)*1,LLAGMX(8)*1,LLAGS(8)*1, + LLDS(8)*1,LLGMX1(8)*1,LLYFFT(8)*1,LN(8)*1,LNF(8)*1, + LNM1(8)*1,LNW(8)*1 C C EXTERNAL SUBROUTINES EXTERNAL EISGE,EISII,EIVII C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERR(15) 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 IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C CHARACTER*1 LISPCF(8), LLACOV(8), LLAGMX(8), C * LLAGS(8), LLGMX1(8), LLDS(8), LN(8), LNF(8), LNM1(8), C * LNW(8), LLYFFT(8), L1(8) C THE ARRAY(S) CONTAINING THE NAME(S) OF THE ARGUMENT(S) C CHECKED FOR ERRORS. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THE USER CALLED SUBROUTINE. C INTEGER NV C THE NUMBER OF VIOLATIONS FOUND WHEN CHECKING VECTOR LAGS. C INTEGER NW C THE ARGUMENT USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C C SET UP NAME ARRAYS C DATA LISPCF(1), LISPCF(2), LISPCF(3), LISPCF(4), LISPCF(5), + LISPCF(6), LISPCF(7), LISPCF(8) /'I','S','P','C','F',' ',' ', + ' '/ DATA LLACOV(1), LLACOV(2), LLACOV(3), LLACOV(4), LLACOV(5), + LLACOV(6), LLACOV(7), LLACOV(8) /'L','A','C','O','V',' ',' ', + ' '/ DATA LLAGMX(1), LLAGMX(2), LLAGMX(3), LLAGMX(4), LLAGMX(5), + LLAGMX(6), LLAGMX(7), LLAGMX(8) /'L','A','G','M','A','X',' ', + ' '/ DATA LLAGS(1), LLAGS(2), LLAGS(3), LLAGS(4), LLAGS(5), LLAGS(6), + LLAGS(7), LLAGS(8) /'L','A','G','S',' ',' ',' ',' '/ DATA LLGMX1(1), LLGMX1(2), LLGMX1(3), LLGMX1(4), LLGMX1(5), + LLGMX1(6), LLGMX1(7), LLGMX1(8) /'L','A','G','M','A','X','+', + '1'/ DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6), + LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/ DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N', + ' ',' ',' ',' ',' ',' ',' '/ DATA LNF(1), LNF(2), LNF(3), LNF(4), LNF(5), LNF(6), LNF(7), + LNF(8) /'N','F',' ',' ',' ',' ',' ',' '/ DATA LNM1(1), LNM1(2), LNM1(3), LNM1(4), LNM1(5), LNM1(6), + LNM1(7), LNM1(8) /'N','-','1',' ',' ',' ',' ',' '/ DATA LNW(1), LNW(2), LNW(3), LNW(4), LNW(5), LNW(6), LNW(7), + LNW(8) /'N','W',' ',' ',' ',' ',' ',' '/ DATA LLYFFT(1), LLYFFT(2), LLYFFT(3), LLYFFT(4), LLYFFT(5), + LLYFFT(6), LLYFFT(7), LLYFFT(8) /'L','Y','F','F','T',' ',' ', + ' '/ DATA L1(1), L1(2), L1(3), L1(4), L1(5), L1(6), L1(7), L1(8) /'1', + ' ',' ',' ',' ',' ',' ',' '/ C C SET UP FOR ERROR CHECKING C IERR = 0 HEAD = .TRUE. C DO 10 I=1,15 ERR(I) = .FALSE. 10 CONTINUE C C CALL ERROR CHECKING ROUTINES C CALL EISGE(NMSUB, LN, N, 17, 1, HEAD, ERR(1), LN) C IF (OPTION(4)) THEN CALL EISGE(NMSUB, LNF, NF, 1, 1, HEAD, ERR(6), LNF) IF (.NOT.ERR(6)) + CALL EISGE(NMSUB, LISPCF, ISPCF, NF, 3, HEAD, ERR(7), LNF) CALL EISGE(NMSUB, LNW, NW, 1, 1, HEAD, ERR(8), LNW) END IF C IF (.NOT.ERR(1)) THEN IF (OPTION(3)) THEN CALL EISII(NMSUB, LLAGMX, LAGMAX, 1, N-1, 1, HEAD, ERR(2), + L1, LNM1) IF (.NOT.ERR(2)) THEN IF (OPTION(2)) THEN CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 8, HEAD, + ERR(3), LLGMX1) ELSE CALL EISGE(NMSUB, LLACOV, LACOV, LAGMAX+1, 7, HEAD, + ERR(3), LLGMX1) END IF END IF END IF IF (.NOT.ERR(2)) THEN IF (OPTION(1)) + CALL EISGE(NMSUB, LLYFFT, LYFFT, NFFT, 9, HEAD, ERR(4), + LLYFFT) C IF (.NOT.ERR(8)) THEN IF (OPTION(4)) THEN IF (OPTION(3)) THEN CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, LAGMAX, 0, HEAD, 3, + NV, ERR(9), L1, LLAGMX) ELSE CALL EIVII(NMSUB, LLAGS, LAGS, NW, 1, N-1, 0, HEAD, 3, NV, + ERR(9), L1, LNM1) END IF END IF C IF ((.NOT.ERR(6)) .AND. (.NOT.ERR(9))) + CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERR(14), + LLDS) END IF END IF END IF C DO 40 I=1,15 IF (ERR(I)) IERR = 1 40 CONTINUE C RETURN C END *UFSEST SUBROUTINE UFSEST(ACOV, W, LAG, SPCF, ISPCF, LACOV, LW, NF, FREQ, + DELTA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE SPECTRUM, SPCF, AND C THEIR LOWER AND UPPER CONFIDENCE LIMITS, SPCLCL AND SPCUCL, C RESPECTIVELY. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + DELTA INTEGER + ISPCF,LACOV,LAG,LW,NF C C ARRAY ARGUMENTS REAL + ACOV(LACOV),FREQ(NF),SPCF(ISPCF),W(LW) C C LOCAL SCALARS REAL + C,PI,V0,V1,V2 INTEGER + I,K,KK C C EXTERNAL SUBROUTINES EXTERNAL GETPI C C INTRINSIC FUNCTIONS INTRINSIC COS C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCES OF THE SERIES. C REAL C C A VALUE USED TO COMPUTE THE SPECTRUM VALUES. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER K, KK C INDEXING VARIABLES. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAG C THE LAG WINDOW TRUCCATION POINT. C INTEGER LW C THE LENGTH OF THE VECTOR W. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C REAL PI C THE VALUE OF PI. C REAL SPCF(ISPCF) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL V0, V1, V2 C CONSTANTS USED FOR COMPUTING THE SPECTRUM VALUES. C REAL W(LW) C THE VECTOR OF LAG WINDOWS. C CALL GETPI(PI) C C COMPUTE THE SPECTRUM AND ITS CONFIDENCE LIMITS. C DO 20 I=1,NF C = COS(2.0E0*PI*FREQ(I)) V0 = 0.0E0 V1 = 0.0E0 DO 10 K=1,LAG KK = LAG + 1 - K V2 = 2.0E0*C*V1 - V0 + W(KK+1)*ACOV(KK+1) V0 = V1 V1 = V2 10 CONTINUE SPCF(I) = DELTA*(ACOV(1)*W(1)+2.0E0*(V1*C-V0)) IF (SPCF(I).LT.0.0E0) SPCF(I) = 0.0E0 20 CONTINUE RETURN END *UFS SUBROUTINE UFS(Y, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS INTEGER + IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK, + LY,NF,NPRT,NW C C LOCAL ARRAYS REAL + ACOV(101),FREQ(101),SPCF(101,4),WORK(101),XAXIS(106), + YAXIS(106) INTEGER + ISORT(101),ISYM(106),LAGS(4),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PARZEN,SETLAG,UFSDRV C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE). C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. 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 LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(106) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(1) C A DUMMY ARRAY WHEN THE SERIES DOES NOT CONTAIN MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL SPCF(101,4) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL WORK(101) C THE VECTOR OF LAG WINDOWS. C REAL XAXIS(106) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YAXIS(106) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMISS C A DUMMY VARIABLE WHEN THE SERIES DO NOT CONTAIN MISSING VALUES C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S',' ',' ',' '/ C C SET UP C OPTION(4) = .FALSE. OPTION(3) = .FALSE. OPTION(2) = .FALSE. OPTION(1) = .FALSE. C LDSTAK = 0 LDSMIN = 0 C ISPCF = 101 LACOV = 101 LNLPPA = 1 LY = N LPCV = 106 LWORK = 101 NF = 101 YMISS = 1.0E0 C C SET MAXIMUM LAG VALUE TO BE USED. C AND NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE. C CALL SETLAG(N, LAGMAX) NW = 4 C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA, + ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB, + LDSMIN, LDSTAK, OPTION, LNLPPA, LY) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFS (Y, N)') END *UFSF SUBROUTINE UFSF(YFFT, N, LYFFT, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS USING THE FFT (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LDSTAK,LYFFT,N C C ARRAY ARGUMENTS REAL + YFFT(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS INTEGER + IFP,IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LNLPPA,LPCV,LWORK, + NALL0,NF,NFFT,NPRT,NW,WORK C C LOCAL ARRAYS REAL + ACOV(101),FREQ(101),RSTAK(12),SPCF(101,4),XAXIS(106), + YAXIS(106) INTEGER + ISORT(101),ISYM(106),LAGS(4),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LDSCMP,PARZEN,SETESL,SETLAG,STKSET,UFSDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE). C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. 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 IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP = 3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(106) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LYFFT C THE LENGTH OF THE VECTOR YFFT. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NFFT C THE NUMBER OF OBSERVATIONS IN THE EXTENDED SERIES. C INTEGER NLPPA(1) C A DUMMY ARRAY WHEN THE SERIES DOES NOT CONTAIN MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(101,4) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WORK. C REAL XAXIS(106) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YAXIS(106) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMISS C A DUMMY VARIABLE WHEN THE SERIES DO NOT CONTAIN MISSING VALUES C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','F',' ',' '/ C C SET UP C OPTION(4) = .FALSE. OPTION(3) = .FALSE. OPTION(2) = .FALSE. OPTION(1) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED. C SET EXTENDED SERIES LENGTH. C SET NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE. C CALL SETLAG(N, LAGMAX) CALL SETESL(N+LAGMAX, 4, NFFT) NW = 4 C ISPCF = 101 LACOV = 101 LNLPPA = 1 LPCV = 106 LWORK = NFFT NF = 101 YMISS = 1.0E0 C C COMPUTE MIIMUM ALLOWABLE STACK LENGTH C CALL LDSCMP(1, 0, 0, 0, 0, 0, 'S', NFFT, LDSMIN) C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.LE.LDSTAK) .AND. (LDSMIN.GE.7)) THEN WORK = STKGET(LWORK,IFP) ELSE WORK = 1 END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(YFFT, LYFFT, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, + FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, + LWORK, DELTA, ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, + PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION, LNLPPA, NFFT) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSF (YFFT, N, LYFFT, LDSTAK)') END *UFSFS SUBROUTINE UFSFS(YFFT, N, LYFFT, LDSTAK, NW, LAGS, NF, FMIN, FMAX, + NPRT, SPCF, ISPCF, FREQ) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS USING THE FFT (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + ISPCF,LDSTAK,LYFFT,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + FREQ(*),SPCF(*),YFFT(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS INTEGER + ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA, + LPCV,LWORK,NALL0,NFFT,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LDSCMP,PARZEN,SETESL,STKCLR,STKSET,UFSDRV C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LYFFT C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(1) C A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WORK. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS. C REAL YFFT(LYFFT) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS. C REAL YMISS C THE MISSING VALUE CODE FOR THE SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','F','S',' '/ C C SET UP C OPTION(4) = .TRUE. OPTION(3) = .FALSE. OPTION(2) = .FALSE. OPTION(1) = .TRUE. C C SET MAXIMUM LAG VALUE TO BE USED. C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LACOV = LAGMAX + 1 LNLPPA = 1 C C SET EXTENDED SERIES LENGTH C CALL SETESL(N+LAGMAX, 4, NFFT) C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(5, 0, IO*(NF+5), 0, 0, 0, 'S', + LAGMAX+1+NFFT+IO*(2*NF+10), LDSMIN) C LPCV = NF + 5 LWORK = NFFT C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN ACOV = 1 WORK = 1 XAXIS = 1 YAXIS = 1 ISYM = 1 ISORT = 1 ELSE ACOV = STKGET(LACOV,IFP) WORK = STKGET(LWORK,IFP) IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) ISYM = STKGET(LPCV,2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = ISYM END IF END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C CALL UFSDRV(YFFT, LYFFT, YMISS, RSTAK(ACOV), NLPPA, SPCF, ISPCF, + NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, + LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, + OPTION, LNLPPA, NFFT) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSFS (YFFT, N, LYFFT, LDSTAK,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + SPCF, ISPCF, FREQ)') END *UFSLAG SUBROUTINE UFSLAG (ACOV, LAGMAX, LAGS, N, NW, NWUSED, LACOV) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE COMPUTES THE LAG WINDOW TRUNCATION POINTS FOR C SPECTRUM ANALYSIS. C C WRITTEN BY - JANET R. DONALDSON 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 + LACOV,LAGMAX,N,NW,NWUSED C C ARRAY ARGUMENTS REAL + ACOV(LACOV) INTEGER + LAGS(NW) C C LOCAL SCALARS REAL + ACOVMX,P95LIM INTEGER + I,J,K,LAG,NWM1 C C INTRINSIC FUNCTIONS INTRINSIC ABS,REAL,SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE ARRAY IN WHICH THE AUTOCOVARIANCES ARE STORED C REAL ACOVMX C THE MAXIMUM AUTOCOVARIANCE VALUE. C INTEGER I C AN INDEX VARIABLE C INTEGER J, K C INDEX VARIABLES. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAG, LAGMAX C THE INDEXING VARIABLE INDICATING THE LAG VALUE OF THE C AUTOCOVARIANCE BEING COMPUTED AND THE MAXIMUM LAG TO BE USED, C RESPECTIVELY. C INTEGER LAGS(NW) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NW C THE NUMBER OF DIFFERENT BANDWIDTHS REQUESTED. C INTEGER NWM1, NWUSED C THE NUMBER OF DIFFERENT BANDWIDTHS MINUS 1, AND THE C ACTUAL NUMBER OF BANDWIDTHS ACTUALLY USED. C REAL P95LIM C THE 95 PERCENT CONFIDENT LIMIT FOR WHITE NOISE. C LAGS(NW) = LAGMAX IF (LAGS(NW) .LE. 32) GO TO 30 C C COMPUTE 95 PERCENT CONFIDENCE LIMITS ON AUTOCOVARIANCES, C ASSUMING WHITE NOISE. C P95LIM = 1.96E0 * ACOV(1) / SQRT(REAL(N)) C C CHECK FOR FIRST ACVF EXCEEDING 95 PERCENT LIMIT ON WHITE NOISE C DO 10 I = 1, LAGMAX LAG = LAGMAX + 1 - I IF (ABS(ACOV(LAG + 1)) .GE. P95LIM) GO TO 30 LAGS(NW) = LAGS(NW) - 1 10 CONTINUE C C IF NO ACVF EXCEEDS WHITE NOISE LIMITS, CHECK FOR LARGEST ACVF. C LAGS(NW) = 1 ACOVMX = ABS(ACOV(2)) DO 20 LAG = 1, LAGMAX IF (ABS(ACOV(LAG + 1)) .LE. ACOVMX) GO TO 20 LAGS(NW) = LAG ACOVMX = ABS(ACOV(LAG + 1)) 20 CONTINUE C C COMPUTE LAG WINDOW TRUNCATION POINTS C 30 LAGS(NW) = LAGS(NW) * 3.0E0 / 2.0E0 IF (LAGS(NW) .LT. 32) LAGS(NW) = 32 IF (LAGS(NW) .GT. LAGMAX) LAGS(NW) = LAGMAX NWUSED = NW IF (NW .EQ. 1) RETURN NWM1 = NW - 1 DO 40 I = 1, NWM1 K = NW - I LAGS(K) = LAGS(K + 1) / 2 40 CONTINUE C C CHECK WHETHER ALL NW LAG WINDOW TRUNCATION POINTS CAN BE USED. C NWUSED = NW IF (LAGS(1) .GE. 4) RETURN C C RECONSTURCT -LAGS- VECTOR IF NOT ALL TRUNCATION POINTS ARE C TO BE USED C DO 50 I = 2, NW NWUSED = NWUSED - 1 IF (LAGS(I) .GE. 4) GO TO 60 50 CONTINUE C 60 DO 70 I = 1, NWUSED J = NW - NWUSED + I LAGS(I) = LAGS(J) 70 CONTINUE C RETURN END *UFSM SUBROUTINE UFSM(Y, YMISS, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS WITH MISSING DATA (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 REAL + YMISS INTEGER + N C C ARRAY ARGUMENTS REAL + Y(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN INTEGER + IPRT,ISPCF,LACOV,LAGMAX,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK, + LY,NF,NPRT,NW C C LOCAL ARRAYS REAL + ACOV(101),FREQ(101),SPCF(101,4),WORK(101),XAXIS(106), + YAXIS(106) INTEGER + ISORT(101),ISYM(106),LAGS(4),NLPPA(101) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ECVF,IPRINT,PARZEN,SETLAG,UFSDRV C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(101) C THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE). C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. 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 LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(106) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(101) C THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL SPCF(101,4) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL WORK(101) C THE VECTOR OF LAG WINDOWS. C REAL XAXIS(106) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C REAL YAXIS(106) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMISS C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF Y(I) = YMISS, C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','M',' ',' '/ C C SET UP C OPTION(4) = .FALSE. OPTION(3) = .FALSE. OPTION(2) = .TRUE. OPTION(1) = .FALSE. C LDSTAK = 0 LDSMIN = 0 C ISPCF = 101 LACOV = 101 LNLPPA = 101 LY = N LPCV = 106 LWORK = 101 NF = 101 C C SET MAXIMUM LAG VALUE TO BE USED. C AND NUMBER OF LAG WINDOW TRUNCATION POINTS TO USE. C CALL SETLAG(N, LAGMAX) NW = 4 C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA, + ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB, + LDSMIN, LDSTAK, OPTION, LNLPPA, LY) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSM (Y, YMISS, N)') END *UFSMN SUBROUTINE UFSMN(ACOV, NLPPA, LAG, DF, NF, FREQ, ALPHA, BW, SPCF, + ALOW, AUP, LACOV, ISPCF, WINDOW, W, LW, N, DELTA, MISS, LNLPPA) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE MAIN SUBROUTINE FOR COMPUTING AUTOCORRELATIONS AND C PARTIAL AUTOCORRELATIONS OF A TIME SERIES C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALOW,ALPHA,AUP,BW,DELTA,DF INTEGER + ISPCF,LACOV,LAG,LNLPPA,LW,N,NF LOGICAL + MISS C C ARRAY ARGUMENTS REAL + ACOV(LACOV),FREQ(NF),SPCF(ISPCF),W(LW) INTEGER + NLPPA(LNLPPA) C C SUBROUTINE ARGUMENTS EXTERNAL WINDOW C C EXTERNAL FUNCTIONS REAL + PPFCHS EXTERNAL PPFCHS C C EXTERNAL SUBROUTINES EXTERNAL DFBW,DFBWM,UFSEST C C INTRINSIC FUNCTIONS INTRINSIC NINT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LACOV) C THE AUTOCOVARIANCES OF THE SERIES. C REAL ALOW C A FACTOR USED TO COMPUTE THE LOWER CONFIDENCE LIMITS. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL AUP C A FACTOR USED TO COMPUTE THE UPPER CONFIDENCE LIMITS. C REAL BW C THE BANDWIDTH. C REAL DELTA C THE SAMPLING INTERVAL. C REAL DF C THE EFFECTIVE DEGREES OF FREEDOM. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAG C THE VARIABLE INDICATING THE LAG VALUE BEING EXAMINED. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LW C THE LENGTH OF THE VECTOR W. C LOGICAL MISS C AN INDICATOR VARIABLE WHICH DESIGNATES WHETHER THERE ARE C MISSING VALUES (TRUE) OR NOT (FALSE) C INTEGER N C THE NUMBER OF OBSERVATIONS IN THE TIME SERIES. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(LNLPPA) C THE NUMBERS OF LAGGED PRODUCT PAIRS IN EACH ACVF VALUE. C REAL SPCF(ISPCF) C THE ARRAY IN WHICH THE SPECTRUM IS STORED. C REAL W(LW) C THE VECTOR OF LAG WINDOWS. C EXTERNAL WINDOW C THE NAME OF THE WINDOW COMPUTING SUBROUTINE. C C COMPUTE THE WINDOW, EFFECTIVE DEGREES OF FREEDOM AND C BANDWIDTH BASED ON THE WINDOW. C CALL WINDOW(LAG, W, LW) IF (.NOT.MISS) CALL DFBW(N, LAG, W, LW, DF, BW) IF (MISS) CALL DFBWM(N, LAG, W, LW, NLPPA, NLPPA, LNLPPA, DF, BW) C C COMPUTE THE SPECTRUM C CALL UFSEST(ACOV, W, LAG, SPCF, ISPCF, LACOV, LW, NF, FREQ, DELTA) C C COMPUTE -ALPHA- PERCENT POINT FUNCTION VALUE FOR C SPECTRUM WINDOW BEING USED. C ALOW = DF/PPFCHS(0.5E0+ALPHA/2.0E0,NINT(DF)) AUP = DF/PPFCHS(0.5E0-ALPHA/2.0E0,NINT(DF)) C RETURN END *UFSMS SUBROUTINE UFSMS(Y, YMISS, N, NW, LAGS, NF, FMIN, FMAX, NPRT, + SPCF, ISPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS WITH MISSING DATA (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN,YMISS INTEGER + ISPCF,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + FREQ(*),SPCF(*),Y(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA INTEGER + ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA, + LPCV,LWORK,LY,NALL0,NLPPA,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA C THE STARTING LOCATION IN ISTAK FOR THE ARRAY CONTAINING C THE NUMBERS OF LAGGED PRODUCT PAIRS USED FOR EACH ACVF. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WINDOW. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS. C REAL YMISS C THE MISSING VALUE CODE FOR THE SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','M','S',' '/ C C SET UP C OPTION(4) = .TRUE. OPTION(3) = .FALSE. OPTION(2) = .TRUE. OPTION(1) = .FALSE. C C SET MAXIMUM LAG VALUE TO BE USED. C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LACOV = LAGMAX + 1 LNLPPA = LAGMAX + 1 C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(6, 0, LAGMAX+1+IO*(NF+5), 0, 0, 0, 'S', + 2*LAGMAX+2+IO*(2*NF+10), LDSMIN) C LY = N LNLPPA = LACOV LPCV = NF + 5 LWORK = LAGMAX+1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN NLPPA = 1 ACOV = 1 WORK = 1 XAXIS = 1 YAXIS = 1 ISYM = 1 ISORT = 1 ELSE NLPPA = STKGET(LACOV,2) ACOV = STKGET(LACOV,IFP) WORK = STKGET(LWORK,IFP) IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) ISYM = STKGET(LPCV,2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = ISYM END IF END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(Y, LY, YMISS, RSTAK(ACOV), ISTAK(NLPPA), SPCF, ISPCF, + NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, + LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, + OPTION, LNLPPA, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSMS (Y, YMISS, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + SPCF, ISPCF, FREQ, LDSTAK)') END *UFSMV SUBROUTINE UFSMV(ACOV, NLPPA, LAGMAX, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS WITH MISSING DATA AND USER SUPPLIED C ACVF VALUES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(*) INTEGER + NLPPA(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS INTEGER + IPRT,ISPCF,LACOV,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,NF, + NPRT,NW C C LOCAL ARRAYS REAL + FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),Y(1),YAXIS(106) INTEGER + ISORT(101),ISYM(106),LAGS(4) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL ECVF,IPRINT,PARZEN,UFSDRV C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE). C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. 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 LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(106) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(LAGMAX+1) C THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL SPCF(101,4) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL WORK(101) C THE VECTOR OF LAG WINDOWS. C REAL XAXIS(106) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(1) C A DUMMY ARRAY. C REAL YAXIS(106) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMISS C A DUMMY VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','M','V',' '/ C C SET UP FOR ERROR CHECKING C OPTION(4) = .FALSE. OPTION(3) = .TRUE. OPTION(2) = .TRUE. OPTION(1) = .FALSE. C LDSTAK = 0 LDSMIN = 0 C YMISS = 1.0E0 LACOV = LAGMAX+1 C ISPCF = 101 LY = 1 LNLPPA = LACOV LPCV = 106 LWORK = 101 NF = 101 C C SET NUMBER OF LAG WINDOW TRUNCATION POINTS C NW = 4 C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA, + ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB, + LDSMIN, LDSTAK, OPTION, LNLPPA, LY) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSMV (ACOV, NLPPA, LAGMAX, N)') END *UFSMVS SUBROUTINE UFSMVS(ACOV, NLPPA, LAGMAX, N, NW, LAGS, NF, + FMIN, FMAX, NPRT, SPCF, ISPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS WITH MISSING DATA (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + ISPCF,LAGMAX,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + ACOV(*),FREQ(*),SPCF(*) INTEGER + LAGS(*),NLPPA(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS INTEGER + IFP,IO,IPRT,ISORT,ISYM,LACOV,LDSMIN,LNLPPA,LPCV,LWORK,LY, + NALL0,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12),Y(1) INTEGER + ISTAK(12) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL ECVF,IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE AUTOCOVARIANCES OF THE SERIES. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM. C INTEGER LACOV C THE LENGTH OF THE ACVF VECTORS. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(LAGMAX+1) C THE ARRAY CONTAINING THE NUMBER OF LAG PRODUCT PAIRS. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C INTEGER WORK C THE STARTING LOCATION IN RSTAK FOR C THE WORK VECTOR. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS. C REAL Y(1) C A DUMMY ARRAY. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS. C REAL YMISS C A DUMMY VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','M','V','S'/ C C SET UP C OPTION(4) = .TRUE. OPTION(3) = .TRUE. OPTION(2) = .TRUE. OPTION(1) = .FALSE. C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(4, 0, IO*(NF+5), 0, 0, 0, 'S', + LAGMAX+1+IO*(2*NF+10), LDSMIN) C YMISS = 1.0E0 LACOV = LAGMAX+1 C LY = 1 LNLPPA = LACOV LPCV = NF + 5 LWORK = LAGMAX+1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN WORK = 1 XAXIS = 1 YAXIS = 1 ISYM = 1 ISORT = 1 ELSE WORK = STKGET(LWORK,IFP) IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) ISYM = STKGET(LPCV,2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = ISYM END IF END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C FOR SERIES WITH MISSING DATA. C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, LWORK, + DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), RSTAK(YAXIS), + LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION, + LNLPPA, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C IF (IERR.EQ.2) CALL ECVF(NMSUB) IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSMVS (ACOV, NLPPA, LAGMAX, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + SPCF, ISPCF, FREQ, LDSTAK)') END *UFSOUT SUBROUTINE UFSOUT(XAXIS, YAXIS, ISYM, NPTS, BW, IDF, LAG, LAGLST, + NEWPG, ISPCER, LPCV, XPLTMN, XPLTMX, YPLTMN, YPLTMX, ILOG, + PHAS, FREQ, NF, UNIVAR, NMSUB) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES THE FOURIER BIVARIATE SPECTRUM OUTPUT. 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 REAL + BW,XPLTMN,XPLTMX,YPLTMN,YPLTMX INTEGER + IDF,ILOG,ISPCER,LAG,LAGLST,LPCV,NF,NPTS LOGICAL + NEWPG,UNIVAR C C ARRAY ARGUMENTS REAL + FREQ(NF),PHAS(NF),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + PI,XMN,XMX,YMN,YMX INTEGER + I,IPRT LOGICAL + ERROR C C EXTERNAL SUBROUTINES EXTERNAL GETPI,IPRINT,PPLMT,PPMN,VERSP C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL BW C THE BANDWIDTH. C LOGICAL ERROR C AN ERROR FLAG C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER IDF C THE EFFECTIVE DEGREES OF FREEDOM. C INTEGER IERR C THE ERROR FLAG. C INTEGER ILOG C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C ILOG = 0 THE PLOT IS LINEAR/LINEAR, IF C ILOG = 1 THE PLOT IS LOG/LINEAR, IF C ILOG = 2 THE PLOT IS LINEAR/LOG, AND IF C ILOG = 3 THE PLOT IS LOG/LOG. C INTEGER IPRT C THE LOGICAL UNIT NUMBER FOR THE OUTPUT. C INTEGER ISPCER C A VARIABLE USED TO DESIGNATE AN ERROR IN THE SPECTRUM C VALUES. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LAG C THE LAG WINDOW TRUNCATION POINT. C INTEGER LAGLST C THE LAST LAG BEFORE MISSING DATA CAUSED THE ACVF OF EITHER C SERIES 1 OR 2 NOT TO BE COMPUTED. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C LOGICAL NEWPG C THE LOGICAL VARIABLE USED TO DETERMINE IF OUTPUT C WILL BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE). C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C CHARACTER*1 NMSUB(6) C THE NAME OF THE CALLING SUBROUTINE. C INTEGER NPTS C THE NUMBER OF CO-ORDINATES TO BE PLOTTED. C REAL PHAS(NF) C THE PHASE COMPONENT OF THE BIVARIATE SPECTRA. C REAL PI C THE VALUE OF PI. C LOGICAL UNIVAR C THE LOGICAL VARIABLE USED TO DETERMINE IF THE OUTPUT C IS FOR UNIVARIATE (TRUE) OR BIVARIATE (FALSE) SPECTRA. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XMN, XMX C * C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMN, YMX C * C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE Y AXIS. C C SET LOGICAL UNIT NUMBER FOR OUTPUT AND SET OUTPUT WIDTH. C CALL IPRINT(IPRT) C CALL GETPI(PI) C IF (NEWPG) WRITE (IPRT,1010) IF (ISPCER.LE.1) GO TO 10 CALL VERSP(.TRUE.) WRITE (IPRT,1060) LAGLST, LAG RETURN C 10 CONTINUE CALL VERSP(.TRUE.) IF (.NOT.UNIVAR) WRITE (IPRT,1070) IF (UNIVAR) WRITE (IPRT,1080) WRITE (IPRT,1020) LAG, BW, IDF IF (ISPCER.EQ.0) GO TO 20 WRITE (IPRT,1050) GO TO 30 C 20 CONTINUE C C PRINT PLOTS C C PLOT SQUARED COHERENCY COMPONENT OF SPECTRUM C CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, YPLTMN, + YPLTMX, YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB, + .FALSE.) IF (.NOT.ERROR) + CALL PPMN(YAXIS, YAXIS, XAXIS, XAXIS, NPTS, 1, LPCV, 1, ISYM, + LPCV, 0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG) IF (XPLTMN.EQ.0.0E0 .AND. XPLTMX.EQ.0.5E0) WRITE (IPRT, 1030) C 30 IF (UNIVAR) RETURN DO 40 I=1,NF XAXIS(I) = FREQ(I) XAXIS(NF+I) = FREQ(I) YAXIS(I) = PHAS(I) IF (PHAS(I).GT.0.0E0) THEN YAXIS(NF+I) = PHAS(I) - 2*PI ELSE IF (PHAS(I).LT.0.0E0) THEN YAXIS(NF+I) = PHAS(I) + 2*PI ELSE YAXIS(NF+I) = 0.0E0 END IF 40 CONTINUE C C PLOT SMOOTHED PHASE COMPONENT OF SPECTRUM C WRITE (IPRT,1010) CALL VERSP(.TRUE.) WRITE (IPRT,1000) WRITE (IPRT,1020) LAG, BW, IDF CALL PPLMT(YAXIS, YAXIS, XAXIS, XAXIS, 2*NF, 1, 2*NF, -2*PI, 2*PI, + YMN, YMX, XPLTMN, XPLTMX, XMN, XMX, ERROR, NMSUB, .FALSE.) IF (ERROR) THEN IERR = 1 ELSE CALL PPMN(YAXIS, YAXIS, XAXIS, XAXIS, + 2*NF, 1, 2*NF, 0, ISYM, LPCV, + 0, -1, YMN, YMX, XMN, XMX, .FALSE., ILOG) IF (XPLTMN.EQ.0.0E0 .AND. XPLTMX.EQ.0.5E0) WRITE (IPRT, 1030) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (50H -- SMOOTHED FOURIER SPECTRUM (PHASE COMPONENT) --) 1010 FORMAT ('1') 1020 FORMAT (45H (PARZEN WINDOW WITH LAG WIND. TRUNC. PT.=, I5, 1X, + 5H/ BW=, F6.4, 1X, 6H/ EDF=, I6, ')') 1030 FORMAT (5H+FREQ/7H PERIOD, 9X, 3HINF, 7X, 3H20., 7X, 3H10., 8X, + 6H6.6667, 4X, 2H5., 8X, 2H4., 8X, 6H3.3333, 4X, 6H2.8571, 4X, + 3H2.5, 7X, 6H2.2222, 4X, 2H2.) C1040 FORMAT (5H+FREQ/7H PERIOD, 9X, 3HINF, 7X, 3H10., 7X, 2H5., 8X, C * 6H3.3333, 4X, 3H2.5, 7X, 2H2.) 1050 FORMAT (//39H THE PLOT HAS BEEN SUPRESSED BECAUSE NO/ + 40H POSITIVE SPECTRUM VALUES WERE COMPUTED.) 1060 FORMAT (//50H THE LARGEST LAG WINDOW TRUNCATION POINT WHICH CAN/ + 12H BE USED IS , I5, '.'/34H THE SPECTRUM FOR THE REQUESTED LA, + 8HG WINDOW, 10H POINT OF , I5, ','/24H THEREFORE, CANNOT BE CO, + 7HMPUTED.) 1070 FORMAT (48H -- SMOOTHED FOURIER SPECTRUM (SQUARED COHERENCY, + 46H COMPONENT) (+), 95 PCT. CONFIDENCE LIMITS (.), + 38H AND 95 PCT. SIGNIFICANCE LEVEL (-) --) 1080 FORMAT (32H -- SMOOTHED FOURIER SPECTRUM --) END *UFSPCV SUBROUTINE UFSPCV (SPCF, SPCMN, SPCMX, FREQ, NF, XAXIS, YAXIS, + ISYM, NPTS, ISPCF, LPCV, NSPC, BW, ALOW, AUP, XPLTMN, XPLTMX, + YPLTMN, YPLTMX, NPRT) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES CO-ORDINATES FOR THE SPECTRUM PLOTS. C C WRITTEN BY - JANET R. DONALDSON 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 REAL + ALOW,AUP,BW,SPCMN,SPCMX,XPLTMN,XPLTMX,YPLTMN,YPLTMX INTEGER + ISPCF,LPCV,NF,NPRT,NPTS,NSPC C C ARRAY ARGUMENTS REAL + FREQ(NF),SPCF(ISPCF),XAXIS(LPCV),YAXIS(LPCV) INTEGER + ISYM(LPCV) C C LOCAL SCALARS REAL + CILOW,CIMID,CIUP,YMAX INTEGER + I,ISPCFW C C EXTERNAL SUBROUTINES EXTERNAL SPPLTC,SPPLTD,SPPLTL C C INTRINSIC FUNCTIONS INTRINSIC LOG10 C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ALOW, AUP C FACTORS USED TO COMPUTE THE CONFIDENCE INTERVALS. C REAL BW C THE BANDWIDTH. C REAL CILOW, CIMID, CIUP C THE Y AXIS VALUES FOR THE LOWER MID AND UPPER CONFIDENCE C INTERVAL POINTS. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISPCFW C AN INDEX VARIABLE. C INTEGER ISYM(LPCV) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NPTS C THE NUMBER OF CO-ORDINATES TO BE PLOTTED. C INTEGER NSPC C THE NUMBER OF VALID SPECTRUM VALUES. C REAL SPCF(ISPCF) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C REAL SPCMN, SPCMX C THE MINIMUM AND MAXIMUM SPECTRUM VALUE TO BE PLOTTED. C REAL XAXIS(LPCV) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL XPLTMN, XPLTMX C THE MINIMUM AND MAXIMUM VALUES TO BE PLOTTED FOR THE X AXIS. C REAL YAXIS(LPCV) C THE Y AXIS VALUES FOR THE SPECTRUM PLOTS. C REAL YMAX C THE MAXIMUM ACTUAL SPECTRUM VALUE (IN DECIBELS) TO BE PLOTTED. C REAL YPLTMN, YPLTMX C THE MINIMUM AND MAXIMUM VAUES TO BE PLOTTED FOR THE Y AXIS. C C ISPCFW = 0 C IF (NPRT .GE. 1) GO TO 30 C C SET VARIOUS Y AXIS VALUES FOR DECIBLE PLOTS C CALL SPPLTD (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX, + CILOW, CIMID, CIUP, YMAX) C C SET CO-ORDINATES FOR DECIBLE PLOTS C DO 10 I = 1, NF IF (SPCF(I) .LT. SPCMN) GO TO 10 ISPCFW = ISPCFW + 1 XAXIS(ISPCFW) = FREQ(I) YAXIS(ISPCFW) = 10.0E0 * LOG10(SPCF(I)) - YMAX ISYM(ISPCFW) = 1 10 CONTINUE C GO TO 70 C 30 CONTINUE C C SET VARIOUS Y AXIS VALUES FOR LOG PLOTS C CALL SPPLTL (SPCMN, SPCMX, ALOW, AUP, YPLTMN, YPLTMX, + CILOW, CIMID, CIUP) C C SET CO-ORDINATES FOR LOG PLOTS C DO 50 I = 1, NF IF (SPCF(I) .LT. SPCMN) GO TO 50 ISPCFW = ISPCFW + 1 XAXIS(ISPCFW) = FREQ(I) YAXIS(ISPCFW) = SPCF(I) ISYM(ISPCFW) = 1 50 CONTINUE C 70 CONTINUE C NPTS = NSPC C C SET CO-ORDINATES FOR BANDWIDTH AND CONFIDENCE INTERVAL. C CALL SPPLTC (XAXIS, YAXIS, ISYM, NPTS, XPLTMN, XPLTMX, BW, CILOW, + CIMID, CIUP, LPCV) C RETURN END *UFSS SUBROUTINE UFSS(Y, N, NW, LAGS, NF, FMIN, FMAX, NPRT, + SPCF, ISPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + ISPCF,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + FREQ(*),SPCF(*),Y(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS INTEGER + ACOV,I,IFP,IO,IPRT,ISORT,ISYM,LACOV,LAGMAX,LDSMIN,LNLPPA, + LPCV,LWORK,LY,NALL0,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12) INTEGER + ISTAK(12),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV C C INTRINSIC FUNCTIONS INTRINSIC MAX C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER ACOV C THE STARTING LOCATION IN RSTAK FOR THE ACVF VECTOR. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER I C AN INDEX VARIABLE C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM. C INTEGER LACOV C THE LENGTH OF VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(1) C A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C INTEGER WORK C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY WINDOW. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS. C REAL Y(N) C THE ARRAY CONTAINING THE OBSERVED TIME SERIES. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS. C REAL YMISS C THE MISSING VALUE CODE FOR THE SERIES. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','S',' ',' '/ C C SET UP C OPTION(4) = .TRUE. OPTION(3) = .FALSE. OPTION(2) = .FALSE. OPTION(1) = .FALSE. C C SET MAXIMUM LAG VALUE TO BE USED. C LAGMAX = N - 1 IF (NW.LE.0) GO TO 20 LAGMAX = LAGS(1) DO 10 I=1,NW LAGMAX = MAX(LAGMAX,LAGS(I)) 10 CONTINUE 20 CONTINUE LACOV = LAGMAX + 1 LNLPPA = 1 C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(5, 0, IO*(NF+5), 0, 0, 0, 'S', + 2*LAGMAX+2+IO*(2*NF+10), LDSMIN) C LY = N LPCV = NF + 5 LWORK = LAGMAX+1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN ACOV = 1 WORK = 1 XAXIS = 1 YAXIS = 1 ISYM = 1 ISORT = 1 ELSE ACOV = STKGET(LACOV,IFP) WORK = STKGET(LWORK,IFP) IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) ISYM = STKGET(LPCV,2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = ISYM END IF END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C CALL UFSDRV(Y, LY, YMISS, RSTAK(ACOV), NLPPA, SPCF, ISPCF, + NF, FMIN, FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, + LWORK, DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), + RSTAK(YAXIS), LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, + OPTION, LNLPPA, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSS (Y, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + SPCF, ISPCF, FREQ, LDSTAK)') END *UFSV SUBROUTINE UFSV(ACOV, LAGMAX, N) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS AND USER SUPPLIED ACVF VALUES (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON 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 + LAGMAX,N C C ARRAY ARGUMENTS REAL + ACOV(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + ALPHA,DELTA,FMAX,FMIN,YMISS INTEGER + IPRT,ISPCF,LACOV,LDSMIN,LDSTAK,LNLPPA,LPCV,LWORK,LY,NF, + NPRT,NW C C LOCAL ARRAYS REAL + FREQ(101),SPCF(101,4),WORK(101),XAXIS(106),Y(1),YAXIS(106) INTEGER + ISORT(101),ISYM(106),LAGS(4),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,PARZEN,UFSDRV C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE AUTOCOVARIANCE AT LAG ZERO (BIASED VARIANCE). C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCES AT WHICH THE C SPECTRUM IS TO BE COMPUTED. C REAL FREQ(101) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. 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 LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT(101) C AN ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISYM(106) C THE ARRAY CONTAINING THE CODE FOR THE PLOT SYMBOLS. C INTEGER LACOV C THE LENGTH OF THE VECTOR ACOV. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(4) C THE ARRAY USED TO STORE THE LAG WINDOW TRUCCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN EACH SERIES C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(1) C A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL SPCF(101,4) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED. C REAL WORK(101) C THE VECTOR OF LAG WINDOWS. C REAL XAXIS(106) C THE X AXIS VALUES FOR THE SPECTRUM PLOT. C REAL Y(1) C A DUMMY ARRAY. C REAL YAXIS(106) C THE Y AXIS VALUES FOR THE SPECTRUM PLOT. C REAL YMISS C A DUMMY VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','V',' ',' '/ C C SET UP FOR ERROR CHECKING C OPTION(4) = .FALSE. OPTION(3) = .TRUE. OPTION(2) = .FALSE. OPTION(1) = .FALSE. C LDSTAK = 0 LDSMIN = 0 C YMISS = 1.0E0 LACOV = LAGMAX+1 C ISPCF = 101 LY = 1 LNLPPA = 1 LPCV = 106 LWORK = 101 NF = 101 C C SET NUMBER OF LAG WINDOW TRUNCATION POINTS C NW = 4 C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, WORK, LACOV, LWORK, DELTA, + ISORT, ISYM, XAXIS, YAXIS, LPCV, ALPHA, NPRT, PARZEN, NMSUB, + LDSMIN, LDSTAK, OPTION, LNLPPA, LY) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSV (ACOV, LAGMAX, N)') END *UFSVS SUBROUTINE UFSVS(ACOV, LAGMAX, N, NW, LAGS, NF, + FMIN, FMAX, NPRT, SPCF, ISPCF, FREQ, LDSTAK) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE FOR TIME SERIES FOURIER C SPECTRUM ANALYSIS AND USER SUPPLIED ACVF VALUES (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 7, 1981 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + FMAX,FMIN INTEGER + ISPCF,LAGMAX,LDSTAK,N,NF,NPRT,NW C C ARRAY ARGUMENTS REAL + ACOV(*),FREQ(*),SPCF(*) INTEGER + LAGS(*) C C SCALARS IN COMMON INTEGER + IERR C C ARRAYS IN COMMON DOUBLE PRECISION DSTAK(12) C C LOCAL SCALARS REAL + ALPHA,DELTA,YMISS INTEGER + IFP,IO,IPRT,ISORT,ISYM,LACOV,LDSMIN,LNLPPA,LPCV,LWORK,LY, + NALL0,WORK,XAXIS,YAXIS C C LOCAL ARRAYS REAL + RSTAK(12),Y(1) INTEGER + ISTAK(12),NLPPA(1) LOGICAL + OPTION(4) CHARACTER + NMSUB(6)*1 C C EXTERNAL FUNCTIONS INTEGER + STKGET,STKST EXTERNAL STKGET,STKST C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LDSCMP,PARZEN,STKCLR,STKSET,UFSDRV C C COMMON BLOCKS COMMON /CSTAK/DSTAK COMMON /ERRCHK/IERR C C EQUIVALENCES EQUIVALENCE (DSTAK(1),RSTAK(1)) EQUIVALENCE (DSTAK(1),ISTAK(1)) C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL ACOV(LAGMAX+1) C THE AUTOCOVARIANCES OF THE SERIES. C REAL ALPHA C THE DESIRED CONFIDENCE LEVEL. C REAL DELTA C THE SAMPLING INTERVAL. C DOUBLE PRECISION DSTAK(12) C THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA. C REAL FMAX, FMIN C THE MAXIMUM AND MINIMUM FREQUENCY AT WHICH THE SPECTRUM C IS TO BE COMPUTED. C REAL FREQ(NF) C THE VECTOR OF FREQUENCIES AT WHICH THE SPECTRUM IS TO BE C COMPUTED. C INTEGER IERR C THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING C WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST C IF ERR01, NO ERRORS WERE DETECTED C IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED C INTEGER IFP C AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES C REAL AND IFP=4 INDICATES DOUBLE PRECISION. C INTEGER IO C A VARIABLE USED TO DETERMINE THE AMOUNT OF STORAGE REQUIRED C BASED ON PRINTED OUTPUT REQUESTED. C INTEGER IPRT C THE LOGICAL UNIT USED FOR PRINTED OUTPUT. C INTEGER ISORT C THE STARTING LOCATION FOR THE ARRAY USED FOR SORTING. C INTEGER ISPCF C THE ACTUAL FIRST DIMENSION OF THE SPECTRUM ARRAYS. C INTEGER ISTAK(12) C THE INTEGER VERSION OF THE /CSTAK/ WORK AREA. C INTEGER ISYM C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY ISYM. C INTEGER LACOV C THE LENGTH OF THE ACVF VECTORS. C INTEGER LAGMAX C THE MAXIMUM LAG VALUE TO BE USED. C INTEGER LAGS(NW) C THE ARRAY USED TO SPECIFY THE LAG WINDOW TRUNCATION C POINTS USED FOR EACH SET OF SPECTRUM VALUES. C INTEGER LDSMIN C THE MINIMUM LENGTH ALLOWED FOR DSTAK. C INTEGER LDSTAK C THE LENGTH OF THE VECTOR DSTAK IN COMMON CSTAK. C INTEGER LNLPPA C THE LENGTH OF THE VECTOR NLPPA. C INTEGER LPCV C THE LENGTH OF THE VECTORS USED FOR PLOTTING. C INTEGER LWORK C THE LENGTH OF THE VECTOR W. C INTEGER LY C THE LENGTH OF THE VECTOR Y. C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS IN THE SERIES. C INTEGER NALL0 C THE NUMBER OF ALLOCATIONS OUTSTANDING AT THE TIME THAT C THIS ROUTINE WAS CALLED. C INTEGER NF C THE NUMBER OF FREQUENCIES AT WHICH THE SPECTRUM IS C TO BE COMPUTED. C INTEGER NLPPA(1) C A DUMMY ARRAY FOR SERIES WITHOUT MISSING VALUES. C CHARACTER*1 NMSUB(6) C THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE. C INTEGER NPRT C A CODE USED TO SPECIFY THE TYPE OF PLOT, WHERE IF C NPRT < 0 THE PLOT IS DECIBLES/LINEAR C NPRT = 0 THE PLOT IS SUPPRESSED C NPRT > 0 THE PLOT IS LOG/LINEAR C INTEGER NW C THE VARIABLE USED TO DETERMINE THE NUMBER OF DIFFERENT C BANDWIDTHS TO BE USED. C LOGICAL OPTION(4) C AN INDICATOR ARRAY USED TO DESIGNATE WHETHER ANY OF THE C FOUR POSSIBLE OPTIONS (F, M, V, OR S) HAVE BEEN USED (TRUE) C OR NOT (FALSE). C EXTERNAL PARZEN C THE SUBROUTINE USED TO COMPUTE THE WINDOW. C REAL RSTAK(12) C THE REAL VERSION OF THE /CSTAK/ WORK AREA. C REAL SPCF(ISPCF,NW) C THE ARRAYS IN WHICH THE SPECTRUM IS STORED C FOR EACH LAG WINDOW. C INTEGER WORK C THE STARTING LOCATION IN RSTAK FOR C THE WORK VECTOR. C INTEGER XAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY XAXIS. C REAL Y(1) C A DUMMY ARRAY. C INTEGER YAXIS C THE STARTING LOCATION IN THE WORK AREA FOR ARRAY YAXIS. C REAL YMISS C A DUMMY VARIABLE. C C SET UP NAME ARRAYS C DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) / + 'U','F','S','V','S',' '/ C C SET UP C OPTION(4) = .TRUE. OPTION(3) = .TRUE. OPTION(2) = .FALSE. OPTION(1) = .FALSE. C LACOV = LAGMAX+1 C C COMPUTE MINIMUM ALLOWABLE STACK LENGTH C IO = 1 IF (NPRT.EQ.0) IO = 0 C CALL LDSCMP(4, 0, IO*(NF+5), 0, 0, 0, 'S', + LAGMAX+1+IO*(2*NF+10), LDSMIN) C YMISS = 1.0E0 C LY = 1 LNLPPA = 1 LPCV = NF + 5 LWORK = LAGMAX+1 C C SET SIZE OF WORK AREA. C SET THE NUMBER OF OUTSTANDING ALLOCATIONS. C SET THE STACK ALLOCATION TYPE. C CALL STKSET(LDSTAK, 4) NALL0 = STKST(1) C IFP = 3 C C SET STARTING LOCATIONS IN THE WORK AREA FOR VARIOUS ARRAYS. C IF ((LDSMIN.GT.LDSTAK) .OR. (LDSMIN.LE.6)) THEN WORK = 1 XAXIS = 1 YAXIS = 1 ISYM = 1 ISORT = 1 ELSE WORK = STKGET(LWORK,IFP) IF (NPRT.NE.0) THEN XAXIS = STKGET(LPCV,IFP) YAXIS = STKGET(LPCV,IFP) ISYM = STKGET(LPCV,2) ISORT = ISYM ELSE XAXIS = WORK YAXIS = WORK ISYM = WORK ISORT = ISYM END IF END IF C C CALL THE CONTROLLING ROUTINE FOR FOURIER SPECTRUM ROUTINES C CALL UFSDRV(Y, LY, YMISS, ACOV, NLPPA, SPCF, ISPCF, NF, FMIN, + FMAX, FREQ, N, NW, LAGMAX, LAGS, RSTAK(WORK), LACOV, LWORK, + DELTA, ISTAK(ISORT), ISTAK(ISYM), RSTAK(XAXIS), RSTAK(YAXIS), + LPCV, ALPHA, NPRT, PARZEN, NMSUB, LDSMIN, LDSTAK, OPTION, + LNLPPA, LY) C CALL STKCLR(NALL0) C C CHECK FOR ERRORS C IF (IERR.EQ.0) RETURN C CALL IPRINT(IPRT) WRITE (IPRT,1000) RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL UFSVS (ACOV, LAGMAX, N,'/ + ' + NW, LAGS, NF, FMIN, FMAX, NPRT,'/ + ' + SPCF, ISPCF, FREQ, LDSTAK)') END *V2NORM REAL 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 REAL + X(*) C C LOCAL SCALARS REAL + ONE,R,SCALE,SQTETA,T,XI,ZERO INTEGER + I,J C C EXTERNAL FUNCTIONS REAL + RMDCON EXTERNAL RMDCON C C INTRINSIC FUNCTIONS INTRINSIC ABS,SQRT C C DATA ONE/1.0E0/, SQTETA/0.0E0/, ZERO/0.0E0/ 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 *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 REAL + A INTEGER + P C C ARRAY ARGUMENTS REAL + W(*),X(*),Y(*) C C LOCAL SCALARS INTEGER + I C C DO 10 I = 1, P 10 W(I) = A*X(I) + Y(I) RETURN 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 REAL + X(*),Y(*) C C LOCAL SCALARS INTEGER + I C C DO 10 I = 1, P 10 Y(I) = X(I) 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 REAL + VCV(LVCV) INTEGER + MASK(LMASK) C C LOCAL SCALARS INTEGER + CODE,I,II,IPRT,MODE C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,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 REAL VCV(LVCV) C THE VARIANCE COVARIANCE MATRIX. C C COMMENCE BODY OF ROUTINE C 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.0E0) GO TO 30 IF (EST) GO TO 10 WRITE (IPRT,1000) GO TO 20 C 10 CONTINUE WRITE (IPRT,1050) IF (IVCVPT.EQ.1) WRITE (IPRT,1060) IF (IVCVPT.EQ.2) WRITE (IPRT,1070) IF (IVCVPT.EQ.3) WRITE (IPRT,1080) 20 WRITE (IPRT,1010) GO TO 50 30 CONTINUE C IF (EST) GO TO 40 C C PRINT HEADING FOR CORRELATION ROUTINES C WRITE (IPRT,1040) WRITE (IPRT,1030) MODE = 2 GO TO 50 C 40 CONTINUE C C PRINT HEADING FOR ESTIMATION ROUTINES C WRITE (IPRT,1050) IF (IVCVPT.EQ.1) WRITE (IPRT,1060) IF (IVCVPT.EQ.2) WRITE (IPRT,1070) IF (IVCVPT.EQ.3) WRITE (IPRT,1080) WRITE (IPRT,1020) MODE = 4 C 50 CALL MATPRF(VCV, VCV, NPAR, MODE, CODE, LVCV, MASK, LMASK) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (///18H COVARIANCE MATRIX) 1010 FORMAT (/39H NONPOSITIVE VARIANCES ENCOUNTERED./10H CORRE, + 39HLATION COEFFICIENTS CANNOT BE COMPUTED.) 1020 FORMAT (4X, 36H- COVARIANCES ARE ABOVE THE DIAGONAL/4X, 7H- VARIA, + 24HNCES ARE ON THE DIAGONAL/4X, 27H- CORRELATION COEFFICIENTS , + 22HARE BELOW THE DIAGONAL) 1030 FORMAT (4X, 41H- STANDARD DEVIATIONS ARE ON THE DIAGONAL/4X, + 49H- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL) 1040 FORMAT (/19H CORRELATION MATRIX) 1050 FORMAT (///45H VARIANCE-COVARIANCE AND CORRELATION MATRICES, + 38H OF THE ESTIMATED (UNFIXED) PARAMETERS/ 1X, 82('-')) 1060 FORMAT (/ + 4X, 54H- APPROXIMATION BASED ON ASSUMPTION THAT RESIDUALS ARE, + 6H SMALL) 1070 FORMAT ( + /4X, 51H- APPROXIMATION BASED ON ASYMPTOTIC MAXIMUM LIKELIH, + 10HOOD THEORY) 1080 FORMAT (/4X, + 51H- APPROXIMATION BASED ON ASSUMPTION THAT CONDITIONS, + 10H NECESSARY/ + 5X, 41H FOR ASYMPTOTIC MAXIMUM LIKELIHOOD THEORY, + 18H MIGHT BE VIOLATED) END *VCVOUT SUBROUTINE VCVOUT(NP, VCV, IVCV, EST) C C LATEST REVISION - 03/15/90 (JRD) C C THIS SUBROUTINE PRINTS THE VARIANCE COVARIANCE MATRIX. 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 - 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 + IVCV,NP LOGICAL + EST C C ARRAY ARGUMENTS REAL + VCV(IVCV,NP) C C LOCAL SCALARS REAL + DEN,SVCVII,SVCVJJ INTEGER + I,IPRT,J,K,MODE C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,MATPRT C C INTRINSIC FUNCTIONS INTRINSIC SQRT C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DEN C DENOMINATOR OF (I, J) CORRELATION COEFFICIENT 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 IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IVCV C THE EXACT FIRST DIMENSION OF THE MATRIX VCV. C INTEGER J C THE INDEX OF THE PARAMETER BEING EXAMINED. C INTEGER K C AN INDEX VARIABLE. C INTEGER MODE C IF MODE IS 1, PRINT FULL MATRIX. C IF MODE IS 2, PRINT LOWER TRIANGLE WITH SQUARE ROOTS OF C OF THE DIAGONAL. C INTEGER NP C THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL. C REAL SVCVII, SVCVJJ C SQUARE ROOTS OF VCV(I, I) AND VCV(J, J) C REAL VCV(IVCV,NP) C THE VARIANCE COVARIANCE MATRIX. C C COMMENCE BODY OF ROUTINE C CALL IPRINT(IPRT) C C DETERMINE WHETHER TO ISSUE NEGATIVE VARIANCE WARNING C MODE = 2 DO 10 I=1,NP IF (VCV(I,I).GT.0.0E0) GO TO 10 WRITE (IPRT,1000) IF (EST) WRITE (IPRT,1050) WRITE (IPRT,1010) MODE = 0 GO TO 70 10 CONTINUE C IF (EST) GO TO 20 C C PRINT HEADING FOR CORRELATION ROUTINES C WRITE (IPRT,1040) WRITE (IPRT,1030) MODE = 2 GO TO 30 C 20 CONTINUE C C PRINT HEADING FOR ESTIMATION ROUTINES C WRITE (IPRT,1050) WRITE (IPRT,1020) MODE = 1 C 30 CONTINUE C C COMPUTE THE CORRELATION COEFFICIENTS AND STORE IN THE BOTTOM HALF C OF THE VARIANCE COVARIANCE MATRIX C IF (NP.EQ.1) GO TO 60 DO 50 J=2,NP K = J - 1 SVCVJJ = 0.0E0 IF (VCV(J,J).GT.0.0E0) SVCVJJ = SQRT(VCV(J,J)) DO 40 I=1,K SVCVII = 0.0E0 IF (VCV(I,I).GT.0.0E0) SVCVII = SQRT(VCV(I,I)) DEN = SVCVII*SVCVJJ IF (DEN.LE.0.0E0) VCV(J,I) = 0.0E0 IF (DEN.GT.0.0E0) VCV(J,I) = VCV(J,I)/DEN 40 CONTINUE 50 CONTINUE C 60 CONTINUE C 70 CALL MATPRT(VCV, VCV, NP, IPRT, MODE, 1, IVCV) C C RESTORE THE VCV MATRIX C IF (NP.EQ.1) RETURN DO 90 J=2,NP K = J - 1 DO 80 I=1,K VCV(J,I) = VCV(I,J) 80 CONTINUE 90 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/18H COVARIANCE MATRIX) 1010 FORMAT (/39H NONPOSITIVE VARIANCES ENCOUNTERED./10H CORRE, + 39HLATION COEFFICIENTS CANNOT BE COMPUTED.) 1020 FORMAT (4X, 36H- COVARIANCES ARE ABOVE THE DIAGONAL/4X, 7H- VARIA, + 24HNCES ARE ON THE DIAGONAL/4X, 27H- CORRELATION COEFFICIENTS , + 22HARE BELOW THE DIAGONAL) 1030 FORMAT (4X, 41H- STANDARD DEVIATIONS ARE ON THE DIAGONAL/4X, + 49H- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL) 1040 FORMAT (/19H CORRELATION MATRIX) 1050 FORMAT (/45H VARIANCE-COVARIANCE AND CORRELATION MATRICES, + 28H OF THE ESTIMATED PARAMETERS/ 1X, 72('-')/) END *VERSP SUBROUTINE VERSP (WIDE) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE VERSION NUMBER. 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 INTEGER + IPRT C C EXTERNAL SUBROUTINES EXTERNAL IPRINT 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 CALL IPRINT(IPRT) C IF (WIDE) THEN WRITE(IPRT, 1000) ELSE WRITE(IPRT, 1010) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (105X, 'STARPAC 2.08S (03/15/90)') 1010 FORMAT (54X, 'STARPAC 2.08S (03/15/90)') END *VPC SUBROUTINE VPC(YM, N, NS, ILOG, ISIZE, IRLIN, IBAR, + YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IRLIN,ISIZE,N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', 'C', ' ', ' '/ C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ISCHCK = 0 MISS = .FALSE. LISYM = 1 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VPC (Y, N, NS, ILOG,'/ + ' + ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)') END SUBROUTINE VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE CONTROLING ROUTINE FOR USER CALLED VERTICAL PLOTS C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M,N,NS LOGICAL + MISS,MULTI C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(*) INTEGER + ISYM(*) CHARACTER + NMSUB(6)*1 C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + YMN,YMX INTEGER + NSAMPL LOGICAL + ERROR,XCHECK C C EXTERNAL SUBROUTINES EXTERNAL PLTCHK,VERSP,VPLMT,VPMN C C INTRINSIC FUNCTIONS INTRINSIC MAX,MOD C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C A VALUE INDICATING WHETHER AN ERROR WAS DETECTEC (TRUE) C OR NOT (FALSE). C INTEGER IBAR C THE INDICATOR USED TO DESIGNATE WHETHER THE PLOT IS TO BE A C BAR GRAPH (IBAR.GE.1) OR NOT (IBAR.LE.0). C INTEGER IERR C THE COMMON VARIABLE USED TO INDICATE ERRORS, C IF =0, THEN NO ERRORS C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IRLIN C THE INDICATOR USED TO DESIGNATE WHETHER THE PLOT WILL HAVE C THE LOCATION OF ZERO PLOTTED AS A REFERENCE LINE (IRLIN.EQ.0), C THE LOCATION OF THE MEAN PLOTTED AS A REFERENCE LINE (IRLIN.GE. C OR NO REFERENCE LINE (IRLIN.LT.0). C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(LISYM) C VECTOR CONTAINING SYMBOLS FOR PLOTTING, NOT USED IN SOME CASES C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS, NSAMPL C THE SAMPLING FREQUENCY. C LOGICAL XCHECK C INDICATOR VARIABLE USED TO DESIGNATE WHETHER X-AXIS VALUES C ARE TO BE CHECKED (XCHECK = .TRUE.) OR NOT (XCHECK = .FALSE.) C REAL XINC C THE INCREMENT FOR THE X-AXIS. C REAL XLB C THE LOWER BOUND FOR THE X-AXIS. (XLB=XUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YLB C THE LOWER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C REAL YM(IYM,M) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(M) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YMN, YMX C THE Y-AYIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YUB C THE UPPER BOUND FOR THE Y-AXIS. (YLB=YUB INDICATES LIMITS ARE C TO BE DETERMINED FROM THE RANGE OF THE DATA.) C C C COMMENCE BODY OF ROUTINE C XCHECK = .FALSE. CALL PLTCHK (YM, YMMISS, YM, YMMISS, N, M, IYM, MULTI, + ILOG, YLB, YUB, XLB, XINC, NMSUB, MISS, XCHECK) IF (IERR.EQ.0) THEN C C DETERMINE THE BOUNDS FOR THE AXIS AND COMPLETE ERROR CHECKING C NSAMPL = MAX(1, NS) CALL VPLMT (YM, YMMISS, N, M, IYM, YLB, YUB, YMN, YMX, + ERROR, NMSUB, MISS, NSAMPL) IF (ERROR) THEN IERR = 1 ELSE C C PRINT PLOT C IF (MOD(MAX(0,ISIZE),10).EQ.0) THEN CALL VERSP(.TRUE.) ELSE CALL VERSP(.FALSE.) END IF CALL VPMN (YM, YMMISS, N, M, IYM, NSAMPL, ISCHCK, ISYM, LISYM, + ISIZE, YMN, YMX, XLB, XINC, MISS, ILOG, IRLIN, IBAR) C END IF END IF RETURN END SUBROUTINE VP(YM, N, NS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', ' ', ' ', ' '/ C C DEFINE CONSTANTS C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 0 ISIZE = -1 MISS = .FALSE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF C RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VP (Y, N, NS)') END *VPHEAD SUBROUTINE VPHEAD(NSAMPL, IRLIN, IBAR, + REFPT, YWIDTH, YMN, YMX, + ISIZE, ILOG, LINE, NUMCOL, ILOGY, YDMN, YDMX) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRINTS THE HEADING FOR THE VERTICAL PLOT OUTPUT. 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 REAL + REFPT,YDMN,YDMX,YMN,YMX,YWIDTH INTEGER + IBAR,ILOG,ILOGY,IRLIN,ISIZE,NSAMPL,NUMCOL C C ARRAY ARGUMENTS CHARACTER + LINE(103)*1 C C LOCAL SCALARS REAL + DELY INTEGER + I,ICOL,IK,IPRT,JCOL,NLABLY,NLU CHARACTER + FMT*4,YLFMT*205,YLFMT2*205 C C LOCAL ARRAYS REAL + YLABEL(20) INTEGER + ISPACE(20) C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,LOGLMT,PRTCNT C C INTRINSIC FUNCTIONS INTRINSIC ABS,LOG10,MAX,MOD C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C REAL DELY C THE SCALE INTERVAL OF THE PLOT. C CHARACTER FMT*4 C * C INTEGER I C AN INDEXING VARIABLE. C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER ICOL, IK C * C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER ILOGY C THE VALUE OF Q (SEE ILOG) C INTEGER IPRT C THE UNIT NUMBER FOR PRINTED OUTPUT. C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISIZE C INTEGER ISPACE(20) C INTEGER JCOL C CHARACTER*1 LINE(103) C INTEGER NLABLY C INTEGER NLU C INTEGER NSAMPL C THE SAMPLING FREQUENCY, C WHERE IF NSAMPL .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C INTEGER NUMCOL C * C REAL REFPT C THE VALUE ZERO, OR THE MEAN OF THE SERIES, WHICH EVER IS C REQUESTED, USED AS A PLOT REFERENCE LINE. C REAL YDMN, YDMX C THE Y-AXIS DATA LIMITS ACTUALLY USED. C REAL YLABEL(20) C THE Y-AXIS LABLES. C CHARACTER YLFMT*205, YLFMT2*205 C THE FORMATS USED TO PRINT THE X-AXIS C REAL YMN, YMX C THE GRAPH AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YWIDTH C * C CALL IPRINT(IPRT) C C CHECK PLOT SEQUENCE. C IF (NSAMPL.EQ.2) THEN WRITE(IPRT, 1003) ELSE IF (NSAMPL.EQ.3) THEN WRITE(IPRT, 1004) ELSE IF (NSAMPL.GE.4) THEN WRITE(IPRT, 1005) NSAMPL END IF C C PRINT HEADINGS FOR Y C IF (IBAR.EQ.0) THEN IF (IRLIN.GE.1) THEN WRITE(IPRT, 1006) ELSE IF (IRLIN.EQ.0) THEN WRITE(IPRT, 1007) END IF END IF C C FIND SIZE OF PLOT TO BE CREATED C IF (MOD(MAX(0,ISIZE),10).EQ.0) THEN NUMCOL=101 ELSE NUMCOL = 51 END IF C C ADJUST FOR LOG PLOTS IF NECESSARY AND FIND AXIS LABELS C CALL PRTCNT (MOD(MAX(0,ILOG),10),1,ILOGY) CALL LOGLMT (ILOGY, YMN, YMX, YLABEL, NUMCOL, 10, DELY, YWIDTH, + NLABLY, YDMN, YDMX) C C WRITE OUT THE HORIZONTAL AXIS AND THE AXIS LABELS. C DO 330 ICOL=1,NUMCOL LINE(ICOL)='-' 330 CONTINUE LINE(1)='I' IF (ILOGY.EQ.0) THEN NLU = NLABLY+1 DO 340 ICOL=NUMCOL,1,-10 LINE(ICOL)='I' NLU = NLU - 1 ISPACE(NLU) = 1 340 CONTINUE ELSE JCOL = 1 LINE(JCOL) = 'I' NLU = NLABLY DO 345 IK = NLABLY,1,-1 ICOL = ((LOG10(YLABEL(IK))-YMN)/YWIDTH)+1.5E0 LINE(ICOL) = 'I' IF (ICOL-JCOL.GE.10) THEN ISPACE(NLU) = ICOL-JCOL-9 NLU = NLU - 1 YLABEL(NLU) = YLABEL(IK) JCOL = ICOL END IF 345 CONTINUE END IF LINE(NUMCOL+1)='-' LINE(NUMCOL+2)=' ' C C CHECK X-AXIS LABELS FOR FORMAT C FMT = 'F9.4' DO 350 I=1,NLABLY IF (((ABS(YLABEL(I)).GT.0.0E0).AND. + (ABS(YLABEL(I)).LT.0.01E0)) .OR. + ((YLABEL(I).GE.1.0E4).OR.(YLABEL(I).LE.(-1.0E3)))) THEN FMT = 'E9.3' GO TO 355 END IF 350 CONTINUE 355 CONTINUE WRITE(YLFMT2,1000) NLABLY-NLU WRITE(YLFMT,YLFMT2) (FMT, ISPACE(I), I=NLABLY,NLU+1,-1), FMT WRITE(IPRT, YLFMT) (YLABEL(I),I=NLABLY,NLU,-1) C WRITE(IPRT, 1001) '-', (LINE(ICOL), ICOL=1,NUMCOL+2) C RETURN C C FORMAT STATEMENTS C 1000 FORMAT ('(''(11X'',', I2, '('', '', A4, '','', I2, ''X''),', + ''', '', A4, '')'')') 1001 FORMAT (' ',13X, A1, 105A1) 1003 FORMAT(45H0NOTE THAT EVERY OTHER POINT HAS BEEN PLOTTED) 1004 FORMAT(45H0NOTE THAT EVERY THIRD POINT HAS BEEN PLOTTED) 1005 FORMAT(17H0NOTE THAT EVERY , I2, 25HTH POINT HAS BEEN PLOTTED) 1006 FORMAT(/' LOCATION OF MEAN IS GIVEN BY PLOT CHARACTER M') 1007 FORMAT(/' LOCATION OF ZERO IS GIVEN BY PLOT CHARACTER 0') END *VPL SUBROUTINE VPL(YM, N, NS, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N,NS C C ARRAY ARGUMENTS REAL + YM(*) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS REAL + YMMISS(1) INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', 'L', ' ', ' '/ C C SET DEFAULT VALUES C YMMISS(1) = 1.0E0 M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 0 ISIZE = -1 MISS = .FALSE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VPL (Y, N, NS, ILOG)') END SUBROUTINE VPLMT (YM, YMMISS, N, M, IYM, YLB, YUB, YMN, + YMX, ERROR, NMSUB, MISS, NSAMPL) C C THIS ROUTINE SETS THE PLOT LIMITS FOR VERTICAL PLOTS C c Discussion: c c This routine had a minor logical flaw, in the case where all data was c missing. In that case, the values of YMX and YMN were not set, but c were then needed by the ADJLMT routine. The correction was to initialize c the values. c c Modified: c c 24 April 2006 c C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C LOGICAL ERROR C A VALUE INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) C OR NOT (FALSE). C LOGICAL HEAD C PRINT HEADING (HEAD=TRUE) OR NOT (HEAD=FALSE). C INTEGER I, II C INDEXING VARIABLES. C INTEGER IPRT C * C INTEGER IYM C ACTUAL ROW DIMENSION OF YM DECLARED IN THE USERS MAIN PROGRAM C INTEGER J C AN INDEX VARIABLE. C INTEGER M C THE NUMBER OF VECTORS IN YM C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS . C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NSAMPL C * C LOGICAL SETLMT C AN INDICATOR VARIABLE USED TO DETERMINE IF STARTING VALUES C FOR XLB, XINC, YMN, YMX HAVE BEEN FOUND. C REAL YLB C THE USER SUPPLIED Y-AXIS LOWER BOUND. C REAL YM(IYM,M) C THE ARRAY CONTAINING THE DEPENDENT VARIABLE(S). C REAL YMMISS(M) C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IS MISSING. C IF YM(I,J) = YMMISS(J), THE VALUE IS ASSUMED MISSING, OTHERWISE C IT IS NOT. C REAL YMN, YMX C THE Y-AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YUB C THE USER SUPPLIED Y-AXIS UPPER BOUNDS. C integer iym integer m logical error logical head integer i integer ii integer iprt integer j logical miss logical mvchk integer n character*1 nmsub(6) integer nsampl real r1mach logical setlmt real ylb real ym(iym,m) real ymmiss(m) real ymn real ymx real yub ERROR = .FALSE. C C SET LIMITS TO USER SPECIFIED VALUES C IF ( YLB.LT.YUB ) THEN YMN = YLB YMX = YUB C C SET LIMITS TO RANGE OF VALUES WITHIN ANY USER SPECIFIED VALUES C ELSE YMN = r1mach ( 2 ) YMX = -r1mach(2) SETLMT = .FALSE. II = 1 C C FIND FIRST VALUE TO BE PLOTTED C DO 20 I=1,N,NSAMPL DO 10 J=1,M IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 10 IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR. + (YUB.LT.YM(I,J)))) GO TO 10 IF (SETLMT) THEN YMN = MIN(YMN, YM(I,J)) YMX = MAX(YMX, YM(I,J)) ELSE YMN = YM(I,J) YMX = YM(I,J) SETLMT = .TRUE. II = I + NSAMPL END IF 10 CONTINUE IF (SETLMT) GO TO 30 20 CONTINUE C 30 IF (II.LE.1) THEN C C NO VALUES TO BE PLOTTED. PRINT ERROR MESSAGE C ERROR = .TRUE. CALL IPRINT(IPRT) HEAD = .TRUE. CALL EHDR(NMSUB,HEAD) IF (YLB.GE.YUB) THEN WRITE (IPRT, 1010) ELSE WRITE (IPRT, 1020) END IF WRITE (IPRT, 1030) C ELSE C C FIND LIMITS FROM REMAINING VALUES C IF (II.LE.N) THEN DO 50 I=II,N,NSAMPL DO 40 J=1,M IF (MISS .AND. MVCHK(YM(I,J),YMMISS(J))) GO TO 40 IF ((YLB.LT.YUB) .AND. ((YM(I,J).LT.YLB) .OR. + (YUB.LT.YM(I,J)))) GO TO 40 YMN = MIN(YMN, YM(I,J)) YMX = MAX(YMX, YM(I,J)) 40 CONTINUE 50 CONTINUE END IF END IF C C ADJUST Y AXIS LIMITS IF EQUAL C write ( *, * ) ' ' write ( *, * ) 'VPLMT: DEBUG:' write ( *, * ) ' YMN = ', ymn write ( *, * ) ' YMX = ', ymx write ( *, * ) ' All is well?' IF (YMN .GE. YMX) then write ( *, * ) 'YMN .GE. YMX' end if IF (YMN .GE. YMX) then write ( *, * ) 'Gonna call' CALL ADJLMT ( YMN, YMX ) end if write ( *, * ) ' VPLMT: DEBUG: Returned from ADJLMT' END IF C RETURN C C FORMAT STATEMENTS C 1010 FORMAT (/ + 44H NO NON-MISSING PLOT COORDINATES WERE FOUND.) 1020 FORMAT (/ + 40H NO NON-MISSING VALUES WERE FOUND WITHIN, + 26H THE USER SUPPLIED LIMITS.) 1030 FORMAT (/ + 30H THE PLOT HAS BEEN SUPPRESSED.) END *VPMC SUBROUTINE VPMC(YM, YMMISS, N, NS, ILOG, ISIZE, + IRLIN, IBAR, YLB, YUB, XLB, XINC) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA (LONG CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IRLIN,ISIZE,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS INTEGER + IPRT,ISCHCK,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', 'M', 'C', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ISCHCK = 0 MISS = .TRUE. LISYM = 1 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VPMC (Y, YMISS, N, NS, ILOG,'/ + ' + ISIZE, IRLIN, IBAR, YLB, YUB, XLB, XINC)') END *VPM SUBROUTINE VPM(YM, YMMISS, N, NS) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA (SHORT CALL). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,ILOG,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', 'M', ' ', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. ILOG = -1 YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 0 ISIZE = -1 MISS = .TRUE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VPM (Y, YMISS, N, NS)') END *VPML SUBROUTINE VPML(YM, YMMISS, N, NS, ILOG) C C LATEST REVISION - 03/15/90 (JRD) C C THIS IS THE USER CALLABLE ROUTINE WHICH PRODUCES A VERTICAL C PLOT WITH MISSING DATA (LOG PLOT OPTION). C C WRITTEN BY - JANET R. DONALDSON C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO C C CREATION DATE - JANUARY 21, 1982 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER + ILOG,N,NS C C ARRAY ARGUMENTS REAL + YM(*),YMMISS(1) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + XINC,XLB,YLB,YUB INTEGER + IBAR,IPRT,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M LOGICAL + MISS,MULTI C C LOCAL ARRAYS INTEGER + ISYM(1) CHARACTER + NMSUB(6)*1 C C EXTERNAL SUBROUTINES EXTERNAL IPRINT,VPCNT C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C INTEGER IERR C A COMMON VARIABLE USED AS A FLAG TO INDICATE WHETHER C OR NOT THERE ARE ANY ERRORS, IF =0 THEN NO ERRORS. C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER IPRT C OUTPUT LOGICAL UNIT NUMBER C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(1) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE FIRST DIMENSION OF ARRAY YM. C INTEGER LISYM C THE LENGTH OF ARRAY ISYM. C INTEGER M C NUMBER OF Y VECTORS C LOGICAL MISS C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MISSING VALUES C MAY BE PRESENT (MISS = .TRUE.) OR NOT (MISS = .FALSE.) C LOGICAL MULTI C INDICATOR VARIABLE USED TO DESIGNATE WHETHER MULTIPLE Y VALUES C ARE TO BE PLOTTED (MULTI = .TRUE.) OR NOT (MULTI = .FALSE.) C INTEGER N C LENGTH OF VECTORS C CHARACTER*1 NMSUB(6) C THE CHARACTERS OF THE CALLING ROUTINES NAME. C INTEGER NS C THE SAMPLING FREQUENCY, C WHERE IF NS .LE. 1, EVERY POINT IS PLOTTED, C = 2, EVERY OTHER POINT IS PLOTTED, C = 3, EVERY THIRD POINT IS PLOTTED, ETC. C REAL XINC, XLB C INCREMENT AND LOWER BOUNDS FOR X-AXIS. C REAL YLB C LOWER BOUND FOR Y-AXIS. C REAL YM(N,1) C MULTIVARIATE OBSERVATIONS FOR THE Y COORDINATES C REAL YMMISS(1) C THE MISSING VALUE CODE FOR THE Y-AXIS. C REAL YUB C UPPER BOUND FOR Y-AXIS. C C SET UP NAME ARRAYS C DATA + NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) + / ' ', 'V', 'P', 'M', 'L', ' '/ C C SET DEFAULT VALUES C M = 1 IYM = N MULTI = .FALSE. YLB = 0.0E0 YUB = 0.0E0 XLB = 1.0E0 XINC = 1.0E0 ISCHCK = 0 ISIZE = -1 MISS = .TRUE. LISYM = 1 IRLIN = -1 IBAR = 0 C C COMMENCE BODY OF ROUTINE C CALL VPCNT (YM, YMMISS, N, M, IYM, MULTI, ILOG, YLB, YUB, + XLB, XINC, NS, IRLIN, IBAR, NMSUB, ISCHCK, ISYM, ISIZE, + MISS, LISYM) C IF (IERR.NE.0) THEN IERR = 1 CALL IPRINT(IPRT) WRITE (IPRT,1000) END IF RETURN C C FORMAT STATEMENTS C 1000 FORMAT (/42H THE CORRECT FORM OF THE CALL STATEMENT IS// + ' CALL VPML (Y, YMISS, N, NS, ILOG)') END *VPMN SUBROUTINE VPMN (YM, YMMISS, N, M, IYM, NSAMPL, ISCHCK, ISYM, + LISYM, ISIZE, YMN, YMX, XLB, XINC, MISS, ILOG, IRLIN, IBAR) C C LATEST REVISION - 03/15/90 (JRD) C C THIS ROUTINE PRODUCES VERTICAL PLOTS 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 REAL + XINC,XLB,YMN,YMX INTEGER + IBAR,ILOG,IRLIN,ISCHCK,ISIZE,IYM,LISYM,M,N,NSAMPL LOGICAL + MISS C C ARRAY ARGUMENTS REAL + YM(IYM,M),YMMISS(M) INTEGER + ISYM(LISYM) C C SCALARS IN COMMON INTEGER + IERR C C LOCAL SCALARS REAL + REFPT,XLABEL,YDMN,YDMX,YWIDTH,YY INTEGER + I,IEND,ILOGY,IMAX,IMIN,IPOINT,IPRT,IPTSYM,IREFPT,J,NUMCOL, + NUSED LOGICAL + IFMISS CHARACTER + I0*1,IBLANK*1,IM*1,IPLTCH*1,IREFCH*1,FMT*72 C C LOCAL ARRAYS INTEGER + ICOUNT(103) CHARACTER + LINE(103)*1 C C EXTERNAL FUNCTIONS LOGICAL + MVCHK EXTERNAL MVCHK C C EXTERNAL SUBROUTINES EXTERNAL AMEAN,AMEANM,IPRINT,PLINE,PLTPLX,PLTSYM,SETIV,VPHEAD C C INTRINSIC FUNCTIONS INTRINSIC LOG10,MAX,MIN C C COMMON BLOCKS COMMON /ERRCHK/IERR C C VARIABLE DEFINITIONS (ALPHABETICALLY) C C CHARACTER FMT*72 C THE FORMAT FOR THE X-AXIS LABELS C INTEGER I C AN INDEXING VARIABLE. C INTEGER IBAR C THE VARIABLE USED TO DETERMINE IF SINGLE POINTS (IBAR .EQ. 0) C OR BARS (IBAR .NE. 0) ARE TO BE PLOTTED. C CHARACTER*1 IBLANK C THE PLOT SYMBOL BLANK. C INTEGER ICOUNT(103) C THE NUMBER OF PLOT SYMBOLS AT EACH LOCATION. C INTEGER IEND C THE NUMBER OF LOCATIONS IN THE PLOT STRING. 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 LOGICAL IFMISS C THE INDICATOR VARIABLE USED TO DETERMINE WHETHER THE C INPUT SERIES HAS MISSING DATA (TRUE) OR NOT (FALSE). C INTEGER ILOG C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SCALE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS LINEAR. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS LOG. C INTEGER ILOGY C THE VALUE OF Q (SEE ILOG). C CHARACTER*1 IM C THE PLOT SYMBOL M. C INTEGER IMAX C THE LARGEST LOCATION IN THE PLOT STRING BEING DEFINED. C INTEGER IMIN C THE SMALLEST LOCATION IN THE PLOT STRING BEING DEFINED. C CHARACTER*1 IPLTCH C THE PLOT CHARACTER USED FOR A GIVEN LINE OF THE PLOT. C INTEGER IPOINT C THE LOCATION IN THE PLOT STRING OF THE VALUE BEING PLOTTED. C INTEGER IPRT C * C INTEGER IPTSYM C AN INDICATOR VARIABLE USED TO DESIGNATE THE TYPE C OF PLOT. IF ISCHCK = 1, THE PLOT IS A SYMPLE PAGE C OR VERTICAL PLOT. IF ISCHCK = 2, THE PLOT IS A SYMBOL C PLOT. IF ISCHCK = 3, THE PLOT IS A MULTIVARIATE PLOT. C CHARACTER*1 IREFCH C THE PLOT SYMBOL USED TO IDENTIFY THE PLOT REFERENCE LINE. C INTEGER IREFPT C THE LOCATION IN THE PLOT STRING FOR THE VALUE ZERO, OR C SERIES MEAN, WHICH EVER WAS REQUESTED. C INTEGER IRLIN C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ZERO OR THE C SERIES MEAN IS TO BE PLOTTED AS A REFERENCE LINE, OR WHETHER C NO REFERENCE LINE IS TO BE PLOTTED. C IF IRLIN .LE. -1, NO REFERENCE LINE IS PLOTTED. C IF IRLIN .EQ. 0, ZERO IS PLOTTED AS THE REFERENCE LINE. C IF IRLIN .GE. 1, THE SERIES MEAN IS PLOTTED. C INTEGER ISCHCK C THE INTEGER VALUE INDICATING HOW THE PLOTTING SYMBOLS C WILL BE DESIGNATED, WHERE C 0 INDICATES THE PLOTTING SYMBOLS HAVE NOT BEEN DESIGNATED IN C THE N VECTOR ISYM AND ONLY THE SYMBOL + IS TO BE USED C 1 INDICATES THE PLOTTING SYMBOLS HAVE BEEN DESIGNATED IN THE C N VECTOR ISYM C 2 INDICATES THAT M SERIES ARE BEING PLOTTED. C SYMBOL I+4 WILL BE USED FOR COLUMN I OF YM. C INTEGER ISIZE C THE TWO DIGIT INTEGER, PQ, USED TO SELECT AXIS SIZE, WHERE C P DESIGNATES THE X-AXIS AND Q DESIGNATES THE Y-AXIS. C IF P.EQ.0 (Q.EQ.0), THEN THE X-AXIS (Y-AXIS) IS THE MAXIMUM. C IF P.NE.0 (Q.NE.0), THEN THE X-AXIS (Y-AXIS) IS HALF THE MAXIMU C INTEGER ISYM(LISYM) C VECTOR CONTAINING SYMBOL DESIGNATIONS FOR PLOTTING C INTEGER IYM C THE EXACT VALUE OF THE FIRST DIMENSION OF THE MATRIX YM. C CHARACTER*1 I0 C THE PLOT SYMBOL -0-. C INTEGER J C AN INDEX VARIABLE. C CHARACTER*1 LINE(103) C THE VECTOR USED FOR THE PLOT STRING. C INTEGER LISYM C * C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN YM. C LOGICAL MISS C * C INTEGER N C THE INTEGER NUMBER OF OBSERVATIONS . C INTEGER NSAMPL C THE SAMPLING FREQUENCY ACTUALLY USED. C INTEGER NUMCOL C * C INTEGER NUSED C THE NUMBER OF ACTIVE OBSERVATIONS. C REAL REFPT C THE VALUE ZERO, OR THE MEAN OF THE SERIES, WHICH EVER IS C REQUESTED, USED AS A PLOT REFERENCE LINE. C REAL XINC C THE VARIABLE USED TO SPECIFY THE INCREMENT FOR XLABEL. C REAL XLABEL C THE VALUE USED FOR THE LABELS ON THE RIGHT SIDE OF THE PLOT. C REAL XLB C THE STARTING VALUE FOR LABELS ON THE RIGHT SIDE OF THE GRAPH. C REAL YDMN, YDMX C THE Y-AXIS DATA LIMITS ACTUALLY USED. C REAL YM(IYM,M) C THE VECTOR CONTAINING THE OBSERVED TIME SERIES C REAL YMMISS(M) C THE USER SUPPLIED CODE WHICH IS USED TO DETERMINE WHETHER OR C NOT AN OBSERVATION IN THE SERIES IS MISSING. IF YM(I) = YMMISS C THE VALUE IS ASSUMED MISSING, OTHERWISE IT IS NOT. C REAL YMN, YMX C THE GRAPH AXIS LOWER AND UPPER LIMITS ACTUALLY USED. C REAL YWIDTH C THE SCALE INTERVAL OF THE PLOT. C REAL YY C THE VALUE OF YM ACTUALLY BEING PLOTTED C C DATA IBLANK/' '/, IM/'M'/, I0/'0'/ C C PRINT PLOT HEADINGS C CALL IPRINT(IPRT) CALL VPHEAD(NSAMPL, IRLIN, IBAR, + REFPT, YWIDTH, YMN, YMX, ISIZE, ILOG, + LINE, NUMCOL, ILOGY, YDMN, YDMX) IEND = NUMCOL + 2 C C COMPUTE REFERENCE POINT OF GRAPH, IF REQUIRED. C IF (IRLIN.GE.0) THEN IF (IRLIN.EQ.0) THEN C C REFERENCE POINT IS ZERO C REFPT = 0.0E0 IREFCH = I0 ELSE C C REFERENCE POINT IS MEAN C IF (MISS) THEN CALL AMEANM(YM, YMMISS, N, NUSED, REFPT) ELSE CALL AMEAN(YM, N, REFPT) END IF IF (ILOGY.NE.0) REFPT = LOG10(REFPT) IREFCH = IM END IF C C COMPUTE LOCATION OF REFPT IN PLOT STRING C CALL PLTPLX(REFPT, YMN, YWIDTH, IREFPT, IEND) ELSE IREFPT = 1 END IF C C BEGIN PLOTTING C IPTSYM = ISCHCK + 1 XLABEL = XLB DO 50 I=1,N,NSAMPL CALL PLINE(1, IEND, IBLANK, LINE) CALL SETIV(ICOUNT, IEND, 0) IFMISS = .FALSE. IPOINT = 1 DO 30 J=1,M IF (MISS) THEN IFMISS = (IFMISS .OR. (MVCHK(YM(I,J),YMMISS(J)))) IF (.NOT.(MVCHK(YM(I,J),YMMISS(J)))) THEN IF (ILOGY.EQ.0) THEN YY = YM(I,J) ELSE YY = LOG10(YM(I,J)) END IF IF ((YY.GE.YDMN) .AND. (YY.LE.YDMX)) THEN CALL PLTPLX(YY, YMN, YWIDTH, IPOINT, IEND) CALL PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT) IPLTCH = LINE(IPOINT) ELSE IPOINT = IREFPT IPLTCH = IBLANK END IF END IF ELSE IF (ILOGY.EQ.0) THEN YY = YM(I,J) ELSE YY = LOG10(YM(I,J)) END IF IF ((YY.GE.YDMN) .AND. (YY.LE. YDMX)) THEN CALL PLTPLX(YY, YMN, YWIDTH, IPOINT, IEND) CALL PLTSYM(IPTSYM, I, J, ISYM, N, IPOINT, LINE, ICOUNT) IPLTCH = LINE(IPOINT) ELSE IPOINT = IREFPT IPLTCH = IBLANK END IF END IF 30 CONTINUE IF ((IBAR.GE.1) .AND. (.NOT.IFMISS)) THEN IMIN = MIN(IPOINT,IREFPT) IMAX = MAX(IPOINT,IREFPT) CALL PLINE(IMIN, IMAX, IPLTCH, LINE) ELSE IF (IRLIN.GE.0) THEN LINE(IREFPT) = IREFCH END IF C IF (IFMISS) THEN WRITE(FMT,1000) NUMCOL, '8H MISSING' WRITE(IPRT,FMT) XLABEL, (LINE(J), J=1,IEND) ELSE WRITE(FMT,1000) NUMCOL, '1X, G11.5 ' IF (M.EQ.1) THEN WRITE(IPRT,FMT) XLABEL, (LINE(J),J=1,IEND), YM(I,1) ELSE WRITE(IPRT,FMT) XLABEL, (LINE(J),J=1,IEND) END IF END IF XLABEL = XLABEL + XINC*NSAMPL 50 CONTINUE C RETURN C C FORMAT STATEMENTS C 1000 FORMAT('(1X,G11.5,1X,A1,''I'',', I3, 'A1,''I'',A1,',A10,')') 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 REAL + S INTEGER + P C C ARRAY ARGUMENTS REAL + Y(*) C C LOCAL SCALARS INTEGER + I C C DO 10 I = 1, P 10 Y(I) = S RETURN END *XERABT SUBROUTINE XERABT(MESSG,NMESSG) C C LATEST REVISION - JANUARY 24, 1990 (JRD) C C ABSTRACT C ***NOTE*** MACHINE DEPENDENT ROUTINE C XERABT ABORTS THE EXECUTION OF THE PROGRAM. C THE ERROR MESSAGE CAUSING THE ABORT IS GIVEN IN THE CALLING C SEQUENCE IN CASE ONE NEEDS IT FOR PRINTING ON A DAYFILE, C FOR EXAMPLE. C C DESCRIPTION OF PARAMETERS C MESSG AND NMESSG ARE AS IN XERROR, EXCEPT THAT NMESSG MAY C BE ZERO, IN WHICH CASE NO MESSAGE IS BEING SUPPLIED. C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 7 JUNE 1978 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER NMESSG C C ARRAY ARGUMENTS CHARACTER MESSG(1)*4 C STOP END *XERCLR SUBROUTINE XERCLR C C ABSTRACT C THIS ROUTINE SIMPLY RESETS THE CURRENT ERROR NUMBER TO ZERO. C THIS MAY BE NECESSARY TO DO IN ORDER TO DETERMINE THAT C A CERTAIN ERROR HAS OCCURRED AGAIN SINCE THE LAST TIME C NUMXER WAS REFERENCED. C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 7 JUNE 1978 C C C VARIABLE DECLARATIONS C C LOCAL SCALARS INTEGER JUNK C C EXTERNAL FUNCTIONS INTEGER J4SAVE EXTERNAL J4SAVE C JUNK = J4SAVE(1,0,.TRUE.) RETURN END *XERCTL SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL) C C ABSTRACT C ALLOWS USER CONTROL OVER HANDLING OF INDIVIDUAL ERRORS. C JUST AFTER EACH MESSAGE IS RECORDED, BUT BEFORE IT IS C PROCESSED ANY FURTHER (I.E., BEFORE IT IS PRINTED OR C A DECISION TO ABORT IS MADE) A CALL IS MADE TO XERCTL. C IF THE USER HAS PROVIDED HIS OWN VERSION OF XERCTL, HE C CAN THEN OVERRIDE THE VALUE OF KONTROL USED IN PROCESSING C THIS MESSAGE BY REDEFINING ITS VALUE. C KONTRL MAY BE SET TO ANY VALUE FROM -2 TO 2. C THE MEANINGS FOR KONTRL ARE THE SAME AS IN XSETF, EXCEPT C THAT THE VALUE OF KONTRL CHANGES ONLY FOR THIS MESSAGE. C IF KONTRL IS SET TO A VALUE OUTSIDE THE RANGE FROM -2 TO 2, C IT WILL BE MOVED BACK INTO THAT RANGE. C C DESCRIPTION OF PARAMETERS C C --INPUT-- C MESSG1 - THE FIRST WORD (ONLY) OF THE ERROR MESSAGE. C NMESSG - SAME AS IN THE CALL TO XERROR OR XERRWV. C NERR - SAME AS IN THE CALL TO XERROR OR XERRWV. C LEVEL - SAME AS IN THE CALL TO XERROR OR XERRWV. C KONTRL - THE CURRENT VALUE OF THE CONTROL FLAG AS SET C BY A CALL TO XSETF. C C --OUTPUT-- C KONTRL - THE NEW VALUE OF KONTRL. IF KONTRL IS NOT C DEFINED, IT WILL REMAIN AT ITS ORIGINAL VALUE. C THIS CHANGED VALUE OF CONTROL AFFECTS ONLY C THE CURRENT OCCURRENCE OF THE CURRENT MESSAGE. C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER KONTRL,LEVEL,MESSG1,NERR,NMESSG C RETURN END *XERPRT SUBROUTINE XERPRT(MESSG,NMESSG) C C ABSTRACT C PRINT THE HOLLERITH MESSAGE IN MESSG, OF LENGTH MESSG, C ON EACH FILE INDICATED BY XGETUA. C THIS VERSION PRINTS EXACTLY THE RIGHT NUMBER OF CHARACTERS, C NOT A NUMBER OF WORDS, AND THUS SHOULD WORK ON MACHINES C WHICH DO NOT BLANK FILL THE LAST WORD OF THE HOLLERITH. C C RON JONES, JUNE 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER NMESSG C C ARRAY ARGUMENTS CHARACTER MESSG(NMESSG)*4 C C LOCAL SCALARS INTEGER I,IUNIT,KUNIT,NCHAR,NCHARL,NCHLST,NCHREM,NFIELD,NLINES, + NUNIT,NWORD,NWORD1,NWORD2 CHARACTER LA*1,LBLANK*1,LCOM*1 C C LOCAL ARRAYS INTEGER LUN(5) CHARACTER F(10)*1,G(14)*1 C C EXTERNAL FUNCTIONS INTEGER I1MACH EXTERNAL I1MACH C C EXTERNAL SUBROUTINES EXTERNAL S88FMT,XGETUA C C INTRINSIC FUNCTIONS INTRINSIC MOD C DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10) 1 / '(' ,'1' ,'X' ,',' ,' ' ,' ' ,'A' ,' ' ,' ' ,')' / DATA G(1),G(2),G(3),G(4),G(5),G(6),G(7),G(8),G(9),G(10) 1 / '(' ,'1' ,'X' ,' ' ,' ' ,' ' ,' ' ,' ' ,' ' ,' ' / DATA G(11),G(12),G(13),G(14) 1 / ' ' ,' ' ,' ' ,')' / DATA LA/'A'/,LCOM/','/,LBLANK/' '/ C PREPARE FORMAT FOR WHOLE LINES NCHAR = I1MACH(6) NFIELD = 72/NCHAR CALL S88FMT(2,NFIELD,F(5)) CALL S88FMT(2,NCHAR,F(8)) C PREPARE FORMAT FOR LAST, PARTIAL LINE, IF NEEDED NCHARL = NFIELD*NCHAR NLINES = NMESSG/NCHARL NWORD = NLINES*NFIELD NCHREM = NMESSG - NLINES*NCHARL IF (NCHREM.LE.0) GO TO 40 DO 10 I=4,13 10 G(I) = LBLANK NFIELD = NCHREM/NCHAR IF (NFIELD.LE.0) GO TO 20 C PREPARE WHOLE WORD FIELDS G(4) = LCOM CALL S88FMT(2,NFIELD,G(5)) G(7) = LA CALL S88FMT(2,NCHAR,G(8)) 20 CONTINUE NCHLST = MOD(NCHREM,NCHAR) IF (NCHLST.LE.0) GO TO 30 C PREPARE PARTIAL WORD FIELD G(10) = LCOM G(11) = LA CALL S88FMT(2,NCHLST,G(12)) 30 CONTINUE 40 CONTINUE C PRINT THE MESSAGE NWORD1 = NWORD+1 NWORD2 = (NMESSG+NCHAR-1)/NCHAR CALL XGETUA(LUN,NUNIT) DO 50 KUNIT = 1,NUNIT IUNIT = LUN(KUNIT) IF (IUNIT.EQ.0) IUNIT = I1MACH(4) IF (NWORD.GT.0) WRITE (IUNIT,F) (MESSG(I),I=1,NWORD) IF (NCHREM.GT.0) WRITE (IUNIT,G) (MESSG(I),I=NWORD1,NWORD2) 50 CONTINUE RETURN END *XERROR SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL) C C ABSTRACT C XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER C DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE C OF THE LIBRARY ERROR CONTROL FLAG, KONTRL. C (SEE SUBROUTINE XSETF FOR DETAILS.) C C DESCRIPTION OF PARAMETERS C --INPUT-- C MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING C NO MORE THAN 72 CHARACTERS. C NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG. C NERR - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE. C NERR MUST NOT BE ZERO. C LEVEL - ERROR CATEGORY. C =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR. C =1 MEANS THIS IS A RECOVERABLE ERROR. (I.E., IT IS C NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.) C =0 MEANS THIS IS A WARNING MESSAGE ONLY. C =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE C PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY C TIMES THIS CALL IS EXECUTED. C C EXAMPLES C CALL XERROR('SMOOTH -- NUM WAS ZERO.',23,1,2) C CALL XERROR('INTEG -- LESS THAN FULL ACCURACY ACHIEVED.', C 43,2,1) C CALL XERROR( 'ROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL C 1 FULLY COLLAPSED.',65,3,0) C CALL XERROR('EXP -- UNDERFLOWS BEING SET TO ZERO.',39,1,-1) C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 7 FEB 1979 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER LEVEL,NERR,NMESSG C C ARRAY ARGUMENTS CHARACTER MESSG(NMESSG)*4 C C EXTERNAL SUBROUTINES EXTERNAL XERRWV C CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.) RETURN END *XERRWV SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2) C C ABSTRACT C XERRWV PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER C DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE C OF THE LIBRARY ERROR CONTROL FLAG, KONTRL. C (SEE SUBROUTINE XSETF FOR DETAILS.) C IN ADDITION, UP TO TWO INTEGER VALUES AND TWO REAL C VALUES MAY BE PRINTED ALONG WITH THE MESSAGE. C C DESCRIPTION OF PARAMETERS C --INPUT-- C MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED. C NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG. C NERR - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE. C NERR MUST NOT BE ZERO. C LEVEL - ERROR CATEGORY. C =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR. C =1 MEANS THIS IS A RECOVERABLE ERROR. (I.E., IT IS C NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.) C =0 MEANS THIS IS A WARNING MESSAGE ONLY. C =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE C PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY C TIMES THIS CALL IS EXECUTED. C NI - NUMBER OF INTEGER VALUES TO BE PRINTED. (O TO 2) C I1 - FIRST INTEGER VALUE. C I2 - SECOND INTEGER VALUE. C NR - NUMBER OF REAL VALUES TO BE PRINTED. (0 TO 2) C R1 - FIRST REAL VALUE. C R2 - SECOND REAL VALUE. C C EXAMPLES C CALL XERROR('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2, C 1 1,NUM,0,0,0.,0.) C CALL XERRWV( 'QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM C 1 (R2).',54,77,1,0,0,0,2,ERRREQ,ERRMIN) C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 19 MAR 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS REAL R1,R2 INTEGER I1,I2,LEVEL,NERR,NI,NMESSG,NR C C ARRAY ARGUMENTS CHARACTER MESSG(NMESSG)*4 C C LOCAL SCALARS INTEGER IFATAL,IUNIT,JUNK,KDUMMY,KOUNT,KUNIT,LERR,LKNTRL,LLEVEL, + LMESSG,MAXMES,MKNTRL,NUNIT CHARACTER LFIRST*4 C C LOCAL ARRAYS INTEGER LUN(5) C C EXTERNAL FUNCTIONS INTEGER I1MACH,J4SAVE EXTERNAL I1MACH,J4SAVE C C EXTERNAL SUBROUTINES EXTERNAL FDUMP,XERABT,XERCTL,XERPRT,XERSAV,XGETUA C C INTRINSIC FUNCTIONS INTRINSIC IABS,MAX,MIN C C GET FLAGS LKNTRL = J4SAVE(2,0,.FALSE.) MAXMES = J4SAVE(4,0,.FALSE.) C CHECK FOR VALID INPUT IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND. 1 (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10 IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17) CALL XERPRT('XERROR -- INVALID INPUT',23) IF (LKNTRL.GT.0) CALL FDUMP IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.', 1 29) IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY) CALL XERABT('XERROR -- INVALID INPUT',23) RETURN 10 CONTINUE C RECORD MESSAGE JUNK = J4SAVE(1,NERR,.TRUE.) CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT) C LET USER OVERRIDE LFIRST = MESSG(1) LMESSG = NMESSG LERR = NERR LLEVEL = LEVEL CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL) C RESET TO ORIGINAL VALUES LMESSG = NMESSG LERR = NERR LLEVEL = LEVEL LKNTRL = MAX(-2,MIN(2,LKNTRL)) MKNTRL = IABS(LKNTRL) C DECIDE WHETHER TO PRINT MESSAGE IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100 IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN(1,MAXMES))) 1.OR.((LLEVEL.EQ.0) .AND.(KOUNT.GT.MAXMES)) 2.OR.((LLEVEL.EQ.1) .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1)) 3.OR.((LLEVEL.EQ.2) .AND.(KOUNT.GT.MAX(1,MAXMES)))) GO TO 100 IF (LKNTRL.LE.0) GO TO 20 CALL XERPRT(' ',1) C INTRODUCTION IF (LLEVEL.EQ.(-1)) CALL XERPRT 1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57) IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13) IF (LLEVEL.EQ.1) CALL XERPRT 1 ('RECOVERABLE ERROR IN...',23) IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17) 20 CONTINUE C MESSAGE CALL XERPRT(MESSG,LMESSG) CALL XGETUA(LUN,NUNIT) DO 50 KUNIT=1,NUNIT IUNIT = LUN(KUNIT) IF (IUNIT.EQ.0) IUNIT = I1MACH(4) IF (NI.GE.1) WRITE (IUNIT,22) I1 IF (NI.GE.2) WRITE (IUNIT,23) I2 IF (NR.GE.1) WRITE (IUNIT,24) R1 IF (NR.GE.2) WRITE (IUNIT,25) R2 22 FORMAT (11X,'IN ABOVE MESSAGE, I1=',I10) 23 FORMAT (11X,'IN ABOVE MESSAGE, I2=',I10) 24 FORMAT (11X,'IN ABOVE MESSAGE, R1=',E20.10) 25 FORMAT (11X,'IN ABOVE MESSAGE, R2=',E20.10) IF (LKNTRL.LE.0) GO TO 40 C ERROR NUMBER WRITE (IUNIT,30) LERR 30 FORMAT (' ERROR NUMBER =',I10) 40 CONTINUE 50 CONTINUE C TRACE-BACK IF (LKNTRL.GT.0) CALL FDUMP 100 CONTINUE IFATAL = 0 IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2))) 1IFATAL = 1 C QUIT HERE IF MESSAGE IS NOT FATAL IF (IFATAL.LE.0) RETURN IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX(1,MAXMES))) GO TO 120 C PRINT REASON FOR ABORT IF (LLEVEL.EQ.1) CALL XERPRT 1 ('JOB ABORT DUE TO UNRECOVERED ERROR.',35) IF (LLEVEL.EQ.2) CALL XERPRT 1 ('JOB ABORT DUE TO FATAL ERROR.',29) C PRINT ERROR SUMMARY CALL XERSAV(' ',-1,0,0,KDUMMY) 120 CONTINUE C ABORT IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX(1,MAXMES))) LMESSG = 0 CALL XERABT(MESSG,LMESSG) RETURN END *XERSAV SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT) C C ABSTRACT C RECORD THAT THIS ERROR OCCURRED. C C DESCRIPTION OF PARAMETERS C --INPUT-- C MESSG, NMESSG, NERR, LEVEL ARE AS IN XERROR, C EXCEPT THAT WHEN NMESSG=0 THE TABLES WILL BE C DUMPED AND CLEARED, AND WHEN NMESSG IS LESS THAN ZERO THE C TABLES WILL BE DUMPED AND NOT CLEARED. C --OUTPUT-- C ICOUNT WILL BE THE NUMBER OF TIMES THIS MESSAGE HAS C BEEN SEEN, OR ZERO IF THE TABLE HAS OVERFLOWED AND C DOES NOT CONTAIN THIS MESSAGE SPECIFICALLY. C WHEN NMESSG=0, ICOUNT WILL NOT BE ALTERED. C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 19 MAR 1980 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER ICOUNT,LEVEL,NERR,NMESSG C C ARRAY ARGUMENTS CHARACTER MESSG(NMESSG)*4 C C LOCAL SCALARS INTEGER I,II,IUNIT,KOUNTX,KUNIT,NCHAR,NCOL,NUNIT C C LOCAL ARRAYS INTEGER KOUNT(10),LEVTAB(10),LUN(5),NERTAB(10) CHARACTER F(17)*1,MESTAB(10)*4 C C EXTERNAL FUNCTIONS INTEGER I1MACH EXTERNAL I1MACH C C EXTERNAL SUBROUTINES EXTERNAL S88FMT,XGETUA C C NEXT THREE DATA STATEMENTS ARE NEEDED MERELY TO SATISFY C CERTAIN CONVENTIONS FOR COMPILERS WHICH DYNAMICALLY C ALLOCATE STORAGE. DATA MESTAB(1),MESTAB(2),MESTAB(3),MESTAB(4),MESTAB(5), 1 MESTAB(6),MESTAB(7),MESTAB(8),MESTAB(9),MESTAB(10) 2 /'0','0','0','0','0','0','0','0','0','0'/ DATA NERTAB(1),NERTAB(2),NERTAB(3),NERTAB(4),NERTAB(5), 1 NERTAB(6),NERTAB(7),NERTAB(8),NERTAB(9),NERTAB(10) 2 /0,0,0,0,0,0,0,0,0,0/ DATA LEVTAB(1),LEVTAB(2),LEVTAB(3),LEVTAB(4),LEVTAB(5), 1 LEVTAB(6),LEVTAB(7),LEVTAB(8),LEVTAB(9),LEVTAB(10) 2 /0,0,0,0,0,0,0,0,0,0/ C NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK C ERROR TABLE INITIALLY DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5), 1 KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10) 2 /0,0,0,0,0,0,0,0,0,0/ DATA KOUNTX/0/ C NEXT DATA STATEMENT SETS UP OUTPUT FORMAT DATA F(1),F(2),F(3),F(4),F(5),F(6),F(7),F(8),F(9),F(10), 1 F(11),F(12),F(13),F(14),F(15),F(16),F(17) 2 /'(' ,'1' ,'X' ,',' ,'A' ,' ' ,' ' ,',' ,'I' ,' ' , 3 ' ' ,',' ,'2' ,'I' ,'1' ,'0' ,')' / IF (NMESSG.GT.0) GO TO 80 C DUMP THE TABLE IF (KOUNT(1).EQ.0) RETURN C PREPARE FORMAT NCHAR = I1MACH(6) CALL S88FMT(2,NCHAR,F(6)) NCOL = 20 - NCHAR CALL S88FMT(2,NCOL,F(10)) C PRINT TO EACH UNIT CALL XGETUA(LUN,NUNIT) DO 60 KUNIT=1,NUNIT IUNIT = LUN(KUNIT) IF (IUNIT.EQ.0) IUNIT = I1MACH(4) C PRINT TABLE HEADER WRITE (IUNIT,10) 10 FORMAT ('0 ERROR MESSAGE SUMMARY'/ 1 ' FIRST WORD NERR LEVEL COUNT') C PRINT BODY OF TABLE DO 20 I=1,10 IF (KOUNT(I).EQ.0) GO TO 30 WRITE (IUNIT,F) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I) 20 CONTINUE 30 CONTINUE C PRINT NUMBER OF OTHER ERRORS IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX 40 FORMAT (/' OTHER ERRORS NOT INDIVIDUALLY TABULATED=',I10) WRITE (IUNIT,50) 50 FORMAT (1X) 60 CONTINUE IF (NMESSG.LT.0) RETURN C CLEAR THE ERROR TABLES DO 70 I=1,10 70 KOUNT(I) = 0 KOUNTX = 0 RETURN 80 CONTINUE C PROCESS A MESSAGE... C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. DO 90 I=1,10 II = I IF (KOUNT(I).EQ.0) GO TO 110 IF (MESSG(1).NE.MESTAB(I)) GO TO 90 IF (NERR.NE.NERTAB(I)) GO TO 90 IF (LEVEL.NE.LEVTAB(I)) GO TO 90 GO TO 100 90 CONTINUE C THREE POSSIBLE CASES... C TABLE IS FULL KOUNTX = KOUNTX+1 ICOUNT = 1 RETURN C MESSAGE FOUND IN TABLE 100 KOUNT(II) = KOUNT(II) + 1 ICOUNT = KOUNT(II) RETURN C EMPTY SLOT FOUND FOR NEW MESSAGE 110 MESTAB(II) = MESSG(1) NERTAB(II) = NERR LEVTAB(II) = LEVEL KOUNT(II) = 1 ICOUNT = 1 RETURN END *XGETF SUBROUTINE XGETF(KONTRL) C C ABSTRACT C XGETF RETURNS THE CURRENT VALUE OF THE ERROR CONTROL FLAG C IN KONTRL. SEE SUBROUTINE XSETF FOR FLAG VALUE MEANINGS. C (KONTRL IS AN OUTPUT PARAMETER ONLY.) C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 7 JUNE 1978 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER KONTRL C C EXTERNAL FUNCTIONS INTEGER J4SAVE EXTERNAL J4SAVE C KONTRL = J4SAVE(2,0,.FALSE.) RETURN END *XGETUA SUBROUTINE XGETUA(IUNIT,N) C C ABSTRACT C XGETUA MAY BE CALLED TO DETERMINE THE UNIT NUMBER OR NUMBERS C TO WHICH ERROR MESSAGES ARE BEING SENT. C THESE UNIT NUMBERS MAY HAVE BEEN SET BY A CALL TO XSETUN, C OR A CALL TO XSETUA, OR MAY BE A DEFAULT VALUE. C C DESCRIPTION OF PARAMETERS C --OUTPUT-- C IUNIT - AN ARRAY OF ONE TO FIVE UNIT NUMBERS, DEPENDING C ON THE VALUE OF N. A VALUE OF ZERO REFERS TO THE C DEFAULT UNIT, AS DEFINED BY THE I1MACH MACHINE C CONSTANT ROUTINE. ONLY IUNIT(1),...,IUNIT(N) ARE C DEFINED BY XGETUA. THE VALUES OF IUNIT(N+1),..., C IUNIT(5) ARE NOT DEFINED (FOR N.LT.5) OR ALTERED C IN ANY WAY BY XGETUA. C N - THE NUMBER OF UNITS TO WHICH COPIES OF THE C ERROR MESSAGES ARE BEING SENT. N WILL BE IN THE C RANGE FROM 1 TO 5. C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER N C C ARRAY ARGUMENTS INTEGER IUNIT(5) C C LOCAL SCALARS INTEGER I,INDEX C C EXTERNAL FUNCTIONS INTEGER J4SAVE EXTERNAL J4SAVE C N = J4SAVE(5,0,.FALSE.) DO 30 I=1,N INDEX = I+4 IF (I.EQ.1) INDEX = 3 IUNIT(I) = J4SAVE(INDEX,0,.FALSE.) 30 CONTINUE RETURN END *XSETF SUBROUTINE XSETF(KONTRL) C C ABSTRACT C XSETF SETS THE ERROR CONTROL FLAG VALUE TO KONTRL. C (KONTRL IS AN INPUT PARAMETER ONLY.) C THE FOLLOWING TABLE SHOWS HOW EACH MESSAGE IS TREATED, C DEPENDING ON THE VALUES OF KONTRL AND LEVEL. (SEE XERROR C FOR DESCRIPTION OF LEVEL.) C C IF KONTRL IS ZERO OR NEGATIVE, NO INFORMATION OTHER THAN THE C MESSAGE ITSELF (INCLUDING NUMERIC VALUES, IF ANY) WILL BE C PRINTED. IF KONTRL IS POSITIVE, INTRODUCTORY MESSAGES, C TRACE-BACKS, ETC., WILL BE PRINTED IN ADDITION TO THE MESSAGE. C C IABS(KONTRL) C LEVEL 0 1 2 C VALUE C 2 FATAL FATAL FATAL C C 1 NOT PRINTED PRINTED FATAL C C 0 NOT PRINTED PRINTED PRINTED C C -1 NOT PRINTED PRINTED PRINTED C ONLY ONLY C ONCE ONCE C C WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE C LATEST REVISION --- 23 MAY 1979 C C C VARIABLE DECLARATIONS C C SCALAR ARGUMENTS INTEGER KONTRL C C LOCAL SCALARS INTEGER JUNK C C EXTERNAL FUNCTIONS INTEGER J4SAVE EXTERNAL J4SAVE C C EXTERNAL SUBROUTINES EXTERNAL XERRWV C IF ((KONTRL.GE.(-2)).AND.(KONTRL.LE.2)) GO TO 10 CALL XERRWV('XSETF -- INVALID VALUE OF KONTRL (I1).',33,1,2, 1 1,KONTRL,0,0,0.,0.) RETURN 10 JUNK = J4SAVE(2,KONTRL,.TRUE.) RETURN END