SUBROUTINE DPSORT(X,N,Y) C C ***** NOTE--THIS SUBROUTINE IS IDENTICAL TO THE SUBROUTINE SORT C AND HAS BEEN REPRODUCED TO FACILITATE EXECUTION EFFICIENCY. C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X C AND PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR Y. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR Y, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR Y, ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL DPSORT(X,N,X) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE QUICKSORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM QUICKSORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 ( QUICKSORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C DIMENSION IU(36) DIMENSION IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSO' ISUBN2='RT ' C IERROR='NO' IBUGA3='OFF' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SORT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************ C ** SORT THE VALUES. ** C ************************ C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SORT--', 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') Y(1)=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') DO137I=1,N Y(I)=X(I) 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** COPY THE VECTOR X INTO THE VECTOR Y ** C ******************************************* C DO200I=1,N Y(I)=X(I) 200 CONTINUE C C ********************************************************** C ** STEP 3-- ** C ** CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ** C ********************************************************** C NM1=N-1 DO250I=1,NM1 IP1=I+1 IF(Y(I).LE.Y(IP1))GOTO250 GOTO290 250 CONTINUE GOTO9000 290 CONTINUE C C *************************** C ** STEP 4-- ** C ** CARRY OUT THE SORT. ** C *************************** C M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=Y(MID) IF(Y(I).LE.AMED)GOTO320 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) 320 L=J IF(Y(J).GE.AMED)GOTO340 Y(MID)=Y(J) Y(J)=AMED AMED=Y(MID) IF(Y(I).LE.AMED)GOTO340 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) GOTO340 330 Y(L)=Y(K) Y(K)=TT 340 L=L-1 IF(Y(L).GT.AMED)GOTO340 TT=Y(L) 350 K=K+1 IF(Y(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)GOTO9000 I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=Y(I+1) IF(Y(I).LE.AMED)GOTO390 K=I 395 Y(K+1)=Y(K) K=K-1 IF(AMED.LT.Y(K))GOTO395 Y(K+1)=AMED GOTO390 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SORT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, CCCCC JULY 2002. ADD ISEED FOR HODGES-LEHMAN PLOT 1ISEED, 1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING STATISTIC PLOTS-- C MEAN STATISTIC PLOT C MIDM STATISTIC PLOT C MEDI STATISTIC PLOT C SD STATISTIC PLOT C REL SD STATISTIC PLOT C COEFFICIENT OF VARIATION STATISTIC PLOT C SD MEAN STATISTIC PLOT C VARI STATISTIC PLOT C REL VARI STATISTIC PLOT C VARI MEAN STATISTIC PLOT C RANG STATISTIC PLOT C MINI STATISTIC PLOT C MAXI STATISTIC PLOT C EXTREME STATISTIC PLOT C SKEW STATISTIC PLOT C KURT STATISTIC PLOT C AUCR STATISTIC PLOT C SDM STATISTIC PLOT C AUCV STATISTIC PLOT C RACV STATISTIC PLOT C LOWH STATISTIC PLOT C UPPH STATISTIC PLOT C LOWQ STATISTIC PLOT C UPPQ STATISTIC PLOT C TRIM STATISTIC PLOT C WINM STATISTIC PLOT C MIDQ STATISTIC PLOT C 1DEC STATISTIC PLOT C 2DEC STATISTIC PLOT C 3DEC STATISTIC PLOT C 4DEC STATISTIC PLOT C 5DEC STATISTIC PLOT C 6DEC STATISTIC PLOT C 7DEC STATISTIC PLOT C 8DEC STATISTIC PLOT C 9DEC STATISTIC PLOT C SINE FREQUENCY STATISTIC PLOT C SINE AMPLITUDE STATISTIC PLOT C TAGUCHI SIGNAL-TO-NOISE PLOTS C CP PLOT C CPL PLOT C CPU PLOT C CPK PLOT C CPM PLOT C CC PLOT C CNPK PLOT C PERCENT DEFECTIVE PLOT C EXPECTED LOSS PLOT C NORM PPCC STATISTIC PLOT C AAD PLOT C MAD PLOT C SN PLOT C QN PLOT C PERCENTILE PLOT C GEOMETRIC MEAN PLOT C GEOMETRIC STANDARD DEVIATION PLOT C HARMONIC MEAN PLOT C INTERQUARTILE RANGE PLOT C BIWEIGHT LOCATION PLOT C BIWEIGHT SCALE PLOT C WINSORIZED VARIANCE PLOT C WINSORIZED SD PLOT C BIWEIGHT MIDVARIANCE PLOT C PERCENTAGE BEND MIDVARIANCE PLOT C HODGES LEHMAN PLOT C QUANTILE PLOT C QUANTILE STANDARD ERROR PLOT C TRIMMED MEAN STANDARD ERROR PLOT C C FOLLOWING REQUIRE TWO RESPONSE VARIABLES C COVARIANCE PLOT C RANK COVARIANCE PLOT C CORRELATION PLOT C RANK CORRELATION PLOT C KENDELL TAU PLOT C COMOVEMENT PLOT C RANK COMOVEMENT PLOT C WINSORIZED COVARIANCE PLOT C WINSORIZED CORRELATION PLOT C BIWEIGHT MIDCOVARIANCE PLOT C BIWEIGHT MIDCORRELATION PLOT C PERCENTAGE BEND CORRELATION PLOT C LINEAR INTERCEPT STATISTIC PLOT C LINEAR SLOPE STATISTIC PLOT C LINEAR RESSD STATISTIC PLOT C LINEAR CORRELATION STATISTIC PLOT C REPEATABILITY SD STATISTIC PLOT C REPRODUCABILITY SD STATISTIC PLOT C WEIGHTED MEAN PLOT C WEIGHTED SD PLOT C WEIGHTED VARIANCE PLOT C WEIGHTED TRIMMED MEAN PLOT C RATIO PLOT C C FOLLOWING STATISTICS COMPUTE DIFFERENCE IN C STATISTIC FOR TWO RESPONSE VARIABLES (USED FOR C LOCATION AND SCALE STATISTICS): C C LOCATION: C DIFFERENCE OF MEANS PLOT X1 X2 C DIFFERENCE OF MIDMEANS PLOT X1 X2 C DIFFERENCE OF MEDIANS PLOT X1 X2 C DIFFERENCE OF TRIMMED MEANS PLOT X1 X2 C DIFFERENCE OF WINSORIZED MEANS PLOT X1 X2 C DIFFERENCE OF GEOMETRIC MEANS PLOT X1 X2 C DIFFERENCE OF HARMONIC MEANS PLOT X1 X2 C DIFFERENCE OF HODGES-LEHMAN PLOT X1 X2 C DIFFERENCE OF BIWEIGHT LOCATION PLOT X1 X2 C C SCALE: C DIFFERENCE OF STANDARD DEVIATIONS PLOT X1 X2 C DIFFERENCE OF VARIANCES PLOT X1 X2 C DIFFERENCE OF AAD PLOT X1 X2 C DIFFERENCE OF MAD PLOT X1 X2 C DIFFERENCE OF SN PLOT X1 X2 C DIFFERENCE OF QN PLOT X1 X2 C DIFFERENCE OF INTERQUARTILE RANGE PLOT X1 X2 C DIFFERENCE OF WINSORIZED SD PLOT X1 X2 C DIFFERENCE OF WINSORIZED VARIANCE PLOT X1 X2 C DIFFERENCE OF BIWEIGHT MIDVARIANCE PLOT X1 X2 C DIFFERENCE OF BIWEIGHT SCALE PLOT X1 X2 C DIFFERENCE OF PERCENTAGE BEND PLOT X1 X2 C DIFFERENCE OF GEOMETRIC SD PLOT X1 X2 C DIFFERENCE OF RANGE PLOT X1 X2 C DIFFERENCE OF MIDRANGE PLOT X1 X2 C DIFFERENCE OF QUANTILE PLOT X1 X2 C DIFFERENCE OF SKEWNESS PLOT X1 X2 C DIFFERENCE OF KURTOSIS PLOT X1 X2 C DIFFERENCE OF RELATIVE SD PLOT X1 X2 C DIFFERENCE OF SD OF MEAN PLOT X1 X2 C DIFFERENCE OF RELATIVE VARIANCE PLOT X1 X2 C DIFFERENCE OF VARIANCE OF THE MEAN PLOT X1 X2 C DIFFERENCE OF MINIMUM PLOT X1 X2 C DIFFERENCE OF MAXIMUM PLOT X1 X2 C DIFFERENCE OF EXTREMES PLOT X1 X2 C DIFFERENCE OF COEFFICENT OF VARI PLOT X1 X2 C DIFFERENCE OF COUNTS PLOT X1 X2 C DIFFERENCE OF SUM PLOT X1 X2 C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/1 C ORIGINAL VERSION--JANUARY 1988. C UPDATED --MARCH 1988. LINEAR INTERCEPT & SLOPE PLOTS C UPDATED --MARCH 1988. LINEAR RESSD AND CORRELATION PLOTS C UPDATED --AUGUST 1988. TAGUCHI SIGNAL-TO-NOISE PLOTS C UPDATED --MAY 1989. CAN OMIT 'TAGUCHI' IN SN.. PLOTS C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --SEPTEMBER 1992. FIX DEBUG SECTION AT EXIT C UPDATED --SEPTEMBER 1993. CP PLOT C UPDATED --SEPTEMBER 1993. CPK PLOT C UPDATED --SEPTEMBER 1993. PERCENT DEFECTIVE PLOT C UPDATED --SEPTEMBER 1993. EXPECTED LOSS PLOT C UPDATED --DECEMBER 1993. SYNONYMS FOR TAGUCHI S/N PLOTS C UPDATED --FEBRUARY 1994. CHANGE ICASPL: SDM => SDME C UPDATED --FEBRUARY 1994. CHANGE ICASPL: VM => VAME C UPDATED --FEBRUARY 1994. CHANGE ICASPL: RSD => RESD C UPDATED --FEBRUARY 1994. CHANGE ICASPL: RVAR => REVA C UPDATED --FEBRUARY 1994. ALLOW SD MEAN C UPDATED --FEBRUARY 1994. ADD VARI OF MEAN C UPDATED --FEBRUARY 1994. ADD EXTREME C UPDATED --FEBRUARY 1994. ADD NORMAL PPCC C UPDATED --MARCH 1994. WINSORIZED MEAN AS SYNONYM TO C WINDSORIZED MEAN. C UPDATED --MARCH 1995. ADD AAD AND MAD C UPDATED --JANUARY 1998. NAME CONFLICT FOR MINIMUM AND C MAXIMUM WITH BLOCK PLOT C UPDATED --NOVEMBER 1998. ADD PERCENTILE PLOT C UPDATED --NOVEMBER 1998. ADD CPM PLOT, CC PLOT C UPDATED --MARCH 1999. ADD GEOMETRIC MEAN PLOT C UPDATED --MARCH 1999. ADD GEOMETRIC STANDARD DEVIATION PLOT C UPDATED --MARCH 1999. ADD HARMONIC MEAN PLOT C UPDATED --OCTOBER 1999. SAVE INTERNAL PARAMETER C ALOWHIGH C UPDATED --APRIL 2001. ADD CPL PLOT, CPU PLOT C UPDATED --SEPTEMBER 2001. ADD IQ RANGE PLOT C UPDATED --NOVEMBER 2001. ADD BIWEIGHT LOCATION PLOT C UPDATED --NOVEMBER 2001. ADD BIWEIGHT SCALE PLOT C UPDATED --JULY 2002. ADD WINSORIZED VARIANCE PLOT C UPDATED --JULY 2002. ADD WINSORIZED SD PLOT C UPDATED --JULY 2002. ADD WINSORIZED COVARIANCE PLOT C UPDATED --JULY 2002. ADD WINSORIZED CORRELATION PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCOVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCORRELATION PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND MIDVARIANCE C PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND CORRELATION C PLOT C UPDATED --JULY 2002. ADD HODGES LEHMAN PLOT C UPDATED --JULY 2002. ADD QUANTILE PLOT C UPDATED --JULY 2002. ADD QUANTILE STANDARD ERROR PLOT C UPDATED --JULY 2002. ADD TRIMMED MEAN STANDARD ERROR C PLOT C UPDATED --MARCH 2003. ADD 35 "DIFFERENCE OF" STATISTICS C UPDATED --MARCH 2003. ADD WEIGHTED MEAN, WEIGHTED SD, C WEIGHTED VARIANCE C UPDATED --APRIL 2003. ADD SN AND QN (AND DIFFERENCE C OF), REQUIRED ADDITIONAL C SCRATCH ARRAYS C UPDATED --MAY 2003. ADD WEIGHTED TRIMMED MEAN C UPDATED --OCTOBER 2004. ADD KENDELL TAU C UPDATED --FEBRUARY 2005. ADD REPEATABILITY SD C UPDATED --FEBRUARY 2005. ADD REPRODUCABILITY SD C UPDATED --SEPTEMBER 2005. ADD RATIO (SUM1/SUM2) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IERRO2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHX CHARACTER*4 IHX2 C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION Y1(MAXOBV) DIMENSION Z1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XTEMP3(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),Z1(1)) EQUIVALENCE (GARBAG(IGARB4),XTEMP3(1)) CCCCC END CHANGE C CCCCC JULY 2002. ADD INTEGER ARRAYS FOR HODGES-LEHMAN PLOT. INCLUDE 'DPCOZI.INC' C INTEGER ITEMP1(MAXOBV) INTEGER ITEMP2(MAXOBV) INTEGER ITEMP3(MAXOBV) INTEGER ITEMP4(MAXOBV) INTEGER ITEMP5(MAXOBV) INTEGER ITEMP6(MAXOBV) EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1)) EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1)) EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1)) EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1)) EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1)) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPSP' ISUBN2=' ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLL=0 ICOLH=0 ICOLX=0 C C ************************************ C ** TREAT THE STATISTIC PLOT CASE ** C ************************************ C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DPSP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 52 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 1-- ** C ** DETERMINE IF OF THIS TYPE ** C ** AND BRANCH ACCORDINGLY. ** C ********************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO9000 C IF(ICOM.EQ.'NUMB'.AND.ICOM2.EQ.'ER ')GOTO201 IF(ICOM.EQ.'COUN'.AND.ICOM2.EQ.'T ')GOTO201 IF(ICOM.EQ.'COUN'.AND.ICOM2.EQ.'TS ')GOTO201 IF(ICOM.EQ.'SIZE'.AND.ICOM2.EQ.' ')GOTO201 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SAMP'.AND.IHARG(1).EQ.'SIZE')GOTO202 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SUBS'.AND.IHARG(1).EQ.'SIZE')GOTO202 C IF(ICOM.EQ.'SUM '.AND.ICOM2.EQ.' ')GOTO211 IF(ICOM.EQ.'PROD'.AND.ICOM2.EQ.'UCT ')GOTO212 IF(ICOM.EQ.'INTE'.AND.ICOM2.EQ.'GRAL')GOTO213 C IF(ICOM.EQ.'MIDR'.AND.ICOM2.EQ.'ANGE')GOTO221 IF(ICOM.EQ.'MEAN'.AND.ICOM2.EQ.' ')GOTO222 CCCCC MARCH 1995. CHECK FOR AVERAGE ABSOLUTE DEVIATION AND AAD IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO413 IF(ICOM.EQ.'AAD '.AND.ICOM2.EQ.' ')GOTO414 C IF(ICOM.EQ.'AVER'.AND.ICOM2.EQ.'AGE ')GOTO222 IF(ICOM.EQ.'MIDM'.AND.ICOM2.EQ.'EAN ')GOTO223 CCCCC MARCH 1995. CHECK FOR MEDIAN ABSOLUTE DEVIATION AND MAD IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN '.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')GOTO415 IF(ICOM.EQ.'MAD '.AND.ICOM2.EQ.' ')GOTO416 C IF(ICOM.EQ.'MEDI'.AND.ICOM2.EQ.'AN ')GOTO224 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1(IHARG(2).NE.'STAN'.AND.IHARG(3).NE.'ERRO'))GOTO225 CCCCC MARCH 1994. RECOGNIZE CORRECT SPELLING. IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'MEAN')GOTO226 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WIND'.AND.IHARG(1).EQ.'MEAN')GOTO226 C IF(ICOM.EQ.'R '.AND.ICOM2.EQ.' ')GOTO241 IF(ICOM.EQ.'RANG'.AND.ICOM2.EQ.'E ')GOTO241 CCCCC JANUARY 1998. CHECK FOR BLOCK PLOT CONFLICT IF(ICOM.EQ.'MINI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MINI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MIN '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO242 ENDIF IF(ICOM.EQ.'MAXI'.AND.ICOM2.EQ.'MUM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF IF(ICOM.EQ.'MAXI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF IF(ICOM.EQ.'MAX '.AND.ICOM2.EQ.' ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO9000 GOTO243 ENDIF C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.'ANCE')GOTO254 CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1994 IF(ICOM.EQ.'VARI'.AND.ICOM2.EQ.' ')GOTO254 C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO251 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO252 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'VAR '.AND.IHARG(1).EQ.'MEAN')GOTO253 IF(ICOM.EQ.'VAR '.AND.ICOM2.EQ.' ')GOTO254 C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'THE '.AND. 1IHARG(4).EQ.'MEAN')GOTO261 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'OF '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1IHARG(2).EQ.'MEAN')GOTO263 C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'THE '.AND.IHARG(3).EQ.'MEAN')GOTO262 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'MEAN')GOTO263 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SD '.AND.IHARG(1).EQ.'MEAN')GOTO266 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI')GOTO264 IF(ICOM.EQ.'SD '.AND.ICOM2.EQ.' ')GOTO265 IF(ICOM.EQ.'S '.AND.ICOM2.EQ.' ')GOTO265 C IF(ICOM.EQ.'RS '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RSD '.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.' ')GOTO271 IF(ICOM.EQ.'RELS'.AND.ICOM2.EQ.'D ')GOTO271 IF(ICOM.EQ.'RV '.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RVAR'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.' ')GOTO272 IF(ICOM.EQ.'RELV'.AND.ICOM2.EQ.'AR ')GOTO272 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'OF '.AND. 1IHARG(2).EQ.'VARI')GOTO273 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'VARI')GOTO274 C CCCCC THE FOLLOWING X LINES WERE ADDED FEBRUARY 1994 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'SD ')GOTO276 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO277 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VAR ')GOTO278 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VARI')GOTO278 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'QUAR')GOTO301 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'QUAR')GOTO302 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'QUAR')GOTO303 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'HING')GOTO304 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'HING')GOTO305 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'THIR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'3RD '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO311 IF(ICOM.EQ.'SKEW'.AND.ICOM2.EQ.'NESS')GOTO312 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'FOUR'.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'4TH '.AND. 1IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')GOTO313 IF(ICOM.EQ.'KURT'.AND.ICOM2.EQ.'OSIS')GOTO314 C CCCCC IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COVA')GOTO321 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COVA'.AND. 1IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')GOTO321 CCCCC IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR')GOTO322 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR'.AND. 1IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')GOTO322 C IF(ICOM.EQ.'COVA'.AND.ICOM2.EQ.'RIAN')GOTO331 IF(ICOM.EQ.'CORR'.AND.ICOM2.EQ.'ELAT')GOTO332 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANK'.AND.IHARG(1).EQ.'COVA')GOTO333 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANK'.AND.IHARG(1).EQ.'CORR')GOTO334 IF(ICOM.EQ.'COMO'.AND.ICOM2.EQ.'VEME')GOTO335 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RANK'.AND.IHARG(1).EQ.'COMO')GOTO336 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'KEND'.AND.IHARG(1).EQ.'TAU ')GOTO337 C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DECI')GOTO111 GOTO119 111 CONTINUE IF(ICOM.EQ.'FIRS')GOTO341 IF(ICOM.EQ.'SECO')GOTO342 IF(ICOM.EQ.'THIR')GOTO343 IF(ICOM.EQ.'FOUR')GOTO344 IF(ICOM.EQ.'FIFT')GOTO345 IF(ICOM.EQ.'SIXT')GOTO346 IF(ICOM.EQ.'SEVE')GOTO347 IF(ICOM.EQ.'EIGH')GOTO348 IF(ICOM.EQ.'NINT')GOTO349 119 CONTINUE C IF(ICOM.EQ.'PERC'.AND.IHARG(1).NE.'BEND'.AND.IHARG(1).NE.'DEFE') 1 GOTO350 C IF(ICOM.EQ.'SN'.AND.IHARG(1).EQ.'SCAL')GOTO493 IF(ICOM.EQ.'QN'.AND.IHARG(1).EQ.'SCAL')GOTO495 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'FREQ')GOTO361 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMP')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SIN'.AND.IHARG(1).EQ.'AMPL')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SINE'.AND.IHARG(1).EQ.'AMPL')GOTO362 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'INTE')GOTO363 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'SLOP')GOTO364 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'RESS')GOTO365 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'CORR')GOTO366 C CCCCC THE FOLLOWING SECTION WAS DRASTICALLY SIMPLIFIED MAY 1989 IF(NUMARG.GE.1.AND.ICOM.EQ.'TAGU')GOTO130 GOTO139 130 CONTINUE IF(IHARG(1).EQ.'SN')GOTO371 IF(IHARG(1).EQ.'S/N')GOTO371 IF(IHARG(1).EQ.'SN0')GOTO371 IF(IHARG(1).EQ.'S/N0')GOTO371 IF(IHARG(1).EQ.'SNT')GOTO371 IF(IHARG(1).EQ.'S/NT')GOTO371 IF(IHARG(1).EQ.'SN+')GOTO372 IF(IHARG(1).EQ.'S/N+')GOTO372 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(IHARG(1).EQ.'SNL')GOTO372 IF(IHARG(1).EQ.'SN-')GOTO373 IF(IHARG(1).EQ.'S/N-')GOTO373 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(IHARG(1).EQ.'SNS')GOTO373 IF(IHARG(1).EQ.'SN00')GOTO374 IF(IHARG(1).EQ.'SNT2')GOTO374 IF(IHARG(1).EQ.'S/N2')GOTO374 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(IHARG(1).EQ.'SN2')GOTO374 139 CONTINUE C CCCCC THE FOLLOWING 12 LINES WERE ADDED MAY 1989 IF(ICOM.EQ.'SN')GOTO381 IF(ICOM.EQ.'S/N')GOTO381 IF(ICOM.EQ.'SN0')GOTO381 IF(ICOM.EQ.'S/N0')GOTO381 IF(ICOM.EQ.'SNT')GOTO381 IF(ICOM.EQ.'S/NT')GOTO381 IF(ICOM.EQ.'SN+')GOTO382 IF(ICOM.EQ.'S/N+')GOTO382 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(ICOM.EQ.'SNL ')GOTO382 IF(ICOM.EQ.'SN-')GOTO383 IF(ICOM.EQ.'S/N-')GOTO383 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(ICOM.EQ.'SNS')GOTO383 IF(ICOM.EQ.'SN00')GOTO384 IF(ICOM.EQ.'SNT2')GOTO384 IF(ICOM.EQ.'S/N2')GOTO384 CCCCC DECEMBER 1993. ADD FOLLOWING LINE IF(ICOM.EQ.'SN2')GOTO384 C CCCCC THE FOLLOWING 6 LINES WERE ADDED SEPTEMBER 1993 IF(ICOM.EQ.'CP')GOTO401 IF(ICOM.EQ.'CPK')GOTO402 IF(ICOM.EQ.'CNPK')GOTO398 IF(ICOM.EQ.'CPM')GOTO400 IF(ICOM.EQ.'CC')GOTO399 IF(ICOM.EQ.'CPL')GOTO396 IF(ICOM.EQ.'CPU')GOTO397 IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'DEFE')GOTO403 IF(ICOM.EQ.'EXPE'.AND.IHARG(1).EQ.'LOSS')GOTO404 ENDIF C CCCCC THE FOLLOWING 3 LINES WERE ADDED FEBRUARY 1994 IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'PPCC')GOTO411 ENDIF C CCCCC THE FOLLOWING 3 LINES WERE ADDED FEBRUARY 1994 IF(NUMARG.GE.1)THEN IF(ICOM.EQ.'EXTR')GOTO412 ENDIF C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'MEAN')GOTO426 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'GEOM'.AND.ICOM2.EQ.'ETRI'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO436 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'HARM'.AND.IHARG(1).EQ.'MEAN')GOTO446 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'INTE'.AND.IHARG(1).EQ.'RANG')GOTO456 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'IQ '.AND.IHARG(1).EQ.'RANG')GOTO456 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'LOCA')GOTO457 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'SCAL')GOTO458 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'VARI')GOTO460 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'SD')GOTO462 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI') 1GOTO464 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'COVA')GOTO466 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'CORR')GOTO468 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDV')GOTO470 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND. 1IHARG(1).EQ.'MIDC'.AND.IHARG2(1).EQ.'ORRE')GOTO473 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDC')GOTO472 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND. 1IHARG(2).EQ.'MIDV')GOTO474 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'HODG'.AND.IHARG(1).EQ.'LEHM')GOTO476 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'QUAN'.AND.IHARG(1).EQ.'PLOT')GOTO478 C IF(NUMARG.GE.3.AND. 1ICOM.EQ.'QUAN'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'ERRO'.AND.IHARG(3).EQ.'PLOT')GOTO480 C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND.IHARG(2).EQ.'STAN'.AND. 1IHARG(3).EQ.'ERRO'.AND.IHARG(4).EQ.'PLOT')GOTO482 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND. 1IHARG(2).EQ.'CORR')GOTO484 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WEIG'.AND.IHARG(1).EQ.'MEAN')GOTO486 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WEIG'.AND.IHARG(1).EQ.'VARI')GOTO488 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'WEIG'.AND.IHARG(1).EQ.'SD')GOTO490 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'WEIG'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO491 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'WEIG'.AND.IHARG(1).EQ.'TRIM'.AND. 1IHARG(2).EQ.'MEAN')GOTO492 C IF(NUMARG.GE.1.AND.ICOM.EQ.'DIFF'.AND.IHARG(1).EQ.'OF')THEN IF(IHARG(2).EQ.'AVER'.AND.IHARG(3).EQ.'ABSO'.AND. 1 IHARG(4).EQ.'DEVI')GOTO623 IF(IHARG(2).EQ.'AAD')GOTO523 IF(IHARG(2).EQ.'MEAN' .OR. IHARG(2).EQ.'AVER')GOTO501 IF(IHARG(2).EQ.'MIDM')GOTO502 IF(IHARG(2).EQ.'MEDI'.AND.IHARG(3).EQ.'ABSO'.AND. 1 IHARG(4).EQ.'DEVI')GOTO624 IF(IHARG(2).EQ.'MAD')GOTO524 IF(IHARG(2).EQ.'MEDI')GOTO503 IF(IHARG(2).EQ.'TRIM'.AND.IHARG(3).EQ.'MEAN')GOTO504 IF(IHARG(2).EQ.'WINS'.AND.IHARG(3).EQ.'MEAN')GOTO505 IF(IHARG(2).EQ.'GEOM'.AND.IHARG(3).EQ.'MEAN')GOTO506 IF(IHARG(2).EQ.'HARM'.AND.IHARG(3).EQ.'MEAN')GOTO507 IF(IHARG(2).EQ.'HODG'.AND.IHARG(3).EQ.'LEHM')GOTO508 IF(IHARG(2).EQ.'BIWE'.AND.IHARG(3).EQ.'LOCA')GOTO509 IF(IHARG(2).EQ.'SD'.AND.IHARG(3).EQ.'OF'.AND. 1 IHARG(4).EQ.'THE'.AND.IHARG(5).EQ.'MEAN')GOTO738 IF(IHARG(2).EQ.'SD'.AND.IHARG(3).EQ.'OF'.AND. 1 IHARG(4).EQ.'MEAN')GOTO638 IF(IHARG(2).EQ.'SD'.AND.IHARG(3).EQ.'MEAN')GOTO538 IF(IHARG(2).EQ.'SD')GOTO520 IF(IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')GOTO521 IF(IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'OF'.AND. 1 IHARG(4).EQ.'THE'.AND.IHARG(5).EQ.'MEAN')GOTO740 IF(IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'OF'.AND. 1 IHARG(4).EQ.'MEAN')GOTO640 IF(IHARG(2).EQ.'VARI'.AND.IHARG(3).EQ.'MEAN')GOTO540 IF(IHARG(2).EQ.'VARI')GOTO522 IF(IHARG(2).EQ.'INTE'.AND.IHARG(3).EQ.'RANG')GOTO525 IF(IHARG(2).EQ.'IQ '.AND.IHARG(3).EQ.'RANG')GOTO525 IF(IHARG(2).EQ.'WINS'.AND.IHARG(3).EQ.'STAN'.AND. 1 IHARG(4).EQ.'DEVI')GOTO626 IF(IHARG(2).EQ.'WINS'.AND.IHARG(3).EQ.'SD')GOTO526 IF(IHARG(2).EQ.'WINS'.AND.IHARG(3).EQ.'VARI')GOTO527 IF(IHARG(2).EQ.'BIWE'.AND.IHARG(3).EQ.'MIDV')GOTO528 IF(IHARG(2).EQ.'BIWE'.AND.IHARG(3).EQ.'SCAL')GOTO529 IF(IHARG(2).EQ.'PERC'.AND.IHARG(3).EQ.'BEND'.AND. 1 IHARG(4).EQ.'MIDV')GOTO530 IF(IHARG(2).EQ.'GEOM'.AND.IHARG(3).EQ.'STAN'.AND. 1 IHARG(4).EQ.'DEVI')GOTO631 IF(IHARG(2).EQ.'GEOM'.AND.IHARG(3).EQ.'SD')GOTO531 IF(IHARG(2).EQ.'RANG')GOTO532 IF(IHARG(2).EQ.'MIDR')GOTO533 IF(IHARG(2).EQ.'QUAN')GOTO534 IF(IHARG(2).EQ.'SKEW')GOTO535 IF(IHARG(2).EQ.'KURT')GOTO536 IF(IHARG(2).EQ.'RELA'.AND.IHARG(3).EQ.'SD')GOTO537 IF(IHARG(2).EQ.'RELA'.AND.IHARG(3).EQ.'VARI')GOTO539 IF(IHARG(2).EQ.'MINI')GOTO541 IF(IHARG(2).EQ.'MAXI')GOTO542 IF(IHARG(2).EQ.'EXTR')GOTO543 IF(IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'OF'.AND. 1 IHARG(4).EQ.'VARI')GOTO554 IF(IHARG(2).EQ.'COEF'.AND.IHARG(3).EQ.'VARI')GOTO544 IF(IHARG(2).EQ.'SN')GOTO545 IF(IHARG(2).EQ.'QN')GOTO546 IF(IHARG(2).EQ.'SUM')GOTO551 IF(IHARG(2).EQ.'SUMS')GOTO551 CCCCC SIZE MAKES NO SENSE IN THIS CONTEXT BECAUSE IT WILL ALWAYS CCCCC RETURN 0 (I.E., GROUP SIZE IS SAME FOR BOTH VARIABLES) CCCCC IF(IHARG(2).EQ.'SIZE')GOTO552 CCCCC IF(IHARG(2).EQ.'NUMB')GOTO552 CCCCC IF(IHARG(2).EQ.'COUN')GOTO552 ENDIF C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'REPE'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO561 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'REPE'.AND.IHARG(1).EQ.'SD ')GOTO562 C C NOTE: NEED TO CHECK FOR CONFLICT WITH REPEAT COMMAND IF(NUMARG.GE.1.AND. 1ICOM.EQ.'REPE'.AND. 1(IHARG(1).EQ.'STAT'.OR.IHARG(1).EQ.'PLOT'))GOTO563 C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'REPR'.AND.IHARG(1).EQ.'STAN'.AND. 1IHARG(2).EQ.'DEVI')GOTO564 C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'REPR'.AND.IHARG(1).EQ.'SD ')GOTO565 C IF(ICOM.EQ.'REPR')GOTO566 C IF(ICOM.EQ.'RATI'.AND.ICOM2.EQ.'O ')GOTO567 C IFOUND='NO' GOTO9000 C C ********************** C ** STEP 2-- ** C ** DEFINE ICASPL. ** C ********************** C 201 CONTINUE ICASPL='NUMB' GOTO701 C 202 CONTINUE ICASPL='NUMB' GOTO702 C 211 CONTINUE ICASPL='SUM' GOTO701 C 212 CONTINUE ICASPL='PROD' GOTO701 C 213 CONTINUE ICASPL='INTE' GOTO701 C 221 CONTINUE ICASPL='MIDR' GOTO701 C 222 CONTINUE ICASPL='MEAN' GOTO701 C 223 CONTINUE ICASPL='MIDM' GOTO701 C 224 CONTINUE ICASPL='MEDI' GOTO701 C 225 CONTINUE ICASPL='TRIM' GOTO702 C 226 CONTINUE ICASPL='WINM' GOTO702 C 241 CONTINUE ICASPL='RANG' GOTO701 C 242 CONTINUE ICASPL='MINI' GOTO701 C 243 CONTINUE ICASPL='MAXI' GOTO701 C 251 CONTINUE ICASPL='VAME' GOTO704 C 252 CONTINUE ICASPL='VAME' GOTO703 C 253 CONTINUE ICASPL='VAME' GOTO702 C 254 CONTINUE ICASPL='VARI' GOTO701 C 261 CONTINUE ICASPL='SDME' GOTO705 C 262 CONTINUE ICASPL='SDME' GOTO704 C 263 CONTINUE ICASPL='SDME' GOTO703 C 264 CONTINUE ICASPL='SD' GOTO702 C 265 CONTINUE ICASPL='SD' GOTO701 C 266 CONTINUE ICASPL='SDME' GOTO702 C 271 CONTINUE ICASPL='RESD' GOTO701 C 272 CONTINUE ICASPL='REVA' GOTO701 C 273 CONTINUE ICASPL='CVAR' GOTO703 C 274 CONTINUE ICASPL='CVAR' GOTO702 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED FEBRUARY 1994 276 CONTINUE ICASPL='RESD' GOTO702 C 277 CONTINUE ICASPL='RESD' GOTO703 C 278 CONTINUE ICASPL='REVA' GOTO702 C 301 CONTINUE ICASPL='LOWQ' GOTO702 C 302 CONTINUE ICASPL='MIDQ' GOTO702 C 303 CONTINUE ICASPL='UPPQ' GOTO702 C 304 CONTINUE ICASPL='LOWH' GOTO702 C 305 CONTINUE ICASPL='UPPH' GOTO702 C 311 CONTINUE ICASPL='SKEW' GOTO704 C 312 CONTINUE ICASPL='SKEW' GOTO701 C 313 CONTINUE ICASPL='KURT' GOTO704 C 314 CONTINUE ICASPL='KURT' GOTO701 C 321 CONTINUE ICASPL='AUCV' GOTO701 C 322 CONTINUE ICASPL='AUCR' GOTO701 C 331 CONTINUE ICASPL='COVA' GOTO701 C 332 CONTINUE ICASPL='CORR' GOTO701 C 333 CONTINUE ICASPL='RACV' GOTO702 C 334 CONTINUE ICASPL='RACR' GOTO702 C 335 CONTINUE ICASPL='COMO' GOTO701 C 336 CONTINUE ICASPL='RACM' GOTO702 C 337 CONTINUE ICASPL='KTAU' GOTO702 C 341 CONTINUE ICASPL='1DEC' GOTO702 C 342 CONTINUE ICASPL='2DEC' GOTO702 C 343 CONTINUE ICASPL='3DEC' GOTO702 C 344 CONTINUE ICASPL='4DEC' GOTO702 C 345 CONTINUE ICASPL='5DEC' GOTO702 C 346 CONTINUE ICASPL='6DEC' GOTO702 C 347 CONTINUE ICASPL='7DEC' GOTO702 C 348 CONTINUE ICASPL='8DEC' GOTO702 C 349 CONTINUE ICASPL='9DEC' GOTO702 C 350 CONTINUE ICASPL='PERC' GOTO701 C 361 CONTINUE ICASPL='SIFR' GOTO702 C 362 CONTINUE ICASPL='SIAM' GOTO702 C 363 CONTINUE ICASPL='LIIN' GOTO702 C 364 CONTINUE ICASPL='LISL' GOTO702 C 365 CONTINUE ICASPL='LIRE' GOTO702 C 366 CONTINUE ICASPL='LICO' GOTO702 C 371 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989 ICASPL='SN0' GOTO702 C 372 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989 ICASPL='SN+' GOTO702 C 373 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989 ICASPL='SN-' GOTO702 C 374 CONTINUE CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989 ICASPL='SN00' GOTO702 C CCCCC THE FOLLOWING SECTIONS (381 TO 384) WERE ADDED MAY 1989 381 CONTINUE ICASPL='SN0' GOTO701 C 382 CONTINUE ICASPL='SN+' GOTO701 C 383 CONTINUE ICASPL='SN-' GOTO701 C 384 CONTINUE ICASPL='SN00' GOTO701 C 396 CONTINUE ICASPL='CPL' GOTO701 C 397 CONTINUE ICASPL='CPU' GOTO701 C 398 CONTINUE ICASPL='CNPK' GOTO701 C 399 CONTINUE ICASPL='CC' GOTO701 C 400 CONTINUE ICASPL='CPM' GOTO701 C CCCCC THE FOLLOWING 4 SECTIONS (401 TO 404) WERE ADDED SEPTEMBER 1993 401 CONTINUE ICASPL='CP' GOTO701 C 402 CONTINUE ICASPL='CPK' GOTO701 C 403 CONTINUE ICASPL='PEDE' GOTO702 C 404 CONTINUE ICASPL='EXLO' GOTO702 C CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED FEBRUARY 1994 411 CONTINUE ICASPL='NOPP' GOTO702 C CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED FEBRUARY 1994 412 CONTINUE ICASPL='EXTR' GOTO701 C 413 CONTINUE ICASPL='AAD ' GOTO703 C 414 CONTINUE ICASPL='AAD ' GOTO701 C 415 CONTINUE ICASPL='MAD ' GOTO703 C 416 CONTINUE ICASPL='MAD ' GOTO701 C 426 CONTINUE ICASPL='GEME' GOTO702 C 436 CONTINUE ICASPL='GESD' GOTO703 C 446 CONTINUE ICASPL='HAME' GOTO702 C 456 CONTINUE ICASPL='IQRA' GOTO702 C 457 CONTINUE ICASPL='BILO' GOTO702 C 458 CONTINUE ICASPL='BISC' GOTO702 C 460 CONTINUE ICASPL='WIVA' GOTO702 C 462 CONTINUE ICASPL='WISD' GOTO702 C 464 CONTINUE ICASPL='WISD' GOTO703 C 466 CONTINUE ICASPL='WICV' GOTO702 C 468 CONTINUE ICASPL='WICR' GOTO702 C 470 CONTINUE ICASPL='BIMV' GOTO702 C 472 CONTINUE ICASPL='BIMC' GOTO702 C 473 CONTINUE ICASPL='BICR' GOTO702 C 474 CONTINUE ICASPL='PBMV' GOTO703 C 476 CONTINUE ICASPL='HLEH' GOTO702 C 478 CONTINUE ICASPL='QUAN' GOTO701 C 480 CONTINUE ICASPL='QUSE' GOTO703 C 482 CONTINUE ICASPL='TMSE' GOTO704 C 484 CONTINUE ICASPL='PBCR' GOTO703 C 486 CONTINUE ICASPL='WEME' GOTO702 C 488 CONTINUE ICASPL='WEVA' GOTO702 C 490 CONTINUE ICASPL='WESD' GOTO702 C 491 CONTINUE ICASPL='WESD' GOTO703 C 492 CONTINUE ICASPL='WETM' GOTO703 C 493 CONTINUE ICASPL='SNSC' GOTO702 C 495 CONTINUE ICASPL='QNSC' GOTO702 C 501 CONTINUE IF(IHARG(3).EQ.'CONF' .AND. 1 (IHARG(4).EQ.'INTE' .OR. IHARG(4).EQ.'LIMI'))THEN IFOUND='NO' GOTO9000 ENDIF ICASPL='DMEA' GOTO703 C 502 CONTINUE ICASPL='DMDM' GOTO703 C 503 CONTINUE ICASPL='DMED' GOTO703 C 504 CONTINUE ICASPL='DTRM' GOTO704 C 505 CONTINUE ICASPL='DWNM' GOTO704 C 506 CONTINUE ICASPL='DGEO' GOTO704 C 507 CONTINUE ICASPL='DHAR' GOTO704 C 508 CONTINUE ICASPL='DHDL' GOTO704 C 509 CONTINUE ICASPL='DBIW' GOTO704 C 520 CONTINUE ICASPL='DSD ' GOTO703 C 521 CONTINUE ICASPL='DSD ' GOTO704 C 522 CONTINUE ICASPL='DVAR' GOTO703 C 623 CONTINUE ICASPL='DAAD' GOTO705 C 523 CONTINUE ICASPL='DAAD' GOTO703 C 624 CONTINUE ICASPL='MAAD' GOTO705 C 524 CONTINUE ICASPL='DMAD' GOTO703 C 525 CONTINUE ICASPL='DIQR' GOTO704 C 626 CONTINUE ICASPL='DWSD' GOTO705 C 526 CONTINUE ICASPL='DWSD' GOTO704 C 527 CONTINUE ICASPL='DWVA' GOTO704 C 528 CONTINUE ICASPL='DBIM' GOTO704 C 529 CONTINUE ICASPL='DBIS' GOTO704 C 530 CONTINUE ICASPL='DPBN' GOTO705 C 631 CONTINUE ICASPL='DGSD' GOTO705 C 531 CONTINUE ICASPL='DGSD' GOTO704 C 532 CONTINUE ICASPL='DRAN' GOTO703 C 533 CONTINUE ICASPL='DMDR' GOTO703 C 534 CONTINUE ICASPL='DQUA' GOTO703 C 535 CONTINUE ICASPL='DSKE' GOTO703 C 536 CONTINUE ICASPL='DKUR' GOTO703 C 537 CONTINUE ICASPL='DRSD' GOTO704 C 738 CONTINUE ICASPL='DSDM' GOTO706 C 638 CONTINUE ICASPL='DSDM' GOTO705 C 538 CONTINUE ICASPL='DSDM' GOTO704 C 539 CONTINUE ICASPL='DRVA' GOTO704 C 740 CONTINUE ICASPL='DVAM' GOTO706 C 640 CONTINUE ICASPL='DVAM' GOTO705 C 540 CONTINUE ICASPL='DVAM' GOTO704 C 541 CONTINUE ICASPL='DMIN' GOTO703 C 542 CONTINUE ICASPL='DMAX' GOTO703 C 543 CONTINUE ICASPL='DEXT' GOTO703 C 554 CONTINUE ICASPL='DCVA' GOTO705 C 544 CONTINUE ICASPL='DCVA' GOTO704 C 545 CONTINUE ICASPL='DSN' GOTO703 C 546 CONTINUE ICASPL='DQN' GOTO703 C 551 CONTINUE ICASPL='DSUM' GOTO703 C 552 CONTINUE ICASPL='DCOU' GOTO703 C 561 CONTINUE ICASPL='REPE' GOTO703 C 562 CONTINUE ICASPL='REPE' GOTO702 C 563 CONTINUE ICASPL='REPE' GOTO701 C 564 CONTINUE ICASPL='REPR' GOTO703 C 565 CONTINUE ICASPL='REPR' GOTO702 C 566 CONTINUE ICASPL='REPR' GOTO701 C 567 CONTINUE ICASPL='RATI' GOTO701 C C ***************************************************** C ** STEP 2-- ** C ** DETERMINE THE LOCATION (IN IHARG(.)) ** C ** OF THE WORD PLOT ** C ** PLACE IT IN ILASTC ** C ***************************************************** C 701 CONTINUE IF(NUMARG.LT.1)GOTO780 IF(IHARG(1).EQ.'PLOT')GOTO801 IF(NUMARG.LT.2)GOTO780 IF(IHARG(1).EQ.'STAT'.AND.IHARG(2).EQ.'PLOT')GOTO802 GOTO780 C 702 CONTINUE IF(NUMARG.LT.2)GOTO780 IF(IHARG(2).EQ.'PLOT')GOTO802 IF(NUMARG.LT.3)GOTO780 IF(IHARG(2).EQ.'STAT'.AND.IHARG(3).EQ.'PLOT')GOTO803 GOTO780 C 703 CONTINUE IF(NUMARG.LT.3)GOTO780 IF(IHARG(3).EQ.'PLOT')GOTO803 IF(NUMARG.LT.4)GOTO780 IF(IHARG(3).EQ.'STAT'.AND.IHARG(4).EQ.'PLOT')GOTO804 GOTO780 C 704 CONTINUE IF(NUMARG.LT.4)GOTO780 IF(IHARG(4).EQ.'PLOT')GOTO804 IF(NUMARG.LT.5)GOTO780 IF(IHARG(4).EQ.'STAT'.AND.IHARG(5).EQ.'PLOT')GOTO805 GOTO780 C 705 CONTINUE IF(NUMARG.LT.5)GOTO780 IF(IHARG(5).EQ.'PLOT')GOTO805 IF(NUMARG.LT.6)GOTO780 IF(IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'PLOT')GOTO806 GOTO780 C 706 CONTINUE IF(NUMARG.LT.6)GOTO780 IF(IHARG(6).EQ.'PLOT')GOTO806 IF(NUMARG.LT.7)GOTO780 IF(IHARG(6).EQ.'STAT'.AND.IHARG(7).EQ.'PLOT')GOTO807 GOTO780 C 707 CONTINUE IF(NUMARG.LT.7)GOTO780 IF(IHARG(7).EQ.'PLOT')GOTO807 IF(NUMARG.LT.8)GOTO780 IF(IHARG(7).EQ.'STAT'.AND.IHARG(8).EQ.'PLOT')GOTO808 GOTO780 C 780 CONTINUE IFOUND='NO' ICASPL='UNKN' GOTO9000 C 801 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 802 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 803 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 804 CONTINUE ILASTC=4 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 805 CONTINUE ILASTC=5 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 806 CONTINUE ILASTC=6 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 807 CONTINUE ILASTC=7 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 808 CONTINUE ILASTC=8 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO890 C 890 CONTINUE IFOUND='YES' C C *********************************************************** C ** STEP 21-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1WRITE(ICOUT,2211)IHLEFT,ICOLL,NLEFT 2211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 23-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='23' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO2390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** ERROR IN DPSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT(' (FOR WHICH A ... STATISTIC PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315)MINN2 2315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2317) 2317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2318)(IANS(I),I=1,IWIDTH) 2318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2390 CONTINUE C C ***************************************** C ** STEP 24-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='24' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO2480 DO2400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO2410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO2410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO2420 2400 CONTINUE GOTO2490 2410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO2490 2420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO2490 C 2480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2481) 2481 FORMAT('***** INTERNAL ERROR IN DPSP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2482) 2482 FORMAT(' AT BRANCH POINT 2481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2483) 2483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2484) 2484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2485)NUMARG 2485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2486) 2486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2487)(IANS(I),I=1,IWIDTH) 2487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2490 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DPSP')GOTO2495 WRITE(ICOUT,2491)NUMARG,ILOCQ,ICASEQ 2491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 2495 CONTINUE C C ***************************************** C ** STEP 24.5-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ***************************************** C ISTEPN='24.5' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 C C ************************************************************ C ** STEP 25-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE TO BE GROUPED ** C ** BASED ON VALUES OF THE SECOND VARIABLE; ** C ** THAT IS, THE SECOND VARAIBLE DEFINES THE ** C ** GROUP NUMBERS WITHIN WHICH THE MEANS, ** C ** STANDARD DEVIATIONS, RANGES, AND ** C ** CUMULATIVE SUMS ARE TO BE COMPUTED. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE X VALUES FOR EACH MEAN, STANDARD DEVIATION, ** C ** ETC. IN THE RESULTING STATISTIC PLOT. ** C ** THE VALUES IN THE SECOND VARIABLE ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ************************************************************ C ISTEPN='25' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO2590 IF(NUMV2.EQ.2)GOTO2530 IF(NUMV2.EQ.3)GOTO2540 GOTO2510 C 2510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2511) 2511 FORMAT('***** ERROR IN DPSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2512) 2512 FORMAT(' FOR A ... STATISTIC PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2518) 2518 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2519) 2519 FORMAT(' MUST BE EITHER 1, 2, OR 3 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2520) 2520 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2521) 2521 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2522)NUMV2 2522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2523) 2523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2524)(IANS(I),I=1,IWIDTH) 2524 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2530 CONTINUE IHHOR=IHARG(2) IHHOR2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1WRITE(ICOUT,2531)IHHOR,ICOLH,NHOR 2531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL DPWRST('XXX','BUG ') GOTO2570 C 2540 CONTINUE IHX=IHARG(2) IHX2=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHX,IHX2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLX=IVALUE(ILOCV) NX=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1WRITE(ICOUT,2541)IHX,ICOLX,NX 2541 FORMAT('IHX,ICOLX,NX = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL DPWRST('XXX','BUG ') C IHHOR=IHARG(3) IHHOR2=IHARG2(3) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCV) NHOR=IN(ILOCV) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1WRITE(ICOUT,2542)IHHOR,ICOLH,NHOR 2542 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL DPWRST('XXX','BUG ') GOTO2570 C 2570 CONTINUE IF(NUMV2.EQ.2.AND.NHOR.EQ.NLEFT)GOTO2590 IF(NUMV2.EQ.3.AND.NX.EQ.NLEFT.AND.NHOR.EQ.NLEFT)GOTO2590 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2571) 2571 FORMAT('***** ERROR IN DPSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2572) 2572 FORMAT(' FOR A ... STATISTIC PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2578)NUMV2 2578 FORMAT(' WHEN HAVE ',I8,' VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2579) 2579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2580)NUMV2 2580 FORMAT(' IN THE ',I8,' VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2581) 2581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2582) 2582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2583)IHLEFT,NLEFT 2583 FORMAT(' VARIABLE 1 ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.2)WRITE(ICOUT,2584)IHHOR,NHOR 2584 FORMAT(' VARIABLE 2 ',A4,' HAS ',I8,' ELEMENTS') IF(NUMV2.EQ.2)CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.3)WRITE(ICOUT,2585)IHX,NX 2585 FORMAT(' VARIABLE 2 ',A4,' HAS ',I8,' ELEMENTS') IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') IF(NUMV2.EQ.3)WRITE(ICOUT,2586)IHHOR,NHOR 2586 FORMAT(' VARIABLE 3 ',A4,' HAS ',I8,' ELEMENTS') IF(NUMV2.EQ.3)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2587) 2587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2588)(IANS(I),I=1,IWIDTH) 2588 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2590 CONTINUE C C ************************************************* C ** STEP 26-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE SECOND VARIABLE (IF EXISTENT) ** C ************************************************* C ISTEPN='26' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2610 IF(ICASEQ.EQ.'SUBS')GOTO2620 IF(ICASEQ.EQ.'FOR')GOTO2630 C 2610 CONTINUE DO2615I=1,NLEFT ISUB(I)=1 2615 CONTINUE NQ=NLEFT GOTO2650 C 2620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2650 C 2630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2650 C 2650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO2660I=1,IMAX IF(ISUB(I).EQ.0)GOTO2660 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) IF(NUMV2.LE.1)GOTO2660 C IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLH.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)X1(J)=TAGPLO(I) IF(NUMV2.LE.2)GOTO2660 C IJ=MAXN*(ICOLX-1)+I IF(ICOLX.LE.MAXCOL)Z1(J)=V(IJ) IF(ICOLX.EQ.MAXCP1)Z1(J)=PRED(I) IF(ICOLX.EQ.MAXCP2)Z1(J)=RES(I) IF(ICOLX.EQ.MAXCP3)Z1(J)=YPLOT(I) IF(ICOLX.EQ.MAXCP4)Z1(J)=XPLOT(I) IF(ICOLX.EQ.MAXCP5)Z1(J)=X2PLOT(I) IF(ICOLX.EQ.MAXCP6)Z1(J)=TAGPLO(I) GOTO2660 C 2660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 27-- ** C ** FOR THE 1-VARIABLE CASE ONLY, * C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE STATISTIC PLOT ANALYSIS. * C ** THE GROUP SIZE SETTING IS DEFINED BY SEARCHING THE ** C ** INTERNAL TABLE FOR THE PARAMETER NAME NI ; ** C ** IF FOUND, USE THE SPECIFIED VALUE. ** C ** IF NOT FOUND, GENERATE AN ERROR MESSAGE. ** C **************************************************************** C ISTEPN='27' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.GE.2)GOTO2790 C IH='NI ' IH2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) IERROR=IERRO2 IF(IERRO2.EQ.'YES')GOTO9000 ISIZE=VALUE(ILOCP)+0.5 2790 CONTINUE C C ************************************************************* C ** STEP 28-- ** C ** COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC-- ** C ** (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM). ** C ** COMPUTE CONFIDENCE LINES. ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='28' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSP2(Y1,Z1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT, CCCCC JULY 2002. ADD FOLLOWING LINE FOR HODGES-LEHMAN 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR) C C C ************************************************* C ** STEP 29-- ** C ** SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND ** C ** LOWEST VALUE OF STATISTIC IN INTERNAL ** C ** PARAMETER ALOWHIGH ** C ************************************************* AMINS=CPUMAX AMAXS=CPUMIN DO2910I=1,NPLOTP IF(D(I).NE.1.0)GOTO2910 IF(Y(I).GT.AMAXS)THEN AMAXS=Y(I) IMAXIN=I ENDIF IF(Y(I).LT.AMINS)THEN AMINS=Y(I) IMININ=I ENDIF 2910 CONTINUE ADIFF=AMAXS-AMINS IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF C ISUBN0='DPSP' C IH='ALOW' IH2='HIGH' VALUE0=ADIFF CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DPSP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ 9012 FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ISIZE 9015 FORMAT('ISIZE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMV2 9016 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.2)WRITE(ICOUT,9018)IHHOR,IHHOR2,ICOLH,NHOR 9018 FORMAT('IHHOR,IHHOR2,ICOLH,NHOR = ',A4,2X,A4,I8,I8) IF(NUMV2.GE.2)CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.3)WRITE(ICOUT,9019)IHX,IHX2,ICOLX,NX 9019 FORMAT('IHX,IHX2,ICOLX,NX = ',A4,2X,A4,I8,I8) IF(NUMV2.GE.3)CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1992 CCCCC IF(NPLOTP.LE.0)GOTO9090 IF(IFOUND.EQ.'NO'.OR.NPLOTP.LE.0)GOTO9090 DO9025I=1,NPLOTP WRITE(ICOUT,9026)I,Y(I),X(I),D(I) 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSP2(Y,Z,X,N,NUMV2,ICASPL,ISIZE,ICONT, 1TEMP,TEMPZ,XIDTEM,XTEMP1,XTEMP2,XTEMP3,MAXNXT, CCCCC JULY 2002. ADD FOLLOWING LINE FOR HODGES-LEHMAN 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A PLOT C OF THE FOLLOWING TYPES-- C MEAN STATISTIC PLOT C MIDM STATISTIC PLOT C MEDI STATISTIC PLOT C SD STATISTIC PLOT C REL SD STATISTIC PLOT C SD MEAN STATISTIC PLOT C VARI STATISTIC PLOT C REL VARI STATISTIC PLOT C VARI MEAN STATISTIC PLOT C RANG STATISTIC PLOT C MINI STATISTIC PLOT C MAXI STATISTIC PLOT C EXTREME STATISTIC PLOT C SKEW STATISTIC PLOT C KURT STATISTIC PLOT C AUCR STATISTIC PLOT C SDM STATISTIC PLOT C AUCV STATISTIC PLOT C RACV STATISTIC PLOT C LOWH STATISTIC PLOT C UPPH STATISTIC PLOT C LOWQ STATISTIC PLOT C UPPQ STATISTIC PLOT C TRIM STATISTIC PLOT C WINM STATISTIC PLOT C MIDQ STATISTIC PLOT C 1DEC STATISTIC PLOT C 2DEC STATISTIC PLOT C 3DEC STATISTIC PLOT C 4DEC STATISTIC PLOT C 5DEC STATISTIC PLOT C 6DEC STATISTIC PLOT C 7DEC STATISTIC PLOT C 8DEC STATISTIC PLOT C 9DEC STATISTIC PLOT C SIN FREQUENCY STATISTIC PLOT C SIN AMPLITUDE STATISTIC PLOT C LINEAR INTERCEPT STATISTIC PLOT C LINEAR SLOPE STATISTIC PLOT C LINEAR RESSD STATISTIC PLOT C LINEAR CORRELATION STATISTIC PLOT C TAGUCHI SIGNAL-TO-NOISE PLOTS C CP PLOT C CPK PLOT C CNPK PLOT C CPM PLOT C CC PLOT C PERCENT DEFECTIVE PLOT C EXPECTED LOSS PLOT C NORM PPCC STATISTIC PLOT C AAD PLOT C MAD PLOT C PERCENTILE PLOT C GEOMETRIC MEAN PLOT C GEOMETRIC STANDARD DEVIATION PLOT C BIWEIGHT LOCATION PLOT C BIWEIGHT SCALE PLOT C WINSORIZED VARIANCE PLOT C WINSORIZED SD PLOT C WINSORIZED COVARIANCE PLOT C WINSORIZED CORRELATION PLOT C BIWEIGHT MIDVARIANCE PLOT C BIWEIGHT MIDCOVARIANCE PLOT C PERCENTAGE BEND MIDVARIANCE PLOT C HODGES-LEHMAN PLOT C SN PLOT C QN PLOT C KENDELL TAU PLOT C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1988. C UPDATED --MARCH 1988. LINEAR INTERCEPT & SLOPE PLOTS C UPDATED --MARCH 1988. LINEAR RESSD & CORRELATION PLOTS C UPDATED --AUGUST 1988. TAGUCHI SIGNAL TO NOISE PLOTS C UPDATED --SEPTEMBER 1988. 4 MISSING CHARACTER*4 STATEMENTS C UPDATED --MAY 1989. CHANGE TAGUCHI S/N DESIGNATIONS C UPDATED --SEPTEMBER 1993. CP PLOT C UPDATED --SEPTEMBER 1993. CPK PLOT C UPDATED --SEPTEMBER 1993. PERCENT DEFECTIVE PLOT C UPDATED --SEPTEMBER 1993. EXPECTED LOSS PLOT C UPDATED --DECEMBER 1993. LINFIT ARGS C UPDATED --DECEMBER 1993. LINFIT ARGS; PROTECT RESSD/DF C UPDATED --FEBRUARY 1994. IFLAG='ACTU' C UPDATED --FEBRUARY 1994. CHANGE ICASPL: SDM => SDME C UPDATED --FEBRUARY 1994. CHANGE ICASPL: VM => VAME C UPDATED --FEBRUARY 1994. CHANGE ICASPL: RSD => RESD C UPDATED --FEBRUARY 1994. CHANGE ICASPL: RVAR => REVA C UPDATED --FEBRUARY 1994. ALLOW SD MEAN C UPDATED --FEBRUARY 1994. ADD VARI OF MEAN C UPDATED --FEBRUARY 1994. ADD VARI OF MEAN C UPDATED --FEBRUARY 1994. ADD NORMAL PPCC C UPDATED --NOVEMBER 1998. ADD PERCENTILE C UPDATED --NOVEMBER 1998. ADD CPM, CC C UPDATED --MARCH 1999. ADD CNPK C UPDATED --MARCH 1999. ADD GEOMETRIC MEAN C UPDATED --MARCH 1999. ADD GEOMETRIC STANDARD DEVIATION C UPDATED --APRIL 2001. ARGUMENT LIST TO CP, CPK, CPM C UPDATED --SEPTEMBER 2001. ADD IQ RANGE C UPDATED --NOVEMBER 2001. ADD BIWEIGHT LOCATION C UPDATED --NOVEMBER 2001. ADD BIWEIGHT SCALE C UPDATED --JULY 2002. ADD WINSORIZED VARIANCE C UPDATED --JULY 2002. ADD WINSORIZED SD C UPDATED --JULY 2002. ADD WINSORIZED COVARIANCE PLOT C UPDATED --JULY 2002. ADD WINSORIZED CORRELATION PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCOVARIANCE PLOT C UPDATED --JULY 2002. ADD BIWEIGHT MIDCORRELATION PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND MIDVARIANCE C PLOT C UPDATED --JULY 2002. ADD PERCENTAGE BEND CoRRELATION C PLOT C UPDATED --JULY 2002. ADD HODGES LEHMAN PLOT C UPDATED --AUGUST 2002. USE "CMPSTA" TO COMPUTE THE C STATISTIC C UPDATED --APRIL 2003. ADD SN AND QN (AND DIFFERENCE C OF), REQUIRED ADDITIONAL C SCRATCH ARRAY C UPDATED --OCTOBER 2004. ADD KENDELL TAU C UPDATED --FEBRUARY 2005. ADD REPEATABILITY SD C UPDATED --FEBRUARY 2005. ADD REPRODUCABILITY SD C UPDATED --SEPTEMBER 2005. ADD RATIO C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 ISUBRO CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 IQUAME CHARACTER*4 IQUASE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION Z(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION TEMP(*) DIMENSION TEMPZ(*) DIMENSION XIDTEM(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) C INTEGER ITEMP1(*) INTEGER ITEMP2(*) INTEGER ITEMP3(*) INTEGER ITEMP4(*) INTEGER ITEMP5(*) INTEGER ITEMP6(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSP' ISUBN2='2 ' C IWRITE='OFF' C I2=0 ISIZE2=0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPSP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C CCCCC IF(N.GE.2)GOTO49 CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46) CCC46 FORMAT('***** ERROR IN DPSP2--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,47) CCC47 FORMAT(' THE NUMBER OF OBSERVATIONS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,48) CCC48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 CCC49 CONTINUE C CCCCC HOLD=Y(1) CCCCC DO60I=1,N CCCCC IF(Y(I).NE.HOLD)GOTO69 CCC60 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,61) CCC61 FORMAT('***** ERROR IN DPSP2--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,62) CCC62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,63)HOLD CCC63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 CCC69 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PSP2')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPSP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IBUGG3,ISUBRO 71 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,ICASPL,NUMV2,ISIZE,ICONT 72 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO73I=1,N IF(NUMV2.LE.2)WRITE(ICOUT,74)I,Y(I),X(I) 74 FORMAT('I, Y(I),X(I) = ',I8,2F15.7) IF(NUMV2.LE.2)CALL DPWRST('XXX','BUG ') IF(NUMV2.GE.3)WRITE(ICOUT,75)I,Y(I),Z(I),X(I) 75 FORMAT('I, Y(I),Z(I),X(I) = ',I8,3F15.7) IF(NUMV2.GE.3)CALL DPWRST('XXX','BUG ') 73 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR THE GROUP VARIABLE (USUALLY VAR. 2) ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A PLOT. ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.1)GOTO110 IF(NUMV2.EQ.2)GOTO150 IF(NUMV2.EQ.3)GOTO150 C 110 CONTINUE NUMSET=0 DO120I=ISIZE,N,ISIZE I2=I NUMSET=NUMSET+1 XIDTEM(NUMSET)=NUMSET 120 CONTINUE IF(I2.LT.N)GOTO130 GOTO140 130 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=NUMSET 140 CONTINUE DO145I=1,N IGROUP=1+((I-1)/ISIZE) IMID=(IGROUP-1)*ISIZE+(ISIZE/2) X(I)=IMID 145 CONTINUE GOTO190 C 150 CONTINUE NUMSET=0 DO151I=1,N IF(NUMSET.EQ.0)GOTO153 DO152J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO151 152 CONTINUE 153 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 151 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C 190 CONTINUE C IF(NUMSET.GE.1)GOTO194 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,191) 191 FORMAT('***** ERROR IN DPSP2 SUBROUTINE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF SETS NUMSET = 0 ') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 194 CONTINUE C CCCC JANUARY 2005. IF NUMBER OF SETS EQUAL NUMBER OF OBSERVATIONS CCCCC (I.E., ALL GROUPS HAVE 1 OBSERVATION), TREAT AS CCCCC A WARNING RATHER THAN AN ERROR. NOTE THAT SOME CCCCC STATISTICS MAY SUBSEQUENTLY GENERATE AN ERROR CCCCC MESSAGE FOR EACH GROUP. C IF(NUMSET.NE.N)GOTO199 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,195) 195 FORMAT('***** WARNING IN DPSP2 SUBROUTINE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,196)NUMSET 196 FORMAT(' THE NUMBER OF SETS ',I8,' IS IDENTICAL TO ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,197)N 197 FORMAT(' THE NUMBER OF OBSERVATIONS ',I8,'.') CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 199 CONTINUE C AN=N ANUMSE=NUMSET C C ****************************************** C ** STEP 11-- ** C ** COMPUTE THE SPECIFIED STATISTIC ** C ** FOR EACH SUBSET OF THE DATA, AND ** C ** THEN FOR THE FULL DATA SET ** C ****************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 ISETMX=NUMSET+1 DO11000ISET=1,ISETMX C IF(ISET.LE.NUMSET)GOTO11010 GOTO11020 C 11010 CONTINUE K=0 DO11011I=1,N IF(X(I).NE.XIDTEM(ISET))GOTO11011 K=K+1 TEMP(K)=Y(I) TEMPZ(K)=Z(I) CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') CCCCC1WRITE(ICOUT,11012)NUMSET,ISET,J,XIDTEM(ISET) 11012 FORMAT('NUMSET,ISET,J,XIDTEM(ISET) = ',3I6,E12.4) CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') CCCCC1CALL DPWRST('XXX','BUG ') CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') CCCCC1WRITE(ICOUT,11013)N,I,K,X(I),Y(I),Z(I),TEMP(K),TEMPZ(K) 11013 FORMAT('N,I,K,X(I),Y(I),Z(I),TEMP(K),TEMPZ(K) = ',3I6,5E12.4) CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2') CCCCC1CALL DPWRST('XXX','BUG ') 11011 CONTINUE NI=K NS2=NI GOTO11080 C CCCCC FEBRUARY 2005: FOR REPEATABILITY SD AND REPRODUCABILITY SD, CCCCC OMIT FULL SAMPLE COMPUTATION (SINCE FULL SAMPLE CCCCC STATISTIC IS NOT MEANINGFUL AND DISTORTS THE CCCCC PLOT) C 11020 CONTINUE IF(ICASPL.EQ.'REPE' .OR. ICASPL.EQ.'REPR')GOTO11000 DO11021I=1,N TEMP(I)=Y(I) TEMPZ(I)=Z(I) 11021 CONTINUE NS2=N GOTO11080 C 11080 CONTINUE IF(NS2.GE.1)GOTO11090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11081) 11081 FORMAT('***** INTERNAL ERROR IN DPSP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11082) 11082 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11083)ISET,XIDTEM(ISET),NI 11083 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 11090 CONTINUE C CCCCC AUGUST 2002: USE SUBROUTINE TO COMPUTE THE STATISTIC RATHER CCCCC THAN CODING HERE. C CALL CMPSTA( 1TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3,MAXNXT,NS2,NS2,NUMV2,ICASPL, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IQUAME,IQUASE, 1RIGHT, 1ISUBRO,IBUGG3,IERROR) C C --------------------------- C 79000 CONTINUE IF(ISET.LE.NUMSET)GOTO79001 GOTO79002 79001 CONTINUE J=J+1 Y2(J)=RIGHT X2(J)=XIDTEM(ISET) D2(J)=1.0 GOTO79009 79002 CONTINUE J=J+1 Y2(J)=RIGHT X2(J)=XIDTEM(1) D2(J)=2.0 J=J+1 Y2(J)=RIGHT X2(J)=XIDTEM(NUMSET) D2(J)=2.0 GOTO79009 79009 CONTINUE C 11000 CONTINUE N2=J NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'PSP2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3,ISUBRO 9012 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR 9013 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMV2,ISIZE 9014 FORMAT('NUMV2,ISIZE = ',2I8) CALL DPWRST('XXX','BUG ') DO9020I=1,N2 WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I) 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPAC(IHARG,NUMARG, 1IDEFSP, 1ITEXSP, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPACING TYPE (FIXED OR PROPORTIONAL) FOR C TITLE, LABEL, AND LEGEND SCRIPT C ON A PLOT. C THE SPACING FOR THE SCRIPT WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXSP. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSP C --IBUGD2 C OUTPUT ARGUMENTS--ITEXSP C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --APRIL 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFSP CHARACTER*4 ITEXSP CHARACTER*4 IBUGD2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFSP 53 FORMAT('IDEFSP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I) 56 FORMAT('I,IHARG(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *************************** C ** TREAT THE SPACING CASE ** C *************************** C 1110 CONTINUE IF(NUMARG.LE.0)GOTO1120 IF(IHARG(NUMARG).EQ.'ON')GOTO1120 IF(IHARG(NUMARG).EQ.'OFF')GOTO1120 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120 GOTO1140 C 1120 CONTINUE ITEXSP=IDEFSP GOTO1180 C 1140 CONTINUE IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'EQUA')GOTO1141 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FIXE')GOTO1141 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'PROP')GOTO1142 C 1130 CONTINUE IERROR='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPSPAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ILLEGAL ENTRY FOR SPACING ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133) 1133 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1134) 1134 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1135) 1135 FORMAT(' TO SET THE SPACING TO PROPORTIONAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' FOR PLOT TITLES, LABELS, ETC.,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' THEN 2 ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138) 1138 FORMAT(' SPACING PROPORTIONAL ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1139) 1139 FORMAT(' SPACING PROP ') CALL DPWRST('XXX','BUG ') GOTO9000 C 1141 CONTINUE ITEXSP='FIXE' GOTO1180 C 1142 CONTINUE ITEXSP='PROP' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE SPACING (FIXED OR PROPORTIONAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT('FOR PLOT SCRIPT AND TEXT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183)ITEXSP 1183 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFSP,ITEXSP 9013 FORMAT('IDEFSP,ITEXSP = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPBA(IHARG,IARGT,ARG,NUMARG,ADEFSB,MAXSPI,ASPIBA, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE BASES. C THESE ARE LOCATED IN THE VECTOR ASPIBA(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --ADEFSB C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ASPIBA (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION ASPIBA(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='BA ' C NUMSPI=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)ADEFSB 55 FORMAT('ADEFSB = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ASPIBA(1) 70 FORMAT('ASPIBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ASPIBA(I) 76 FORMAT('I,ASPIBA(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=ADEFSB IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ASPIBA(1)=ADEFSB GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG-1 IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEFSB IF(IHOLD1.EQ.'OFF')HOLD2=ADEFSB IF(IHOLD1.EQ.'AUTO')HOLD2=ADEFSB IF(IHOLD1.EQ.'DEFA')HOLD2=ADEFSB ASPIBA(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ASPIBA(I) 1276 FORMAT('SPIKE BASE ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEFSB IF(IHOLD1.EQ.'OFF')HOLD2=ADEFSB IF(IHOLD1.EQ.'AUTO')HOLD2=ADEFSB IF(IHOLD1.EQ.'DEFA')HOLD2=ADEFSB DO1315I=1,NUMSPI ASPIBA(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ASPIBA(I) 1316 FORMAT('ALL SPIKE BASES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPBA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ADEFSB 9015 FORMAT('ADEFSB = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ASPIBA(1) 9030 FORMAT('ASPIBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ASPIBA(I) 9036 FORMAT('I,ASPIBA(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPCO(IHARG,NUMARG,IDEFSC,MAXSPI,ISPICO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE COLORS. C THESE ARE LOCATED IN THE VECTOR ISPICO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSC C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISPICO (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFSC CHARACTER*4 ISPICO C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION ISPICO(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='CO ' C NUMSPI=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPCO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSC 55 FORMAT('IDEFSC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISPICO(1) 70 FORMAT('ISPICO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISPICO(I) 76 FORMAT('I,ISPICO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IDEFSC IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ISPICO(1)=IDEFSC GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG-1 IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFSC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFSC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSC ISPICO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ISPICO(I) 1276 FORMAT('SPIKE COLOR ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFSC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFSC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSC DO1315I=1,NUMSPI ISPICO(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISPICO(I) 1316 FORMAT('ALL SPIKE COLORS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPCO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSC 9015 FORMAT('IDEFSC = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISPICO(1) 9030 FORMAT('ISPICO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISPICO(I) 9036 FORMAT('I,ISPICO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPDI(IHARG,NUMARG,IDEFSD,MAXSPI,ISPIDI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE DIRECTION-- C VERT = VERTICAL C HORI = HORIZONTAL C HOR2 = HORIZONTAL TOWARD X2-X3 PLANE (FOR 3D PLOTS) C THESE ARE LOCATED IN THE VECTOR ISPIDI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSD C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISPIDI (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/5 C ORIGINAL VERSION--MAY 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFSD CHARACTER*4 ISPIDI C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION ISPIDI(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='DI ' C NUMSPI=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPDI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSD 55 FORMAT('IDEFSD = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISPIDI(1) 70 FORMAT('ISPIDI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISPIDI(I) 76 FORMAT('I,ISPIDI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1='VERT' IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE SINGLE SPECIFICATION CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ISPIDI(1)='VERT' GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG-1 IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 C???? IF(IHOLD1.EQ.'VERT')IHOLD2='VERT' C???? IF(IHOLD1.EQ.'3')IHOLD2='3' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSD CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSD ISPIDI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ISPIDI(I) 1276 FORMAT('SPIKE DIRECTION ',I6, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 3-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI IHOLD2=IHOLD1 C???? IF(IHOLD1.EQ.'2')IHOLD2='2' C???? IF(IHOLD1.EQ.'3')IHOLD2='3' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSD CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSD DO1315I=1,NUMSPI ISPIDI(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISPIDI(I) 1316 FORMAT('ALL SPIKE DIRECTIONS', 1'HAVE JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPDI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSD 9015 FORMAT('IDEFSD = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISPIDI(1) 9030 FORMAT('ISPIDI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISPIDI(I) 9036 FORMAT('I,ISPIDI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPE2(Y1,Y2,N,ICASPL,NUMLAG,MAXN, 1COV11,COV22,COV12,COV21, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) AUTOSPECTRUM C 2) CO-SPECTRUM; C 3) QUADRATURE SPECTRUM; C 4) CROSS-SPECTRUM (CO-SPECTRUM AND CROSS-SPECTRUM); C 5) COHERENCY DIAGRAM; C 6) AMPLITUDE DIAGRAM; C 7) PHASE DIAGRAM; C 8) GAIN DIAGRAM; C 9) ARGAND DIAGRAM. C NOTE--AN AUTOSPECTRAL PLOT, C IN ORDER THAT THE RESULTS OF THE TIME SERIES ANALYSIS C BE VALID AND PROPERLY INTERPRETED, THE INPUT DATA C IN X SHOULD BE EQUI-SPACED IN TIME C (OR WHATEVER VARIABLE CORRESPONDS TO TIME). C C THE HORIZONTAL AXIS OF THE SPECTRA PRODUCED C BY THIS SUBROUTINE IS FREQUENCY. C THIS FREQUENCY IS MEASURED IN UNITS OF C CYCLES PER 'DATA POINT' OR, MORE PRECISELY, IN C CYCLES PER UNIT TIME WHERE C 'UNIT TIME' IS DEFINED AS THE C ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS. C THE RANGE OF THE FREQUENCY AXIS IS 0.0 TO 0.5. C C INPUT ARGUMENTS--Y1 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS C FOR THE FIRST VARIABLE. C --Y2 = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C FOR THE SECOND VARIABLE. C N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C PRINTING--YES. C RESTRICTIONS--THE SAMPLE SIZE N MUST BE C SMALLER THAN OR EQUAL TO 1000. C --THE SAMPLE SIZE N MUST BE GREATER C THAN OR EQUAL TO 3. C OTHER DATAPAC SUBROUTINES NEEDED--PLOTC0, PLOTSP, AND CHSPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE 'FAST FOURIER TRANSFORM' IS NOT USED C IN THIS VEERSION OF TIME, BUT WILL BE C IMPLEMENTED IN A FUTURE VEERSION. C --THE USUAL MAXIMUM NUMBER OF LAGS C FOR WHICH THE AUTOCORRELATION IS C COMPUTED IS N/4 WHERE N IS C THE SAMPLE SIZE (LENGTH OF THE C DATA RECORD IN THE VECTOR X). C THIS RULE IS OVERRIDDEN IN C LARGE DATA SETS AND IS REPLACED C BY THE RULE THAT THE MAXIMUM C NUMBER OF LAGS = 500 C (WHICH CORRESPONDS TO AN C AUTOCORRELATION PLOT COVERING C 5 COMPUTER PAGES). C IF MORE LAGS ARE DESIRED, C CHANGE THE VALUE OF THE C VARIABLE MAXLAG C WITHIN THIS SUBROUTINE C FROM 500 TO WHATEVER DESIRED, C AND ALSO CHANGE THE DIMENSION OF C THE VECTOR R FROM ITS PRESENT 500 TO HOWEVER C MANY LAGS ARE DESIRED. C --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED C TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME, C THEN THE FREQUENCY AXIS OF THE RESULTING C SPECTRA WOULD BE IN UNITS OF HERTZ C (= CYCLES PER SECOND). C --THE FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE C IN THE DATA OF INFINITE (= 1/(0.0)) C LENGTH OR PERIOD. C THE FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE C IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS. C --ANY EQUI-SPACED TIME SERIES ANALYSIS IS C INTRINSICALLY LIMITED TO DETECTING FREQUENCIES C NO LARGER THAN 0.5 CYCLES PER DATA POINT; C THIS CORRESPONDS TO THE FACT THAT THE C SMALLEST DETECTABLE CYCLE IN THE DATA C IS 2 DATA POINTS PER CYCLE. C REFERENCES--JENKINS AND WATTS, ESPECIALLY PAGE 290. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--MAY 1978. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JANUARY 1988. (SPECTRUM POINTS FROM 120 TO N/2 TO 1000 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION D(*) C DIMENSION COV11(*) DIMENSION COV22(*) DIMENSION COV12(*) DIMENSION COV21(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ C C-----START POINT----------------------------------------------------- C ISUBN1='DPSP' ISUBN2='E2 ' C IERROR='NO' C KMAX=0 C Y2BAR=0.0 VARBY2=0.0 COVB12=0.0 ALK=0.0 QK=0.0 AMPLIT=0.0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPSPE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(N.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPSPE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47) 47 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48) 48 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 49 CONTINUE C HOLD=Y1(1) DO60I=1,N IF(Y1(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPSPE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL ELEMENTS IN Y1 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)HOLD 63 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPSPE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,NUMLAG,MAXN 71 FORMAT('N,ICASPL,NUMLAG,MAXN = ',I8,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y1(I),Y2(I) 74 FORMAT('I, Y1(I), Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C C ******************************* C ** STEP 1-- ** C ** COMPUTE THE SAMPLE MEAN ** C ******************************* C AN=N SUM=0.0 DO100I=1,N SUM=SUM+Y1(I) 100 CONTINUE Y1BAR=SUM/AN C IF(ICASPL.EQ.'AUSP')GOTO190 C SUM=0.0 DO110I=1,N SUM=SUM+Y2(I) 110 CONTINUE Y2BAR=SUM/AN C 190 CONTINUE C C ************************************* C ** STEP 2-- ** C ** COMPUTE THE SAMPLE VARIANCE ** C ** AND SUM OF SQUARED DEVIATIONS ** C ************************************* C SUM=0.0 DO200I=1,N SUM=SUM+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR) 200 CONTINUE SSQY1=SUM VARBY1=SSQY1/AN VARY1=SSQY1/(AN-1.0) IF(VARY1.LE.0.0)SDY1=0.0 IF(VARY1.GT.0.0)SDY1=SQRT(VARY1) C IF(ICASPL.EQ.'AUSP')GOTO290 C SUM=0.0 DO210I=1,N SUM=SUM+(Y2(I)-Y2BAR)*(Y2(I)-Y2BAR) 210 CONTINUE SSQY2=SUM VARBY2=SSQY2/AN VARY2=SSQY2/(AN-1.0) IF(VARY2.LE.0.0)SDY2=0.0 IF(VARY2.GT.0.0)SDY2=SQRT(VARY2) C SUM=0.0 DO220I=1,N SUM=SUM+(Y1(I)-Y1BAR)*(Y2(I)-Y2BAR) 220 CONTINUE SSQ12=SUM COVB12=SSQ12/AN COVB21=COVB12 C 290 CONTINUE C C ******************************* C ** STEP 3-- ** C ** IF NECESSARY, ** C ** COMPUTE THE MAXIMUM LAG ** C ******************************* C MAXLAG=MAXN IF(NUMLAG.GE.1)KMAX=NUMLAG IF(NUMLAG.LE.0)KMAX=N/4 IF(NUMLAG.LE.0.AND.N.LE.32)KMAX=N/2 IF(NUMLAG.LE.0.AND.N.LE.16)KMAX=N IF(KMAX.GT.MAXLAG)KMAX=MAXLAG NM1=N-1 IF(KMAX.GT.NM1)KMAX=NM1 KMAXM1=KMAX-1 AKMAXM=KMAXM1 C C ***************************************************** C ** STEP 3-- ** C ** COMPUTE THE AUTOCORRELATIONS FOR THE Y1 DATA. ** C ** REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.1) ** C ** IF NECESSRY, ** C ** COMPUTE THE AUTOCORRELATIONS FOR THE Y2 DATA. ** C ** REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.3) ** C ** IF NECESSRY, ** C ** COMPUTE THE SAMPLE CROSS-CORRELATIONS ** C ** REFERENCE--JENKINS AND WATTS, PAGE 383 (9.3.5) ** C ***************************************************** C COV110=VARBY1 COV220=VARBY2 COV120=COVB12 COV210=COVB12 DO340K=1,KMAXM1 SUM11=0.0 SUM22=0.0 SUM12=0.0 SUM21=0.0 NMK=N-K DO350I=1,NMK J=I+K SUM11=SUM11+(Y1(I)-Y1BAR)*(Y1(J)-Y1BAR) IF(ICASPL.EQ.'AUSP')GOTO350 SUM22=SUM22+(Y2(I)-Y2BAR)*(Y2(J)-Y2BAR) SUM12=SUM12+(Y1(I)-Y1BAR)*(Y2(J)-Y2BAR) SUM21=SUM21+(Y2(I)-Y2BAR)*(Y1(J)-Y1BAR) 350 CONTINUE COV11(K)=SUM11/AN IF(ICASPL.EQ.'AUSP')GOTO340 COV22(K)=SUM22/AN COV12(K)=SUM12/AN COV21(K)=SUM21/AN 340 CONTINUE C C C ************************************** C ** STEP 4-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C C **************************************************************** C ** STEP 4.1-- C ** COMPUTE AUTOSPECTRA FOR Y1 C ** REFERENCE--JENKINS AND WATTS--PAGES 382 AND 383 (9.3.2 AND 9 C **************************************************************** C 1000 CONTINUE IF(ICASPL.EQ.'AUSP')GOTO1100 GOTO1900 C 1100 CONTINUE CCCCC IMAX=120 IMAX=(N/2) IF(IMAX.LT.120)IMAX=120 IF(IMAX.GT.1000)IMAX=1000 AIMAX=IMAX NUMFRE=IMAX+1 C J=0 CCCCC DO1110IP1=1,NUMFRE DO1110IP1=2,NUMFRE J=J+1 I=IP1-1 AI=I SUM11=0.0 C DO1120K=1,KMAXM1 AK=K ARG1=PI*AK/AKMAXM ARG2=PI*AI*AK/AIMAX WK=0.5*(1.0+COS(ARG1)) AFACT=WK*COS(ARG2) SUM11=SUM11+COV11(K)*AFACT 1120 CONTINUE C FREQJ=0.5*AI/AIMAX SP11J=2.0*(COV110+2.0*SUM11) IF(SP11J.LE.0.0)SP11J=0.000001 C Y(J)=SP11J X(J)=FREQJ D(J)=1.0 C 1110 CONTINUE NPLOTP=J NPLOTV=2 GOTO9000 C 1900 CONTINUE C C **************************************************************** C ** COMPUTE COSPECTRUM AND QUADRATURE SPECTRUM. C ** REFERENCE--JENKINS AND WATTS--PAGE 383 (9.3.8 AND 9.3.9) C ** COMPUTE COHERENCY PLOT. C ** COMPUTE AMPLITUDE PLOT. C ** COMPUTE PHASE PLOT. C ** COMPUTE GAIN PLOT. C ** COMPUTE ARGAND PLOT. C ** REFERENCE--JENKINS AND WATTS--PAGE 383 (9.3.10, 9.3.11, 9.3. C ** REFERENCE--GRANGER AND HATANAKA, PAGE 77-79. ** C **************************************************************** C 2000 CONTINUE CCCCC IMAX=120 IMAX=(N/2) IF(IMAX.LT.120)IMAX=120 IF(IMAX.GT.1000)IMAX=1000 AIMAX=IMAX NUMFRE=IMAX+1 C J=0 JPF=0 DO2010IP1=1,NUMFRE J=J+1 I=IP1-1 AI=I SUM11=0.0 SUM22=0.0 SUM12=0.0 SUM21=0.0 AL0=(COV120+COV210)/2.0 Q0=(COV120-COV210)/2.0 C DO2020K=1,KMAXM1 AK=K ARG1=PI*AK/AKMAXM ARG2=PI*AI*AK/AIMAX WK=0.5*(1.0+COS(ARG1)) AFACTC=WK*COS(ARG2) AFACTS=WK*SIN(ARG2) SUM11=SUM11+COV11(K)*AFACTC SUM22=SUM22+COV22(K)*AFACTC ALK=(COV12(K)+COV21(K))/2.0 QK=(COV12(K)-COV21(K))/2.0 SUM12=SUM12+ALK*AFACTC SUM21=SUM21+QK*AFACTS 2020 CONTINUE C FREQJ=0.5*AI/AIMAX SP11J=2.0*(COV110+2.0*SUM11) SP22J=2.0*(COV220+2.0*SUM22) COSPJ=2.0*(AL0+2.0*SUM12) QUSPJ=2.0*(Q0+2.0*SUM21) C IF(IBUGG3.EQ.'ON') 1WRITE(ICOUT,2121)J,ALK,QK,SP11J,SP22J,COSPJ,QUSPJ 2121 FORMAT('I,ALK,QK,SP11J,SP22J,COSPJ,QUSPJ = ', 1I8,6F10.5) IF(IBUGG3.EQ.'ON') 1CALL DPWRST('XXX','BUG ') C IF(ICASPL.EQ.'COSP')GOTO2100 IF(ICASPL.EQ.'QUSP')GOTO2200 IF(ICASPL.EQ.'CRSP')GOTO2300 IF(ICASPL.EQ.'COHE')GOTO2400 IF(ICASPL.EQ.'AMPL')GOTO2500 IF(ICASPL.EQ.'PHAS')GOTO2600 IF(ICASPL.EQ.'GAIN')GOTO2700 IF(ICASPL.EQ.'ARGA')GOTO2800 C 2030 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** INTERNAL ERROR IN DPSPE2') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' AT BRANCH POINT 681--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2313) 2313 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 9--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' AUSP, COSP, QUSP, CRSP, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315) 2315 FORMAT(' COHE, AMPL, PHAS, GAIN, ARGA. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316)ICASPL 2316 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2100 CONTINUE Y(J)=COSPJ X(J)=FREQJ D(J)=1.0 GOTO2010 C 2200 CONTINUE Y(J)=QUSPJ X(J)=FREQJ D(J)=1.0 GOTO2010 C 2300 CONTINUE Y(J)=COSPJ X(J)=FREQJ D(J)=1.0 JPF=J+NUMFRE Y(JPF)=QUSPJ X(JPF)=FREQJ D(JPF)=2.0 GOTO2010 C 2400 CONTINUE ARG=(COSPJ**2)+(QUSPJ**2) IF(ARG.LE.0.0)AMPLIT=0.0 IF(ARG.GT.0.0)AMPLIT=SQRT(ARG) Y(J)=AMPLIT*AMPLIT/(SP11J*SP22J) X(J)=FREQJ D(J)=1.0 GOTO2010 C 2500 CONTINUE ARG=(COSPJ**2)+(QUSPJ**2) IF(ARG.LE.0.0)Y(J)=0.0 IF(ARG.GT.0.0)Y(J)=SQRT(ARG) X(J)=FREQJ D(J)=1.0 GOTO2010 C 2600 CONTINUE ARG=-QUSPJ/COSPJ Y(J)=ATAN(ARG) X(J)=FREQJ D(J)=1.0 GOTO2010 C 2700 CONTINUE ARG=(COSPJ**2)+(QUSPJ**2) IF(ARG.LE.0.0)AMPLIT=0.0 IF(ARG.GT.0.0)AMPLIT=SQRT(ARG) Y(J)=AMPLIT/SP11J X(J)=FREQJ D(J)=1.0 GOTO2010 C 2800 CONTINUE Y(J)=COSPJ/SP11J X(J)=QUSPJ/SP22J D(J)=1.0 GOTO2010 C 2010 CONTINUE NPLOTP=J IF(ICASPL.EQ.'CRSP')NPLOTP=JPF NPLOTV=2 IF(ICASPL.EQ.'CRSP')NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IERROR,NPLOTP,NPLOTV 9012 FORMAT('ICASPL,IERROR,NPLOTP,NPLOTV = ',A4,2X,A4,2X,I8,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPEC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--FORM C 1) AUTOSPECTRUM C 2) CO-SPECTRUM; C 3) QUADRATURE SPECTRUM; C 4) CROSS-SPECTRUM (CO-SPECTRUM AND CROSS-SPECTRUM); C 5) COHERENCY DIAGRAM; C 6) AMPLITUDE DIAGRAM; C 7) PHASE DIAGRAM; C 8) GAIN DIAGRAM; C 9) ARGAND DIAGRAM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MAY 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1979. C UPDATED --JANUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHVA21 CHARACTER*4 IHVA22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION COV11(MAXOBV) DIMENSION COV22(MAXOBV) DIMENSION COV12(MAXOBV) DIMENSION COV21(MAXOBV) CCCCC THE FOLLOWING INCLUDE & 6 EQUIV. WERE ADDED JUNE 1990 (ALAN) INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),COV11(1)) EQUIVALENCE (GARBAG(IGARB4),COV22(1)) CCCCC THE FOLLOWING 2 EQUIVALENCES WERE FIXED JANUARY 1991 CCCCC TO FIX A QUADRATURE SPECTRUM PROBLEM (BOULDER) JANUARY 1991 EQUIVALENCE (GARBAG(IGARB5),COV12(1)) EQUIVALENCE (GARBAG(IGARB6),COV21(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='EC ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLV2=0 C C **************************************************************** C ** TREAT THE FOLLOWING CASES-- * C ** 1) AUTOSPECTRUM * C ** 2) CO-SPECTRUM; * C ** 3) QUADRATURE SPECTRUM; * C ** 4) CROSS-SPECTRUM (CO-SPECTRUM AND CROSS-SPECTRUM); * C ** 5) COHERENCY DIAGRAM; * C ** 6) PHASE DIAGRAM; * C ** 7) GAIN DIAGRAM; * C ** 8) ARGAND DIAGRAM. * C **************************************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ******************************************* C ** STEP 1.1-- ** C ** SEARCH FOR SPECTRUM OR AUTOSPECTRUM ** C ******************************************* C ICASPL='AUSP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AUTO'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'SPEC'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'SPEC'.AND.IHARG(1).NE.'PLOT') 1GOTO110 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SPEC'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'SPEC'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C C ***************************** C ** STEP 1.2-- ** C ** SEARCH FOR COSPECTRUM ** C ***************************** C ICASPL='COSP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CO'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CO'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COSP'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COSP'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C C ************************************** C ** STEP 1.3-- ** C ** SEARCH FOR QUADRATURE SPECTRUM ** C ************************************** C ICASPL='QUSP' C BUG FIX: AUGUST, 1987, QUADRATIC SPLINE FIT COMMAND WAS GOING TO C QUADRATURE SPECTRUM PLOT IF(ICOM.EQ.'QUAD'.AND.ICOM2.EQ.'RATI')GOTO20 C END FIX C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C BUG FIX 20 CONTINUE C END FIX C C ********************************* C ** STEP 1.4-- ** C ** SEARCH FOR CROSS-SPECTRUM ** C ********************************* C ICASPL='CRSP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CROS'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SSPE'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'CROS'.AND.ICOM2.EQ.'SSPE'.AND.IHARG(1).NE.'PLOT') 1GOTO110 C C ************************************ C ** STEP 1.5-- ** C ** SEARCH FOR COHERENCY DIAGRAM ** C ************************************ C ICASPL='COHE' C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COHE'.AND.IHARG(1).EQ.'DIAG') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'COHE'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'COHE'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'COHE'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C C ************************************ C ** STEP 1.6-- ** C ** SEARCH FOR AMPLITUDE DIAGRAM ** C ************************************ C ICASPL='AMPL' C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AMPL'.AND.IHARG(1).EQ.'DIAG') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'AMPL'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AMPL'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AMPL'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C C C ******************************** C ** STEP 1.7-- ** C ** SEARCH FOR PHASE DIAGRAM ** C ******************************** C ICASPL='PHAS' C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PHAS'.AND.IHARG(1).EQ.'DIAG') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'PHAS'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PHAS'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'PHAS'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C C ******************************* C ** STEP 1.8-- ** C ** SEARCH FOR GAIN DIAGRAM ** C ******************************* C ICASPL='GAIN' C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'GAIN'.AND.IHARG(1).EQ.'DIAG') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'GAIN'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'GAIN'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'GAIN'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C C ********************************* C ** STEP 1.9-- ** C ** SEARCH FOR ARGAND DIAGRAM ** C ********************************* C ICASPL='ARGA' C IF(NUMARG.GE.1.AND. 1ICOM.EQ.'ARGA'.AND.IHARG(1).EQ.'DIAG') 1GOTO111 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'ARGA'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'ARGA'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'ARGA'.AND.IHARG(1).EQ.'SPEC'.AND.IHARG(2).NE.'PLOT') 1GOTO111 C ICASPL=' ' C IFOUND='NO' GOTO9000 C 110 CONTINUE ILASTC=0 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(ICASPL.EQ.'AUSP')GOTO270 IF(ICASPL.EQ.'COSP')GOTO280 IF(ICASPL.EQ.'QUSP')GOTO280 IF(ICASPL.EQ.'CRSP')GOTO280 IF(ICASPL.EQ.'COHE')GOTO280 IF(ICASPL.EQ.'AMPL')GOTO280 IF(ICASPL.EQ.'PHAS')GOTO280 IF(ICASPL.EQ.'GAIN')GOTO280 IF(ICASPL.EQ.'ARGA')GOTO280 C 260 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPSPEC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,262) 262 FORMAT(' AT BRANCH POINT 261--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,263) 263 FORMAT(' ICASPL NOT EQUAL ONE OF THE ALLOWABLE 9--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,264) 264 FORMAT(' AUSP, COSP, QUSP, CRSP,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,265) 265 FORMAT(' COHE, AMPL, PHAS, GAIN, ARGA. ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,267) 267 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,268)(IANS(I),I=1,IWIDTH) 268 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 270 CONTINUE MAXV2=1 GOTO290 C 280 CONTINUE MAXV2=2 GOTO290 C 290 CONTINUE C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *********************************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A SPECTRAL ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C *********************************************** C ** STEP 6-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EXACTLY 1 ** C ** FOR AN AUTOSPECTRAL ANALYSIS; ** C ** EXACTLY 2 ** C ** FOR A CROSS-SPECTRAL ANALYSIS. ** C ** ALSO, FOR A CROSS-SPECTRAL ANALYSIS, ** C ** CHECK THE VALIDITY ** C ** OF THE SECOND VARIABLE. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** IN THE SECOND VARIABLE ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE FIRST VARIABLE? ** C *********************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO509 GOTO550 C 509 CONTINUE IF(NUMV2.LE.1)GOTO590 IHVA21=IHARG(2) IHVA22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVA21,IHVA22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLV2=IVALUE(ILOCV) NVAR2=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHVA21,IHVA22,ICOLV2,NVAR2 511 FORMAT('IHVA21,IHVA22,ICOLV2,NVAR2 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NVAR2.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A CROSS-SPECTRAL ANALYSIS, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556) 556 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMV2 557 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A CROSS-SPECTRAL ANALYSIS, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574) 574 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577)IHLEFT,IHLEF2,NLEFT 577 FORMAT(' THE FIRST VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)IHVA21,IHVA22,NVAR2 578 FORMAT(' THE SECOND VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,580)(IANS(I),I=1,IWIDTH) 580 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ********************************************** C ** STEP 7-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE FIRST VARIABLE; ** C ** ALSO, FOR A CROSS-SPECTRAL ANALYSIS, ** C ** FORM THE VARIABLE Y2(.) ** C ** WHICH WILL CONTAIN THE SECOND VARIABLE. ** C ** FORM THESE VARIABLES BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO610 IF(ICASQ.EQ.'SUBS')GOTO620 IF(ICASQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE IF(NQ.GE.MINN2)GOTO660 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) 651 FORMAT('***** ERROR IN DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653)IHLEFT,IHLEF2 653 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,654) 654 FORMAT(' (FOR WHICH AN AUTO OR CROSS-SPECTRAL ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,656)MINN2 656 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657) 657 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658) 658 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,659)(IANS(I),I=1,IWIDTH) 659 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 660 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO670I=1,IMAX IF(ISUB(I).EQ.0)GOTO670 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y1(J)=TAGPLO(I) IF(MAXV2.LE.1)GOTO670 C IJ=MAXN*(ICOLV2-1)+I IF(ICOLV2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLV2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLV2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLV2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLV2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLV2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLV2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 670 CONTINUE NS=J C C ********************************************************** C ** STEP 8-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE NUMBER OF LAGS DESIRED ** C ** FOR THE CROSS-SPECTRAL ANALYSIS. ** C ** THE LAG SETTING IS DONE BY SEARCHING THE ** C ** INTERNAL TABLE FOR THE PARAMETER NAMES ** C ** LAGS, LAG, OR NUMLAG ** C ** (WITH THE SEARCH CONDUCTED IN THAT ORDER ** C ** AND WITH THE FIRST FIND TERMINATING ** C ** THE SEARCH.) ** C ** IF FOUND, USE THE SPECIFIED VALUE ** C ** (WHICH MUST BE BETWEEN 1 AND 1000, INCLUSIVE); ** C ** IF NOT FOUND, USE THE DEFAULT VALUE ** C ** (USUALLY NS/4) WHICH WILL BE DEFINED ** C ** IN THE SUBROUTINE DPSPE2. ** C ********************************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMLAG=0 C IH='LAGS' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')NUMLAG=VALUE(ILOCV)+0.5 IF(IERROR.EQ.'NO')GOTO790 C IH='LAG ' IH2=' ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')NUMLAG=VALUE(ILOCV)+0.5 IF(IERROR.EQ.'NO')GOTO790 C IH='NUML' IH2='AG ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')NUMLAG=VALUE(ILOCV)+0.5 IF(IERROR.EQ.'NO')GOTO790 C 790 CONTINUE C C **************************************************************** C ** STEP 9-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE ALL ONES FOR ALL 7 CASES EXCEPT * C ** WHEN THE COMMAND CROSS-SPECTRUM IS ENTERED * C ** WHICH WILL RESULT IN 2 SUPERIMPOSED CURVES-- * C ** THE CO-SPECTRUM AND THE QUADRATURE SPECTRUM * C ** AND SO D(.) WILL RETURN WITH ALL ONES FOR C ** THE CO-SPECTRUM PART, AND ALL TWOS * C ** FOR THE QUADRATURE SPECTRUM PART. * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSPE2(Y1,Y2,NS,ICASPL,NUMLAG,MAXN, 1COV11,COV22,COV12,COV21, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C TEMPORARY PATCH FOR STEFAN (FOR CEPSTRAL CALCULATIONS)-- C CCCCC DO800I=1,NPLOTP NO LONGER NEEDED (DEC. 1986) CCCCC PRED(I)=Y(I) CCCCC RES(I)=X(I) CC800 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMLAG,MAXN 9014 FORMAT('NUMLAG,MAXN = ',I8,I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9090 DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPL(IBUGA2,IBUGA3,IBUGQ,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--CARRY OUT A SPLINE FIT C (ANY DEGREE FROM 1 TO 10). C NOTE--FOR A GIVEN DEGREE, ALL LOW-ORDER C DERIVATIVES WILL BE SET SO THAT THE FUNCTION C WILL BE SMOOTH AT THE KNOTS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1978. C UPDATED --MARCH 1981. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C MOVE SOME DIMENSIONS TO DPSPL C C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASSF CHARACTER*4 ICASEQ CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IOP CHARACTER*4 IREPU CHARACTER*4 IRESU CHARACTER*4 IBUGJU CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHFACT CHARACTER*4 IHFAC2 CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION ICOLIV(10) DIMENSION NIV(10) C DIMENSION B(100) DIMENSION SDB(100) DIMENSION B2(100) DIMENSION SDB2(100) C DIMENSION PRED2(MAXOBV) DIMENSION RES2(MAXOBV) C DIMENSION XKNOT(MAXOBV) DIMENSION W(MAXOBV) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C--------------------------------------------------------------------- C EQUIVALENCE (XKNOT(1),X3D(1)) EQUIVALENCE (W(1),D(1)) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' DIMENSION V1(MAXOBV) DIMENSION V2(MAXOBV) DIMENSION DUM1(MAXOBV) DIMENSION DUM2(MAXOBV) DIMENSION AJUNK(MAXOBV) EQUIVALENCE (GARBAG(IGARB1),PRED2(1)) EQUIVALENCE (GARBAG(IGARB2),RES2(1)) EQUIVALENCE (GARBAG(IGARB3),V1(1)) EQUIVALENCE (GARBAG(IGARB4),V2(1)) EQUIVALENCE (GARBAG(IGARB5),DUM1(1)) EQUIVALENCE (GARBAG(IGARB6),DUM2(1)) EQUIVALENCE (GARBAG(IGARB7),AJUNK(1)) EQUIVALENCE (GARBAG(IGARB8),SDB(1)) EQUIVALENCE (GARBAG(IGARB8+100),SDB2(1)) EQUIVALENCE (GARBAG(IGARB8+200),B(1)) EQUIVALENCE (GARBAG(IGARB8+300),B2(1)) CCCCC END CHANGE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSP' ISUBN2='L ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=3 MINN2=2 C MAXFAC=MAXV2 C MINDEG=1 MAXDEG=10 C NUMCHA=0 C ICASEQ='UNKN' C C ********************************* C ** TREAT THE SPLINE FIT CASE ** C ********************************* C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ 53 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************* C ** STEP 1.1-- ** C ** SEARCH FOR SPLINE FIT ** C ** (WITH UNSPECIFIED DEGREE) ** C ********************************* C ICASSF='SF' C IF(ICOM.EQ.'SPLI'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FIT') 1GOTO111 C C ********************************************* C ** STEP 1.21-- ** C ** SEARCH FOR 1-ST DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='1SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'1'.AND.IHARG(1).EQ.'ST'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'1ST'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'1'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'ONE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'1'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'ONE'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.22-- ** C ** SEARCH FOR 2-ND DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='2SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'2'.AND.IHARG(1).EQ.'ND'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'2ND'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'2'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'TWO'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'2'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'TWO'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.23-- ** C ** SEARCH FOR 3-RD DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='3SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'3'.AND.IHARG(1).EQ.'RD'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'3RD'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'3'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'THRE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'3'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'THRE'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'CUBI'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.24-- ** C ** SEARCH FOR 4-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='4SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'4'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'4TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'FOUR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'4'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'FOUR'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'4'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'FOUR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUAR'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.25-- ** C ** SEARCH FOR 5-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='5SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'5'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'5TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'FIFT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'5'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'FIVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'5'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'FIVE'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'QUIN'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.26-- ** C ** SEARCH FOR 6-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='6SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'6'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'6TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SIXT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'6'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SIX'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'6'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'SIX'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SEXT'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.27-- ** C ** SEARCH FOR 7-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='7SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'7'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'7TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SEVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'7'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'SEVE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'7'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'SEVE'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'SEPT'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.28-- ** C ** SEARCH FOR 8-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='8SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'8'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'8TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'EIGH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'8'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'EIGH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'8'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'EIGH'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'OCTI'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.29-- ** C ** SEARCH FOR 9-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='9SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'9'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'9TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'NINT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'9'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'NINE'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'9'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'NINE'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'NONI'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ********************************************* C ** STEP 1.30-- ** C ** SEARCH FOR 10-TH DEGREE SPLINE FITTING ** C ********************************************* C ICASSF='10SF' C IF(NUMARG.GE.4.AND. 1ICOM.EQ.'10'.AND.IHARG(1).EQ.'TH'.AND.IHARG(2).EQ.'DEGR'.AND. 1IHARG(3).EQ.'SPLI'.AND.IHARG(4).EQ.'FIT')GOTO114 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'10TH'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'TENT'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'10'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'TEN'.AND.IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'10'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.3.AND. 1ICOM.EQ.'DEGR'.AND.IHARG(1).EQ.'TEN'.AND.IHARG(2).EQ.'SPLI'.AND. 1IHARG(3).EQ.'FIT')GOTO113 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'DEXI'.AND.IHARG(1).EQ.'SPLI'.AND.IHARG(2).EQ.'FIT') 1GOTO112 C C ******************************************** C ** STEP 1.31-- ** C ** SINCE VALID COMMAND NOT FOUND, EXIT. ** C ******************************************** C ICASSF=' ' C IFOUND='NO' GOTO9000 C 111 CONTINUE CCCCC ILASTC=1 CCCCC CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE CCCCC ILASTC=2 CCCCC CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 113 CONTINUE CCCCC ILASTC=3 CCCCC CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 114 CONTINUE CCCCC ILASTC=4 CCCCC CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=4 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 2-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO290 DO200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO220 200 CONTINUE GOTO290 210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO290 220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO290 290 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO295 WRITE(ICOUT,291)NUMARG,ILOCQ 291 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 295 CONTINUE C C ********************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE SPLINE FIT COMMAND, ** C ** THE WORD AFTER FIT SHOULD BE THE RESPONSE ** C ** VARIABLE (= THE DEPENDENT VARIABLE). ** C ** EXTRACT THE RESPONSE VARIABLE AND DETERMINE ** C ** IF IT IS ALREADY IN THE NAME LIST AND IS, IN FACT, ** C ** A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ********************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C I2=0 IF(ICOM.EQ.'FIT')GOTO2349 IMAX=ILOCQ-1 DO2330I=1,IMAX I2=I IF(IHARG(I).EQ.'FIT')GOTO2349 2330 CONTINUE WRITE(ICOUT,2331) 2331 FORMAT('***** INTERNAL ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2332) 2332 FORMAT(' THE WORD FIT NOT FOUND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2333) 2333 FORMAT(' IN THE ARGUMENT LIST, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3334) 3334 FORMAT(' EVEN THOUGH IT HAD BEEN PREVIOSULY FOUND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2335)NUMARG,IMAX 2335 FORMAT(' NUMARG, IMAX = ',2I10) CALL DPWRST('XXX','BUG ') DO2336I=1,NUMARG WRITE(ICOUT,2337)I,IHARG(I),IHARG2(I) 2337 FORMAT('I,IHARG(I),IHARG2(I) = ',I8,A4,A4) CALL DPWRST('XXX','BUG ') 2336 CONTINUE WRITE(ICOUT,2338)IWIDTH 2338 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2339)(IANS(J),J=1,IWIDTH) 2339 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2349 CONTINUE ILOCFI=I2 C ILOCF1=ILOCFI+1 IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) DO2350I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I2).AND.IHLEF2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME FOLLOWING THE WORD FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE THE RESPONSE VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2365) 2365 FORMAT(' OR IS A PARAMETER (AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' LIST OF AVAILABLE VARIABLE AND PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2368) 2368 FORMAT(' NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2371)IHLEFT,IHLEF2 2371 FORMAT(' NAME AFTER THE WORD FIT = ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2372) 2372 FORMAT(' CURRENT LIST OF DEFINED VARIABLES AND ', 1'PARAMETERS--') CALL DPWRST('XXX','BUG ') DO2373K2=1,NUMNAM WRITE(ICOUT,2374)IHNAME(K2),IHNAM2(K2),IUSE(K2),IVALUE(K2), 1VALUE(K2) 2374 FORMAT(6X,A4,A4,6X,A4,6X,I6,6X,E15.7) CALL DPWRST('XXX','BUG ') 2373 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2375)IWIDTH 2375 FORMAT(' NUMBER OF CHARACTERS IN COMMAND LINE = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2376)(IANS(J),J=1,IWIDTH) 2376 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2379 CONTINUE ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) 2390 CONTINUE C C *********************************************************** C ** STEP 5-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *********************************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A SPLINE FIT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN PERFORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C ************************************************************** C ** STEP 5-- ** C ** CHECK THE VALIDITY OF THE VARIABLES. ** C ** CHECK THAT THERE ARE 2 OR 3 VARIABLES. ** C ** (WHEN HAVE 2 ARGUMENTS, THEN MUST HAVE PRIOR ** C ** USE OF THE KNOTS COMMAND.) ** C ** CHECK THE VALIDITY OF EACH OF THE VARIABLES. ** C ** DOES THE VARIABLE NAME EXIST IN THE TABLE? ** C ** IS THE NUMBER OF ELEMENTS FOR EACH VARIABLE POSITIVE? ** C ** DOES THE NUMBER OF ELEMENTS IN VARIABLE 2 ** C ** AGREE WITH THE NUMBER OF ELEMENTS IN VARIABLE 1? ** C ************************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMFAC=ILOCQ-ILOCFI-1 IF(1.LE.NUMFAC.AND.NUMFAC.LE.MAXFAC)GOTO509 WRITE(ICOUT,501) 501 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,502) 502 FORMAT(' FOR A SPLINE FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,503) 503 FORMAT(' THE NUMBER OF VARIABLES MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,504) 504 FORMAT(' EITHER 2 OR 3;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,505) 505 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,506)NUMFAC 506 FORMAT(' THE SPECIFIED NUMBER OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,507) 507 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,508)(IANS(I),I=1,IWIDTH) 508 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 509 CONTINUE C IFACMN=ILOCFI+1 IFACMX=ILOCFI+3 DO510IFAC=IFACMN,IFACMX IHFACT=IHARG(IFAC) IHFAC2=IHARG2(IFAC) IF(NUMFAC.EQ.2.AND.IFAC.EQ.IFACMX)IHFACT=IKNOT1 IF(NUMFAC.EQ.2.AND.IFAC.EQ.IFACMX)IHFAC2=IKNOT2 IHWUSE='V' MESSAG='YES' CALL CHECKN(IHFACT,IHFAC2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLIV(IFAC)=IVALUE(ILOCV) NIV(IFAC)=IN(ILOCV) IF(IBUGA2.EQ.'ON')WRITE(ICOUT,666)IFAC,IHFACT,IHFAC2,ICOLIV(IFAC), 1NIV(IFAC) 666 FORMAT('IFAC,IHFACT,IHFAC2,ICOLIV(IFAC),NIV(IFAC) = ', 1I8,2X,A4,A4,I8,I8) IF(IBUGA2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C DO515IFAC=IFACMN,IFACMX IF(NIV(IFAC).GE.1)GOTO515 GOTO520 515 CONTINUE GOTO529 C 520 CONTINUE WRITE(ICOUT,521) 521 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,522) 522 FORMAT(' FOR A SPLINE FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,523) 523 FORMAT(' ALL VARIABLES MUST HAVE AT LEAST 1 ELEMENT;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,524) 524 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO525IFAC=IFACMN,IFACMX WRITE(ICOUT,526)IHARG(IFAC),IHARG2(IFAC),NIV(IFAC) 526 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 525 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,527) 527 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,528)(IANS(I),I=1,IWIDTH) 528 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 529 CONTINUE C J1=ILOCFI+1 J2=ILOCFI+2 J3=ILOCFI+3 IF(NIV(J2).EQ.NIV(J1).AND.NIV(J3).LE.NIV(J2))GOTO549 WRITE(ICOUT,531) 531 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,532) 532 FORMAT(' FOR A SPLINE FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,533) 533 FORMAT(' THE NUMBER OF ELEMENTS IN VARIABLE 2 MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,534) 534 FORMAT(' EQUAL THE NUMBER OF ELEMENTS IN VARIABLE 1;') CALL DPWRST('XXX','BUG ') IF(NUMFAC.GE.3)WRITE(ICOUT,536) 536 FORMAT(' AND THE NUMBER OF ELEMENTS IN KNOTS VARIABLE ', 1'(THE KNOTS) MUST') IF(NUMFAC.GE.3)CALL DPWRST('XXX','BUG ') IF(NUMFAC.GE.3)WRITE(ICOUT,537) 537 FORMAT(' NOT EXCEED THE NUMBER OF ELEMENTS IN ', 1'VARIABLE 2;') IF(NUMFAC.GE.3)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,538) 538 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO545IFAC=IFACMN,IFACMX WRITE(ICOUT,546)IHARG(IFAC),IHARG2(IFAC),NIV(IFAC) 546 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') 545 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,547) 547 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,548)(IANS(I),I=1,IWIDTH) 548 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 549 CONTINUE C C ********************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE EXACT RATIONAL FIT. ** C ********************************************* C ISTEPN='6' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO660I=1,IMAX IF(ISUB(I).EQ.0)GOTO660 J=J+1 C IFAC=ILOCFI+1 ICOLR=ICOLIV(IFAC) IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.10)Y(J)=V(IJ) IF(ICOLR.EQ.11)Y(J)=PRED(I) IF(ICOLR.EQ.12)Y(J)=RES(I) C IFAC=ILOCFI+2 ICOLR=ICOLIV(IFAC) IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X(J)=TAGPLO(I) C 660 CONTINUE NS=J C CCCCC IF(NUMFAC.LE.2)GOTO699 J=0 IFAC=ILOCFI+3 IMAX=NIV(IFAC) DO670I=1,IMAX J=J+1 C IFAC=ILOCFI+3 ICOLR=ICOLIV(IFAC) IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)XKNOT(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)XKNOT(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)XKNOT(J)=RES(I) IF(ICOLR.EQ.MAXCP3)XKNOT(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)XKNOT(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)XKNOT(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)XKNOT(J)=TAGPLO(I) C 670 CONTINUE N34=IMAX C 699 CONTINUE C C *************************************************** C ** STEP 7-- ** C ** EXTRACT THE DEGREE OF THE SPLINE FUNCTION. ** C ** CHECK THAT THE DEGREE IS IN THE VALID RANGE ** C ** (1 TO 10). ** C *************************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCRV=ILOCFI+1 ILOCIV=ILOCFI+2 ILOCW=ILOCFI+3 C CCCCC IDEGRE=0 IDEGRE=3 IF(ICASSF.EQ.'SF'.AND.IDEG.GE.MINDEG.AND.IDEG.LE.MAXDEG) 1IDEGRE=IDEG IF(ICASSF.EQ.'0SF')IDEGRE=0 IF(ICASSF.EQ.'1SF')IDEGRE=1 IF(ICASSF.EQ.'2SF')IDEGRE=2 IF(ICASSF.EQ.'3SF')IDEGRE=3 IF(ICASSF.EQ.'4SF')IDEGRE=4 IF(ICASSF.EQ.'5SF')IDEGRE=5 IF(ICASSF.EQ.'6SF')IDEGRE=6 IF(ICASSF.EQ.'7SF')IDEGRE=7 IF(ICASSF.EQ.'8SF')IDEGRE=8 IF(ICASSF.EQ.'9SF')IDEGRE=9 IF(ICASSF.EQ.'10FI')IDEGRE=10 IF(ICASSF.EQ.'10SF')IDEGRE=10 C IF(MINDEG.LE.IDEGRE.AND.IDEGRE.LE.MAXDEG)GOTO899 WRITE(ICOUT,821) 821 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,822) 822 FORMAT(' FOR A SPLINE FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,823) 823 FORMAT(' THE DEGREE FOR THE FIT MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,824)MINDEG,MAXDEG 824 FORMAT(' BETWEEN ',I8,' AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,825) 825 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,826)IDEGRE 826 FORMAT(' THE SPECIFIED DEGREE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,828) 828 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,829)(IANS(I),I=1,IWIDTH) 829 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 899 CONTINUE C NKNOT=NIV(ILOCW) K=IDEGRE+NKNOT+1 C IF(NS.GE.K)GOTO920 WRITE(ICOUT,901) 901 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902) 902 FORMAT(' FOR A SPLINE FIT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) 903 FORMAT(' THE NUMBER OF ELEMENTS IN THE FIRST VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,904) 904 FORMAT(' (THAT IS, THE NUMBER OF POINTS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) 905 FORMAT(' FITTED) MUST BE EQUAL TO OR GREATER THAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,906) 906 FORMAT(' THE NUMBER OF COEFFICIENTS TO BE ESTIMATED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,907) 907 FORMAT(' (THAT IS, MUST BE EQUAL TO OR GREATER THAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,908) 908 FORMAT(' (SPLINE DEGREE + NUMBER OF KNOTS + 1));') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,909) 909 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,910)NS 910 FORMAT(' NUMBER OF FIT POINTS FROM FIRST VARIABLE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,911)K 911 FORMAT(' NUMBER OF ESTIMATED COEFFICIENTS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,912)IDEGRE 912 FORMAT(' DEGREE OF SPLINE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,913)NKNOT 913 FORMAT(' NUMBER OF KNOTS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,914) 914 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,915)(IANS(I),I=1,IWIDTH) 915 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 920 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** CHECK THAT THE PRODUCT OF THE NUMBER OF POINTS ** C ** TO BE FITTED (NS) AND THE NUMBER OF B-SPLINE ** C ** COEFFICIENTS TO BE ESTIMATED (K) ** C ** DOES NOT EXCEED MAXNK--THUS THE ARRAY Z2(.) ** C ** IN THE SUBROUTINE DPSPL2 WILL NOT OVERFLOW. ** C ****************************************************** C INK=NS*K IF(INK.LE.MAXNK)GOTO929 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921) 921 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,922) 922 FORMAT(' AN INTERNAL ARRAY WILL OVERFLOW') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,923) 923 FORMAT(' IF THE PRODUCT OF THE NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,924) 924 FORMAT(' POINTS TO BE FITTED AND THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,925) 925 FORMAT(' NUMBER OF B-SPLINE COEFFICIENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,926)MAXNK 926 FORMAT(' TO BE ESTIMATED EXCEEDS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,927) 927 FORMAT(' SUCH WOULD BE THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,928)NS,K,INK 928 FORMAT(' N = ',I8,' K = ',I8,' N*K = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 929 CONTINUE C C **************************************************************** C ** STEP 10-- C ** PREPARE FOR ENTRANCE INTO DPSPL2-- C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. C **************************************************************** C ISTEPN='10' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO970I=1,NS W(I)=1.0 970 CONTINUE C C ********************************************************* C ** STEP 11-- ** C ** DUMP THE COMMON VECTOR V(.) OUT ONTO MASS STORAGE ** C ** SO AS TO PRESERVE THEIR CONTENTS FOR LATER USE ** C ** (AFTER DPSPL2). ** C ********************************************************* C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOP='WRIT' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C C ********************* C ** STEP 12- ** C ** ENTER DPSPL2. ** C ********************* C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPSPL, AS WE ARE ABOUT TO CALL DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6082)NUMCHA,NLEFT,MAXN,NS 6082 FORMAT('NUMCHA,NLEFT,MAXN,NS = ',4I8) CALL DPWRST('XXX','BUG ') DO6083I=1,NS WRITE(ICOUT,6084)I,Y(I),X(I),W(I) 6084 FORMAT('I,Y(I),X(I),W(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 6083 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,6091)IBUGA3 6091 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C CCCCC JUNE, 1990. MOVE SOME DIMENSIONS FROM DPSPL2 TO DPSPL CALL DPSPL2(Y,X,W,NS,XKNOT,NKNOT,IDEGRE,V, 1B,SDB,B2,SDB2,PRED2,RES2,REPSD,REPDF,RESSD,RESDF,ALFCDF, 1V1,V2,DUM1,DUM2,AJUNK, 1IBUGA3,IERROR) C IF(IERROR.EQ.'YES')GOTO9000 C C *************************************** C ** STEP 12-- ** C ** READ BACK IN FROM MASS STORAGE ** C ** THE CONTENTS OF THE V(.) MATRIX. ** C *************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO1109 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1101) 1101 FORMAT('WE ARE IN DPSPL AND ARE ABOUT TO READ V BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1102)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS 1102 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1103)V(1),PRED(1),RES(1) 1103 FORMAT('V(1),PRED(1),RES(1) = ',3E15.7) CALL DPWRST('XXX','BUG ') 1109 CONTINUE C IOP='READ' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C IF(IBUGA2.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('WE ARE IN DPSPL AND HAVE JUST READ V BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS 1112 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113)V(1),PRED(1),RES(1) 1113 FORMAT('V(1),PRED(1),RES(1) = ',3E15.7) CALL DPWRST('XXX','BUG ') 1119 CONTINUE C C *************************************** C ** STEP 14-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='14' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOLPR=MAXCP1 ICOLRE=MAXCP2 IREPU='ON' IRESU='ON' CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NLEFT, 1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,ILOCN,IBUGA3,IERROR) C IBUGJU='OFF' C L=0 IKNMAX=NKNOT+1 JMAX=IDEGRE+1 DO7500IKN=1,IKNMAX DO7600J=1,JMAX L=L+1 JM1=J-1 CALL COENAM(IKN,JM1,IH,IH2,IBUGJU,IERROR) C 7640 CONTINUE DO7650I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO7680 7650 CONTINUE IF(NUMNAM.LT.MAXNAM)GOTO7670 WRITE(ICOUT,7651) 7651 FORMAT('***** ERROR IN DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7652) 7652 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7653)MAXNAM 7653 FORMAT(' NAMES MUST BE AT MOST ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7654) 7654 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7655) 7655 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7656) 7656 FORMAT(' WAS JUST EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7657) 7657 FORMAT(' SUGGESTED ACTION--ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7658) 7658 FORMAT(' TO DETERMINE THE IMPORTANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7659) 7659 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7660) 7660 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7661) 7661 FORMAT(' OF THE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7662) 7662 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,7663)(IANS(I),I=1,IWIDTH) 7663 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 7670 CONTINUE NUMNAM=NUMNAM+1 ILOC=NUMNAM IHNAME(ILOC)=IH IHNAM2(ILOC)=IH2 IUSE(ILOC)='P' VALUE(ILOC)=B2(L) GOTO7600 C 7680 CONTINUE VALUE(I2)=B2(L) GOTO7600 C 7600 CONTINUE 7500 CONTINUE C C *************************************** C ** STEP 15-- ** C ** ENTER A NOTE IN MODEL(.) ** C ** STATING THAT THE LAST FIT ** C ** WAS A SPLINE FIT ** C ** OF WHATEVER DEGREE. ** C *************************************** C 8000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO8100I=1,IWIDTH MODEL(I)=IANS(I) 8100 CONTINUE NUMCHA=IWIDTH C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NS,NKNOT,ICASSF,IDEGRE 9014 FORMAT('NS,NKNOT,ICASSF,IDEGRE = ',2I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPL2(Y,X,W,N,XKNOT,NKNOT,IDEGRE,Z2, 1B,SDB,B2,SDB2,PRED2,RES2,REPSD,REPDF,RESSD,RESDF,ALFCDF, 1V1,V2,DUM1,DUM2,AJUNK, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES A LEAST SQUARES SPLINE FIT C FOR ANY DEGREE--LINEAR, QUADRATIC, CUBIC, ETC. C ALGORITHM USED--B-SPLINES (MODIFIED SO THAT SOME ELEMENTS C SET = 0 RATHER THAN COMPUTED AS 0) C REFERENCE--WOLD, TECHNOMETRICS, 1974, PAGE 2 C INPUT ARGUMENTS--Y = SINGLE PRECISION VECTOR OF C RESPONSE DATA (THAT IS, THE C DEPENDENT VARIABLE). C X = SINGLE PRECISION MATRIX OF C THE DEPENDENT VARIABLE. C W = THE SINGLE PRECISION VECTOR C OF WEIGHTS FOR THE RESPONSE C VARIABLE. C N = THE INTEGER VALUE OF THE SAMPLE SIZE. C XKNOT = THE SINGLE PRECISION VECTOR OF KNOTS. C NKNOT = THE INTEGER NUMBER OF SPECIFIED KNOTS. C IDEGRE = THE INTEGER DEGREE OF THE SPLINE. C OUTPUT ARGUMENTS--B = THE SINGLE PRECISION VECTOR OF C ESTIMATED REGRESSION COEFFICIENTS. C SDB = THE SINGLE PRECISION VECTOR OF C ESTIMATED STANDARD DEVIATIONS OF THE C ESTIMATED REGRESSION COEFFICIENTS. C RESSD = THE ESTIMATED RESIDUAL STANDARD C DEVIATION. C PRED2 = THE SINGLE PRECISION VECTOR OF C PREDICTED VALUES. C RES2 = THE SINGLE PRECISION VECTOR OF C RESIDUALS FROM THE LEAST SQUARES FIT. C SUBROUTINES NEEDED--DECOMP, INVXWX, AND DOT. C NOTE--CODE MODIFIED SO THAT NUMBER OF KNOTS SHOULD NOT C EXCEED 50 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1975. C UPDATED --NOVEMBER 1975. C UPDATED --MAY 1976. C UPDATED --DECEMBER 1978. C UPDATED --AUGUST 1979. C UPDATED --MARCH 1981. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1988. ADD LOFCDF C UPDATED --JANUARY 1989. DECLARE AJUNK AS ARRAY (DIM. 1) (ALAN) C UPDATED --MAY 1989. INCREACED DIMENSION FOR V1 AND V2 C MOVE SOME DIMENSIONS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IREP CHARACTER*4 IBUGJU CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION W(*) DIMENSION XKNOT(*) C DIMENSION B(*) DIMENSION SDB(*) DIMENSION PRED2(*) DIMENSION RES2(*) DIMENSION B2(*) DIMENSION SDB2(*) C DIMENSION Z2(*) C DIMENSION XPX(50,50) C DIMENSION SSQ(50,50) EQUIVALENCE (SSQ(1,1),XPX(1,1)) C DIMENSION XPY(50) CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989 CCCCC DIMENSION V1(200) CCCCC JUNE, 1990. V1, V2, DUM1, DUM2, AJUNK NOW DIMENSIONED IN DPSPL CCCCC DIMENSION V1(MAXOBV) DIMENSION V1(*) CCCCC THE FOLLOWING LINE WAS FIXED MAY 1989 CCCCC DIMENSION V2(200) CCCCC DIMENSION V2(MAXOBV) DIMENSION V2(*) DIMENSION RIGHT(50) DIMENSION BTEMP(100) C DIMENSION A(50,50) EQUIVALENCE (A(1,1),XPX(1,1)) C DIMENSION EKNOT(200) CCCCC DIMENSION COV(50,50) CCCCC DIMENSION CORR(50,50) C CCCCC DIMENSION DUM1(MAXOBV) CCCCC DIMENSION DUM2(MAXOBV) C CCCCC DIMENSION AJUNK(MAXOBV) DIMENSION DUM1(*) DIMENSION DUM2(*) C DIMENSION AJUNK(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSP' ISUBN2='L2 ' C IERROR='NO' C K2=0 C DIJ=0.0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NKNOT,IDEGRE 52 FORMAT('N,NKNOT,IDEGRE = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA3 53 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I),W(I),XKNOT(I) 56 FORMAT('I,Y(I),X(I),W(I),XKNOT(I) = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C AN=N K=NKNOT+IDEGRE+1 AK=K DEG=IDEGRE KMAX=50 C C *************************** C ** STEP 1-- ** C ** WRITE OUT THE TITLE ** C *************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('LEAST SQUARES SPLINE FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)N 102 FORMAT(' SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.1)WRITE(ICOUT,111) 111 FORMAT(' MODEL--LINEAR SPLINE') IF(IDEGRE.EQ.1)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.2)WRITE(ICOUT,112) 112 FORMAT(' MODEL--QUADRATIC SPLINE') IF(IDEGRE.EQ.2)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.3)WRITE(ICOUT,113) 113 FORMAT(' MODEL--CUBIC SPLINE') IF(IDEGRE.EQ.3)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.4)WRITE(ICOUT,114) 114 FORMAT(' MODEL--4-TH DEGREE SPLINE') IF(IDEGRE.EQ.4)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.5)WRITE(ICOUT,115) 115 FORMAT(' MODEL--5-TH DEGREE SPLINE') IF(IDEGRE.EQ.5)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.6)WRITE(ICOUT,116) 116 FORMAT(' MODEL--6-TH DEGREE SPLINE') IF(IDEGRE.EQ.6)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.7)WRITE(ICOUT,117) 117 FORMAT(' MODEL--7-TH DEGREE SPLINE') IF(IDEGRE.EQ.7)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.8)WRITE(ICOUT,118) 118 FORMAT(' MODEL--8-TH DEGREE SPLINE') IF(IDEGRE.EQ.8)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.9)WRITE(ICOUT,119) 119 FORMAT(' MODEL--9-TH DEGREE SPLINE') IF(IDEGRE.EQ.9)CALL DPWRST('XXX','BUG ') IF(IDEGRE.EQ.10)WRITE(ICOUT,120) 120 FORMAT(' MODEL--10-TH DEGREE SPLINE') IF(IDEGRE.EQ.10)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121)NKNOT 121 FORMAT(' NUMBER OF KNOTS = ',I8) CALL DPWRST('XXX','BUG ') 129 CONTINUE C C ***************************************** C ** STEP 2-- ** C ** CHECK THE INPUT ARGUMENTS N AND K ** C ***************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(1.LE.K.AND.K.LE.KMAX)GOTO159 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE NUMBER OF SPLINE COEFFICIENTS (K = NDEG+1)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IS NON-POSITIVE OR LARGER THAN ALLOWABLE MAX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154)K,KMAX 154 FORMAT(' K,KMAX = ',I8,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 159 CONTINUE C IF(K.LE.N)GOTO169 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,161) 161 FORMAT('***** ERROR IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,162) 162 FORMAT(' THE NUMBER OF SPLINE COEFFICIENTS (K = NDEG+1)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' IS LARGER THAN THE NUMBER OF DATA POINTS (N).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,164)K,N 164 FORMAT(' K,N = ',I8,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 169 CONTINUE C IF(NKNOT.LE.50)GOTO179 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,171) 171 FORMAT('***** ERROR IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,172)NKNOT 172 FORMAT(' THE NUMBER OF KNOTS (= ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,173) 173 FORMAT(' HAS JUST EXCEEDED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,174) 174 FORMAT(' THE ALLOWABLE MAXIMUM (= 50).') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 179 CONTINUE C C **************************************************************** C ** STEP 3-- C ** INSPECT THE WEIGHT VECTOR W--IF ALL ELEMENTS ARE IDENTICAL, C ** THEN RESET ALL ELEMENTS TO 1.0. THIS AVOIDS THE C ** PROBLEM OF AN UNDEFINED EMPTY WEIGHT VECTOR W WHEN C ** IN FACT AN EQUAL WEIGHTING SCHEME IS DESIRED. C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWFLAG=0 WHOLD=W(1) DO600I=1,N IF(W(I).EQ.WHOLD)GOTO600 GOTO850 600 CONTINUE IWFLAG=1 850 CONTINUE IF(IBUGA3.EQ.'ON')THEN IF(IWFLAG.EQ.0)THEN WRITE(ICOUT,851) 851 FORMAT(' UNEQUAL WEIGHTS CASE') CALL DPWRST('XXX','BUG ') ENDIF IF(IWFLAG.EQ.1)THEN WRITE(ICOUT,852) 852 FORMAT(' EQUAL WEIGHTS CASE') CALL DPWRST('XXX','BUG ') ENDIF ENDIF C C ************************************************************** C ** STEP 3.5-- ** C ** CHECK FOR REPLICATION AND IF EXISTENT ** C ** COMPUTE A (MODEL-FREE) REPLICATION STANDARD DEVIATION. ** C ************************************************************** C ISTEPN='3.5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=1 C IREP='NO' REPSD=0.0 REPDF=0.0 IREPDF=REPDF+0.5 RESSD=0.0 RESDF=0.0 ALFCDF=(-999.99) CALL DPREPS(Y,X,AJUNK,AJUNK,AJUNK,AJUNK,N,NUMVAR,DUM1,DUM2, 1IREP,REPSS,REPMS,REPSD,REPDF,NUMSET,IBUGA3,IERROR) IREPDF=REPDF+0.5 C IF(IREP.EQ.'NO')GOTO4800 GOTO4900 C 4800 CONTINUE IF(IPRINT.EQ.'OFF')GOTO4819 WRITE(ICOUT,4811) 4811 FORMAT(' NO REPLICATION CASE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4819 CONTINUE GOTO4999 C 4900 CONTINUE IF(IPRINT.EQ.'OFF')GOTO4929 WRITE(ICOUT,4911) 4911 FORMAT(' REPLICATION CASE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4922)REPSD 4922 FORMAT(' REPLICATION STANDARD DEVIATION = ',D20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4923)IREPDF 4923 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4924)NUMSET 4924 FORMAT(' NUMBER OF DISTINCT SUBSETS = ',2X,I9) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4929 CONTINUE GOTO4999 C 4999 CONTINUE C C **************************************************************** C ** STEP 4-- C ** FORM THE MATRIX X2 (WHICH CORRESPONDS TO THE USUAL X MATRIX C ** IN THE FIT SUBROUTINE BUT IS HERE CALLED X2 BECAUSE OF A C ** CONFLICT DUE TO THE INPUT VECTOR X). C ** B-SPLINES ARE USED HEREIN. C ** REFERENCE--WOLD, TECHNOMETRICS, 1974, PAGE 2. C **************************************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************** C ** STEP 4.1-- ** C ** DETERMINE THE MIN X VALUE. ** C ** DETERMINE THE MAX X VALUE. ** C ********************************** C ISTEPN='4.1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C XMIN=X(1) XMAX=X(1) DO900I=1,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) 900 CONTINUE C C ************************************ C ** STEP 4.2-- ** C ** DEFINE EXTENDED KNOTS ** C ** (ON EITHER END OF THE DATA). ** C ** THE NUMBER OF SUCH KNOTS ** C ** ON EACH SIDE WILL BE ** C ** DEGREE + 1. ** C ************************************ C ISTEPN='4.2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL SORT(XKNOT,NKNOT,XKNOT) C IF(XKNOT(1).EQ.XMIN)GOTO910 GOTO920 910 CONTINUE RANGE=XMAX-XMIN DEL=RANGE/100.0 GOTO930 920 CONTINUE DEL=XKNOT(1)-XMIN DEL=ABS(DEL) 930 CONTINUE C L=0 C IMAX=IDEGRE+1 DO940I=1,IMAX L=L+1 AIREV=IMAX-I+1 EKNOT(L)=XKNOT(1)-AIREV*DEL 940 CONTINUE C DO950I=1,NKNOT L=L+1 EKNOT(L)=XKNOT(I) 950 CONTINUE C IF(XKNOT(NKNOT).EQ.XMAX)GOTO960 GOTO970 960 CONTINUE RANGE=XMAX-XMIN DEL=RANGE/100.0 GOTO980 970 CONTINUE DEL=XMAX-XKNOT(NKNOT) DEL=ABS(DEL) 980 CONTINUE C IMAX=IDEGRE+1 DO990I=1,IMAX L=L+1 AI=I EKNOT(L)=XKNOT(NKNOT)+AI*DEL 990 CONTINUE C NKNOT2=L C IF(IBUGA3.EQ.'OFF')GOTO995 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,991)NKNOT,NKNOT2 991 FORMAT('NKNOT,NKNOT2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,992)XMIN,XKNOT(1),XKNOT(NKNOT),XMAX,DEL 992 FORMAT('XMIN,XKNOT(1),XKNOT(NKNOT),XMAX,DEL = ',5E15.7) CALL DPWRST('XXX','BUG ') DO993I=1,NKNOT2 WRITE(ICOUT,994)I,EKNOT(I) 994 FORMAT('I, EKNOT(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 993 CONTINUE 995 CONTINUE C C *************************************** C ** STEP 4.3-- ** C ** COUNT THE NUMBER OF DATA POINTS ** C ** BETWEEN EACH SET OF KNOTS. ** C ** WRITE OUT THE KNOT VALUES ** C ** AND THE NUMBER OF OBSERVATIONS ** C ** BETWEEN KNOTS. ** C *************************************** C ISTEPN='4.3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO1009 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1005) 1005 FORMAT(' INTERVAL LOWER UPPER NUMBER OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1006) 1006 FORMAT(' NUMBER KNOT KNOT OBSERVATIONS' 1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1007) 1007 FORMAT(' IN INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1008) 1008 FORMAT(' -----------------------------------------------' 1) CALL DPWRST('XXX','BUG ') 1009 CONTINUE C L=1 ISUM=0 DO1100I=1,N IF(X(I).LT.XKNOT(1))ISUM=ISUM+1 1100 CONTINUE IF(IPRINT.EQ.'ON')WRITE(ICOUT,1101)L,XKNOT(L),ISUM 1101 FORMAT(3X,I8,' -INFINITY ',E14.7,I8) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NKNOT.LT.2)GOTO1290 DO1200L=2,NKNOT LM1=L-1 ISUM=0 DO1300I=1,N IF(XKNOT(LM1).LE.X(I).AND.X(I).LT.XKNOT(L))ISUM=ISUM+1 1300 CONTINUE IF(IPRINT.EQ.'ON')WRITE(ICOUT,1301)L,XKNOT(LM1),XKNOT(L),ISUM 1301 FORMAT(3X,I8,E14.7,E14.7,I8) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') 1200 CONTINUE 1290 CONTINUE C L=NKNOT+1 ISUM=0 DO1400I=1,N IF(XKNOT(NKNOT).LE.X(I))ISUM=ISUM+1 1400 CONTINUE IF(IPRINT.EQ.'ON')WRITE(ICOUT,1401)L,XKNOT(NKNOT),ISUM 1401 FORMAT(3X,I8,E14.7 ,' +INFINITY ',I8) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ******************************************* C ** STEP 4.4-- ** C ** FORM THE LINEAR REGRESSION X MATRIX ** C ** (HERE CALLED X2) ** C ** WHICH WILL CONTAIN THE B-SPLINE ** C ** REPRESENTATION OF THE SPLINE ** C ** PROBLEM. ** C ** NOTE THAT K = THE NUMBER ** C ** OF ORIGINAL KNOTS + IDEGRE + 1. ** C ******************************************* C ISTEPN='4.4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1500I=1,N DO1600J=1,K C IJ=(I-1)*K+J Z2(IJ)=0.0 LMAX=IDEGRE+J+1 IF(X(I).LT.EKNOT(J).OR.X(I).GT.EKNOT(LMAX))GOTO1600 C SUM=0.0 DO1700L=J,LMAX IF(X(I).LE.EKNOT(L))GOTO1700 XI=X(I) EKNOL=EKNOT(L) ANUM=(XI-EKNOL)**DEG PROD=1.0 DO1800M=J,LMAX IF(M.EQ.L)GOTO1800 EKNOL=EKNOT(L) EKNOM=EKNOT(M) PROD=PROD*(EKNOL-EKNOM) 1800 CONTINUE ADEN=PROD C RATIO=ANUM/ADEN SUM=SUM+RATIO IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1811)ANUM,ADEN,RATIO,SUM 1811 FORMAT('ANUM,ADEN,RATIO,SUM = ',4E15.8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 1700 CONTINUE IJ=(I-1)*K+J Z2(IJ)=SUM IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1711)I,J,Z2(IJ) 1711 FORMAT('I, J, Z2(IJ) = ',I8,I8,E15.8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C 1600 CONTINUE 1500 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO1990 WRITE(ICOUT,1901) 1901 FORMAT('AFTER STEP 4.4 IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1902) 1902 FORMAT('Z2(.,.) = ') CALL DPWRST('XXX','BUG ') DO1910I=1,N IJMIN=(I-1)*K+1 IJMAX=I*K WRITE(ICOUT,1911)(Z2(IJ),IJ=IJMIN,IJMAX) 1911 FORMAT(8E15.7) CALL DPWRST('XXX','BUG ') 1910 CONTINUE 1990 CONTINUE C CCCCC WRITE(ICOUT,131)Z2(1,1) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,131)Z2(2,2) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,131)Z2(3,3) 131 FORMAT(E15.8) CCCCC CALL DPWRST('XXX','BUG ') C C ******************************* C ** STEP 5-- ** C ** FORM THE X'X MATRIX ** C ** (HERE CALLED XPX) ** C ** THIS WILL HAVE K ROWS ** C ** AND K COLUMNS ** C ** WHERE K = THE NUMBER OF ** C ** ORIGINAL KNOTS + 4. ** C ******************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2100I=1,K DO2200J=1,K DO2300L=1,N LI=(L-1)*K+I V1(L)=Z2(LI) LJ=(L-1)*K+J V2(L)=Z2(LJ) 2300 CONTINUE CALL DOTPRO(V1,V2,N,RESULT) XPX(I,J)=RESULT CCCCC WRITE(ICOUT,111)Z2(1,1) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,133)I,J,N,Z2(I,J),XPX(I,J) CCCCC CALL DPWRST('XXX','BUG ') IJ=(I-1)*K+J 133 FORMAT('I,J,N,Z2(IJ),XPX(I,J) = ',3I6,2E15.8) CCCCC WRITE(ICOUT,133)I,J,N,Z2(1,1),XPX(I,J) CCCCC CALL DPWRST('XXX','BUG ') 2200 CONTINUE 2100 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO2390 WRITE(ICOUT,2301) 2301 FORMAT('AFTER STEP 5 IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2302) 2302 FORMAT('Z2(.,.) = ') CALL DPWRST('XXX','BUG ') DO2310I=1,N JMIN=(I-1)*K+1 JMAX=I*K WRITE(ICOUT,2311)(Z2(IJ),IJ=JMIN,JMAX) 2311 FORMAT(8E15.7) CALL DPWRST('XXX','BUG ') 2310 CONTINUE WRITE(ICOUT,2402) 2402 FORMAT('XPX(.,.) = ') CALL DPWRST('XXX','BUG ') DO2410I=1,N WRITE(ICOUT,2411)(XPX(I,J),J=1,K) 2411 FORMAT(8E15.7) CALL DPWRST('XXX','BUG ') 2410 CONTINUE 2390 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** FORM THE INVERSE MATRIX (X'X)**-1 ** C ** (HERE CALLED SSQ). ** C ** THIS WILL HAVE K ROWS ** C ** AND K COLUMNS ** C ** WHERE K = THE NUMBER OF ** C ** ORIGINAL KNOTS + 4. ** C ***************************************** C ISTEPN='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO2690 DO2610I=1,K DO2620J=1,K WRITE(ICOUT,2621)I,J,XPX(I,J) 2621 FORMAT('I,J,XPX(I,J) = ',I8,I8,E15.8) CALL DPWRST('XXX','BUG ') 2620 CONTINUE 2610 CONTINUE 2690 CONTINUE C CALL MATI50(XPX,K,SSQ) C IF(IBUGA3.EQ.'OFF')GOTO2790 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO2710I=1,K DO2720J=1,K WRITE(ICOUT,2721)I,J,SSQ(I,J) 2721 FORMAT('I,J,SSQ(I,J) = ',I8,I8,E15.8) CALL DPWRST('XXX','BUG ') 2720 CONTINUE 2710 CONTINUE 2790 CONTINUE C C ********************************************* C ** STEP 7-- ** C ** COMPUTE THE K REGRESSION COEFFICIENTS. ** C ********************************************* C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3100I=1,K DO3200L=1,N LI=(L-1)*K+I V1(L)=Z2(LI) V2(L)=Y(L) 3200 CONTINUE CALL DOTPRO(V1,V2,N,XPY(I)) 3100 CONTINUE C DO3600I=1,K DO3700L=1,K V1(L)=SSQ(L,I) V2(L)=XPY(L) 3700 CONTINUE CALL DOTPRO(V1,V2,K,B(I)) 3600 CONTINUE C C ********************************* C ** STEP 8-- ** C ** COMPUTE PREDICTED VALUES. ** C ** COMPUTE RESIDUALS. ** C ********************************* C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO4100I=1,N DO4200L=1,K IL=(I-1)*K+L V1(L)=Z2(IL) V2(L)=B(L) 4200 CONTINUE CALL DOTPRO(V1,V2,K,PRED2(I)) 4100 CONTINUE C DO4600I=1,N RES2(I)=Y(I)-PRED2(I) 4600 CONTINUE C C ******************************************** C ** STEP 9-- ** C ** COMPUTE RESIDUAL STANDARD DEVIATION. ** C ******************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C SUM=0.0 DO5100I=1,N SUM=SUM+RES2(I)**2 5100 CONTINUE RESSS=SUM IRESDF=N-K RESDF=IRESDF IF(IRESDF.LE.0)GOTO5150 RESVAR=RESSS/RESDF RESSD=0.0 IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR) GOTO5190 5150 CONTINUE RESSS=0.0 RESVAR=0.0 RESSD=0.0 5190 CONTINUE C C ************************************** C ** STEP 10-- ** C ** COMPUTE THE COVARIANCE MATRIX ** C ** OF THE COEFFICIENTS. ** C ** COMPUTE THE CORRELATION MATRIX ** C ** OF THE COEFFICIENTS. ** C ************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC DO6100I=1,K CCCCC DO6200J=1,K CCCCC COV(I,J)=SSQ(I,J)*RESSD*RESSD C6200 CONTINUE C6100 CONTINUE C CCCCC DO6600I=1,K CCCCC DO6700J=1,K CCCCC ANUM=SSQ(I,J) CCCCC ADEN=SQRT(SSQ(I,I)*SSQ(J,J)) CCCCC CORR(I,J)=ANUM/ADEN C6700 CONTINUE C6600 CONTINUE C C *************************************************** C ** STEP 11-- ** C ** COMPUTE STANDARD DEVIATION OF COEFFICIENTS. ** C *************************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO7100I=1,K SDB(I)=0.0 IF(SSQ(I,I).GT.0.0)SDB(I)=RESSD*SQRT(SSQ(I,I)) 7100 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO7290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7205)RESSD 7205 FORMAT('S = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO7210I=1,K WRITE(ICOUT,7211)I,B(I),SDB(I) 7211 FORMAT('I, B(I), SDB(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 7210 CONTINUE 7290 CONTINUE C C ****************************************************** C ** STEP 12-- ** C ** COMPUTE COEFFICIENTS FOR THE SPLINE POLYNOMIAL ** C ** OVER EACH INDIVIDUAL REGION (BETWEEN KNOTS). ** C ****************************************************** C ISTEPN='12' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ****************************************** C ** STEP 12.1-- ** C ** LOOP THROUGH THE NKNOT+1 INTERVALS ** C ****************************************** C L3=0 IKNMAX=NKNOT+1 IMAX=IDEGRE+1 DO8100IKN=1,IKNMAX IKN2=IKN+(IDEGRE+1) IKN2M1=IKN2-1 C C ************************************************** C ** STEP 12.2-- ** C ** FOR A GIVEN INTERVAL, ** C ** FORM THE MATRIX OF COEFFICIENTS ** C ** FOR THE POLYNOMIALS IN THE INTERVAL ** C ** AND FOR THE DERIVATIVES OF THE POLYNOMIALS ** C ** WE ARE MERELY EXTRACTING COEFFICIENTS ** C ** OF POLYNOMIALS VIA DIFFERENTIATION. ** C ** EVALUATE THE DERIVATIVES AT THE MIDPOINTS ** C ** BETWEEN KNOTS. ** C ************************************************** C DO8200I=1,IMAX IM1=I-1 DO8300J=1,IMAX A(I,J)=0.0 IF(I.GT.J)GOTO8300 PROD=1.0 IF(IM1.LT.1)GOTO8450 AJ=J DO8400L=1,IM1 AL=L PROD=PROD*(AJ-AL) 8400 CONTINUE C 8450 CONTINUE CIJ=PROD XI=(EKNOT(IKN2)+EKNOT(IKN2M1))/2.0 IF(I.EQ.J)DIJ=1.0 IF(I.NE.J)DIJ=XI**(J-I) A(I,J)=CIJ*DIJ 8300 CONTINUE 8200 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO8290 WRITE(ICOUT,8201)IKN 8201 FORMAT('IN THE MIDDLE OF STEP 12 IN SPLINE. IKN = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8202) 8202 FORMAT('A(.,.) = ') CALL DPWRST('XXX','BUG ') IDEGP1=IDEGRE+1 DO8210I=1,IDEGP1 WRITE(ICOUT,8211)(A(I,J),J=1,IDEGP1) 8211 FORMAT(8E15.7) CALL DPWRST('XXX','BUG ') 8210 CONTINUE 8290 CONTINUE C I=IKN CCCCC XI=EKNOT(IKN2) XI=(EKNOT(IKN2)+EKNOT(IKN2M1))/2.0 C C IF I = 1, MAKE ALL EVALUATIONS BETWEEN KNOT 0 AND KNOT 1; C IF I = 2, MAKE ALL EVALUATIONS BETWEEN KNOT 1 AND KNOT 2; C IF I = 3, MAKE ALL EVALUATIONS BETWEEN KNOT 2 AND KNOT 3; ETC. C C **************************************************************** C ** STEP 12.3-- C ** COMPUTE THE RIGHT SIDE OF THE MATRIX EQUATION. C ** COMPUTE PREDICTED VALUES AND DERIVATIES OF PREDICTED CALUES C ** AT SELECTED POINTS (HALF WAY BETWEEN KNOTS). C **************************************************************** C IROWMX=IDEGRE+1 DO8500IROW=1,IROWMX C C IF IROW = 1, EVALUATE S(X); C IF IROW = 2, EVALUATE S'(X); C IF IROW = 3, EVALUATE S''(X); ETC. C FOR DEGREE K, STOP (INCLUSIVELY) AT THE K-TH DERIVATIVE. C RIGHT(IROW)=0.0 DO8600J=1,K C LMAX=IDEGRE+J+1 IF(XI.LT.EKNOT(J).OR.XI.GT.EKNOT(LMAX))GOTO8600 C SUM=0.0 DO8700L=J,LMAX IF(XI.LE.EKNOT(L))GOTO8700 EKNOL=EKNOT(L) C PROD=1.0 NUMTER=IROW-1 IF(NUMTER.LT.1)GOTO8770 DO8760L2=1,NUMTER AL2=L2 PROD=PROD*(DEG-AL2+1.0) 8760 CONTINUE 8770 CONTINUE CIJ=PROD IPOWER=IDEGRE-(IROW-1) DPOWER=IPOWER DIJ=(XI-EKNOL)**DPOWER ANUM=CIJ*DIJ IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8771)IROW,DEG,IPOWER,XI,CIJ,DIJ,ANUM 8771 FORMAT('XI,IROW,DEG,IPOWER,XI,CIJ,DIJ,ANUM = ',I8,E15.7, 1I8,4E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C CCCCC SUM=0.0 PROD=1.0 DO8800M=J,LMAX IF(M.EQ.L)GOTO8800 EKNOL=EKNOT(L) EKNOM=EKNOT(M) PROD=PROD*(EKNOL-EKNOM) 8800 CONTINUE ADEN=PROD RATIO=ANUM/ADEN SUM=SUM+RATIO IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8811)ANUM,ADEN,RATIO,SUM 8811 FORMAT('ANUM,ADEN,RATIO,SUM = ',4E15.8) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 8700 CONTINUE IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8812)IROW,J,RIGHT(IROW),B(J),SUM 8812 FORMAT('IROW,J,RIGHT(IROW),B(J),SUM = ',2I8,3E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') RIGHT(IROW)=RIGHT(IROW)+B(J)*SUM IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8812)IROW,J,RIGHT(IROW),B(J),SUM IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C 8600 CONTINUE 8500 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO8990 WRITE(ICOUT,8901) 8901 FORMAT('AFTER STEP 12 IN DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8902) 8902 FORMAT('A(.,.), RIGHT(.) = ') CALL DPWRST('XXX','BUG ') DO8910I=1,IDEGP1 WRITE(ICOUT,8911) (A(I,J),J=1,IDEGP1),RIGHT(I) 8911 FORMAT(8E15.7) CALL DPWRST('XXX','BUG ') 8910 CONTINUE 8990 CONTINUE C IDEGP1=IDEGRE+1 CALL BACK50(A,IDEGP1,IDEGP1,RIGHT,BTEMP,IBUGA3) C DO8950I=1,IDEGP1 L3=L3+1 B2(L3)=BTEMP(I) 8950 CONTINUE C 8100 CONTINUE K2=L3 C C ********************************** C ** STEP 13-- ** C ** WRITE OUT THE COEFFICIENTS ** C ********************************** C ISTEPN='13' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IBUGJU='OFF' C IF(IPRINT.EQ.'OFF')GOTO7409 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7400) 7400 FORMAT(' PARAMETER ESTIMATES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7401) 7401 FORMAT(' -----------------------------------------------' 1) CALL DPWRST('XXX','BUG ') 7409 CONTINUE C L=0 IKNMAX=NKNOT+1 JMAX=IDEGRE+1 DO7500IKN=1,IKNMAX DO7600J=1,JMAX L=L+1 JM1=J-1 CALL COENAM(IKN,JM1,IH,IH2,IBUGJU,IERROR) IF(IPRINT.EQ.'ON')WRITE(ICOUT,7611)IKN,IH,IH2,B2(L) 7611 FORMAT(' INTERVAL ',I4,'-- ',A4,A4,' = ',E15.7) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') 7600 CONTINUE IF(IPRINT.EQ.'ON')WRITE(ICOUT,999) IF(IPRINT.EQ.'ON')CALL DPWRST('XXX','BUG ') 7500 CONTINUE C C ********************************************* C ** STEP 14-- ** C ** PRINT OUT GOODNESS OF FIT INFORMATION ** C ********************************************* C 5000 CONTINUE IF(IPRINT.EQ.'OFF')GOTO5129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5125)RESSD 5125 FORMAT(' RESIDUAL STANDARD DEVIATION = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5126)IRESDF 5126 FORMAT(' RESIDUAL DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') 5129 CONTINUE C IF(IREP.EQ.'NO')GOTO4950 IF(IPRINT.EQ.'OFF')GOTO5139 WRITE(ICOUT,5131)REPSD 5131 FORMAT(' REPLICATION STANDARD DEVIATION = ',F20.10) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5133)IREPDF 5133 FORMAT(' REPLICATION DEGREES OF FREEDOM = ',2X,I9) CALL DPWRST('XXX','BUG ') 5139 CONTINUE IFITDF=IRESDF-IREPDF IF(IFITDF.GE.1)GOTO4961 IF(IPRINT.EQ.'OFF')GOTO5149 WRITE(ICOUT,5141) 5141 FORMAT(' LACK OF FIT F TEST CANNOT BE DONE BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5142) 5142 FORMAT(' HAVE ONLY 0 DEGREES OF FREEDOM IN ', 1'NUMERATOR OF F RATIO.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5143) 5143 FORMAT(' THIS HAPPENS WHEN NUMBER OF PARAMETERS ', 1'FITTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5144) 5144 FORMAT(' IS IDENTICAL TO NUMBER OF DISTINCT ', 1'SUBSETS.') CALL DPWRST('XXX','BUG ') 5149 CONTINUE GOTO4950 4961 CONTINUE C FITDF=IFITDF FITSS=RESSS-REPSS FITMS=FITSS/FITDF FSTAT=FITMS/REPMS CALL FCDF(FSTAT,IFITDF,IREPDF,CDF) CDF2=100.0*CDF CCCCC THE FOLLOWING LINE WAS INSERTED MARCH 1988. ALFCDF=CDF IF(IPRINT.EQ.'OFF')GOTO4949 WRITE(ICOUT,4940)FSTAT,CDF2 4940 FORMAT(' LACK OF FIT F RATIO = ',F10.4,' = THE ', 1F8.4,'% POINT OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4945)IFITDF,IREPDF 4945 FORMAT(' F DISTRIBUTION WITH ',I6,' AND ',I6, 1' DEGREES OF FREEDOM') CALL DPWRST('XXX','BUG ') 4949 CONTINUE 4950 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPL2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NKNOT,IDEGRE 9013 FORMAT('N,NKNOT,IDEGRE = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)K2 9014 FORMAT('K2 = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,K2 WRITE(ICOUT,9016)I,B2(I),SDB2(I) 9016 FORMAT('I,B2(I),SDB2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9021)NUMVAR 9021 FORMAT('NUMVAR = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IREP 9022 FORMAT('IREP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)REPSS,REPMS,REPSD,REPDF,NUMSET 9023 FORMAT('REPSS,REPMS,REPSD,REPDF,NUMSET = ',4E15.7,I8) CALL DPWRST('XXX','BUG ') DO9025I=1,N WRITE(ICOUT,9026)I,Y(I),X(I),W(I),PRED2(I),RES2(I) 9026 FORMAT('I,Y(I),X(I),W(I),PRED2(I),RES2(I) = ',I8,5E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPLC(IANS,IWIDTH,ITERCH, 1IANSV,IWIDSV,IBUGGC,IERROR) C C PURPOSE--SEARCH THE VECTOR IANS(.) FOR THE C SEPARATOR CHARACTOR. C REFORM IANS(.) AND IWIDTH BY OMITTING C FROM IANS(.) ALL CHARACTERS C FROM THE FIRST SEPARATOR CHARACTOR TO THE END C (THE SEPARATOR CHARACTOR ITSELF WILL BE OMITTED). C FORM IANSV(.) AND IWIDSV BY C SAVING ALL CHARACTERS IN THE ORIGINAL IANS(.) C AFTER THE FIRST SEPARATOR CHARACTOR. C THE ORIGINAL COMMAND LINE HAS THUS BEEN SPLIT INTO C 2 PARTS WITH THE FIRST SEPARATOR CHARACTOR AS THE PARTITION. C THE FIRST PART WILL REMAIN IN IANS(.); C THE SECOND PART WILL BE SAVED IN IANSV(.). C NOTE--IANS AND IWIDTH ARE BOTH INPUT AND OUTPUT ARGUMENTS. C THE INPUT ARGUMENTS IANS AND IWIDTH BOTH GET CHANGED C DURING THE EXECUTION OF THIS SUBROUTINE. C INPUT ARGUMENTS--IANS (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C ORIGINAL INPUT COMMAND LINE. C --IWIDTH (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE ORIGINAL COMMAND LINE. C --ITERCH (A HOLLERITH VARIABLE WHICH C CONTAINS THE TERMINATORCHARACTER. C OUTPUT ARGUMENTS--IANS (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C FIRST PART OF THE ORIGINAL COMMAND LINE C (UP TO BUT EXCLUDING THE TERMINATORCHARACTOR). C --IWIDTH (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE FIRST PART OF THE ORIGINAL COMMAND LINE. C --IANSV (A HOLLERITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C SECOND PART OF THE COMMAND LINE C (STARTING WITH THE CHARACTER AFTER C THE TERMINATORCHARACTER). C --IWIDSV (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE SECOND PART OF THE ORIGINAL COMMAND LINE. C --IBUGGC (A HOLLERITH VARIABLE C FOR DEBUGGING C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS CHARACTER*4 ITERCH CHARACTER*4 IANSV CHARACTER*4 IBUGGC CHARACTER*4 IERROR C CHARACTER*4 IBLANK C C--------------------------------------------------------------------- C DIMENSION IANS(*) DIMENSION IANSV(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGGC.EQ.'OFF')GOTO109 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('AT THE BEGINNING OF DPSPLC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102)(IANS(I),I=1,IWIDTH) 102 FORMAT('IANS(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)IWIDTH 103 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)ITERCH 104 FORMAT('ITERCH = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,105)(IANSV(I),I=1,IWIDSV) 105 FORMAT('IANSV(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,106)IWIDSV 106 FORMAT('IWIDSV = ',I8) CALL DPWRST('XXX','BUG ') 109 CONTINUE C C ************************************* C ** STEP 1-- ** C ** TRIM THE VALUE OF IWIDTH ** C ** BY IGNORING BLANKS ON THE END ** C ** OF IANS(.) ** C ************************************* C DO150I=1,IWIDTH IREV=IWIDTH-I+1 IF(IANS(IREV).NE.' ')GOTO160 150 CONTINUE IWIDTH=0 IWIDSV=0 GOTO900 160 CONTINUE IWIDTH=IREV C C ************************************* C ** STEP 2-- ** C ** BLANK OUT THE IANSV(.) VECTOR. ** C ** NOTE THAT THIS NEED ONLY BE ** C ** DONE OUT TO IWIDTH ELEMENTS ** C ** SINCE IANSV(.) WILL NEVER ** C ** BE LARGER THAN IANS(.) ** C ************************************* C IBLANK=' ' DO200I=1,IWIDTH IANSV(I)=IBLANK 200 CONTINUE C C ********************************** C ** STEP 3-- ** C ** SCAN THE IANS(.) VECTOR TO ** C ** SEARCH FOR THE TERMINATOR ** C ********************************** C DO300I=1,IWIDTH ILOCSP=I IF(IANS(I).EQ.ITERCH)GOTO390 300 CONTINUE ILOCSP=IWIDTH+1 390 CONTINUE C C *********************************** C ** STEP 4-- ** C ** COMPUTE IANSV(.) AND IWIDSV ** C *********************************** C J=0 IMIN=ILOCSP+1 IMAX=IWIDTH IF(IMIN.GT.IMAX)GOTO450 DO400I=IMIN,IMAX J=J+1 IANSV(J)=IANS(I) 400 CONTINUE 450 CONTINUE IWIDSV=J C C ***************************************************** C ** STEP 5-- ** C ** RECOMPUTE THE VALUE OF IWIDTH-- ** C ** FIRST BY DEFINING IT TO BE ** C ** IMMEDIATELY BEFORE THE TERMINATOR CHARACTOR, ** C ** AND THEN TRIMMING IT FURTHER BY ** C ** IGNORING ANY BLANKS AT THE NEW END OF IANS(.) ** C ***************************************************** C 500 CONTINUE IWIDTH=ILOCSP-1 C DO510I=1,IWIDTH IREV=IWIDTH-I+1 IF(IANS(IREV).NE.' ')GOTO520 510 CONTINUE IREV=0 520 CONTINUE IWIDTH=IREV C C **************** C ** STEP 9-- ** C ** EXIT ** C **************** C 900 CONTINUE IF(IBUGGC.EQ.'OFF')GOTO909 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('AT THE END OF DPSPLC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902)(IANS(I),I=1,IWIDTH) 902 FORMAT('IANS(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903)IWIDTH 903 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,904)ITERCH 904 FORMAT('ITERCH = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905)(IANSV(I),I=1,IWIDSV) 905 FORMAT('IANSV(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,906)IWIDSV 906 FORMAT('IWIDSV = ',I8) CALL DPWRST('XXX','BUG ') 909 CONTINUE C 990 CONTINUE RETURN END SUBROUTINE DPSPLI(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPSPLI(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE LINE TYPES. C THESE ARE LOCATED IN THE VECTOR ISPILI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSL C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISPILI (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C UPDATED --AUGUST 1995. DASH2 BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IHARG2 CHARACTER*4 IDEFSL CHARACTER*4 ISPILI C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION ISPILI(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='LI ' C NUMSPI=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPLI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSL 55 FORMAT('IDEFSL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISPILI(1) 70 FORMAT('ISPILI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISPILI(I) 76 FORMAT('I,ISPILI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE CCCCC IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) CCCCC IF(IHARG(2).EQ.'ALL')GOTO1300 CCCCC IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) CCCCC IF(IHARG(3).EQ.'ALL')GOTO1300 CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW IF(IHARG(2).EQ.'ALL')THEN IHOLD1=IHARG(3) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF IF(IHARG(3).EQ.'ALL')THEN IHOLD1=IHARG(2) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ISPILI(1)=' ' GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG-1 IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I+1 IHOLD1=IHARG(J) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL ISPILI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ISPILI(I) 1276 FORMAT('SPIKE LINE ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL DO1315I=1,NUMSPI ISPILI(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISPILI(I) 1316 FORMAT('ALL SPIKE LINES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPLI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSL 9015 FORMAT('IDEFSL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISPILI(1) 9030 FORMAT('ISPILI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISPILI(I) 9036 FORMAT('I,ISPILI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPMA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IANGLU,MAXNPP, 1CLLIMI,CLWIDT, 1ICONT,NUMHPP,NUMVPP,IMANUF, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IMPSW,IMPNR,IMPNC,IMPCO, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1ALOWFR,ALOWDG, 1IFORSW, 1ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF, 1ICAPSW, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--GENERATE A SCATTER PLOT MATRIX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/9 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C INCLUDE 'DPCOPA.INC' C CHARACTER*4 ICASPL CHARACTER*4 ICAPSW CHARACTER*4 ICASEQ CCCCC CHARACTER*4 ICASAN CHARACTER*4 ICONT CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IANGLU CHARACTER*4 IFORSW C CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGUG CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ C CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISQUAR CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW CHARACTER*4 IREPCH CHARACTER*4 IMPSW CHARACTER*4 IMPSW3 CHARACTER*4 ISPMFZ CHARACTER*4 ISPMTZ CHARACTER*4 ISPMPZ CHARACTER*4 ISPMLZ CHARACTER*4 ISPML2 CHARACTER*4 ISPMXZ CHARACTER*4 ISPMYZ CHARACTER*4 ISPMDZ CHARACTER*4 ISPMZT CHARACTER*4 ISPMZ2 CHARACTER*4 ISPMZ3 CHARACTER*4 ISPMZ4 CHARACTER*4 IPLOTT CHARACTER*4 ISUBSZ C CHARACTER*4 ICT CHARACTER*4 IC2T CHARACTER*4 IHT(5) CHARACTER*4 IH2T(5) CHARACTER*4 ICBT CHARACTER*4 IC2BT CHARACTER*4 IHBT(5) CHARACTER*4 IH2BT(5) CHARACTER*4 ISU2SW(MAXSUB) C CHARACTER*4 IFEED9 C CHARACTER*4 IMANUF C CHARACTER*4 ICHAP2(100) CHARACTER*4 ILINP2(100) CHARACTER*4 IBARS2(100) CHARACTER*4 ISPIS2(100) CHARACTER*4 IFENC2 CHARACTER*4 IPPTB2 CHARACTER*4 IERAS2 CHARACTER*4 ISORS2 CHARACTER*4 IX1TSV CHARACTER*4 IX2TSV CHARACTER*4 IY1TSV CHARACTER*4 IY2TSV CHARACTER*4 IX1ZSV CHARACTER*4 IX2ZSV CHARACTER*4 IY1ZSV CHARACTER*4 IY2ZSV CHARACTER*4 IX1LT2(MAXCH) CHARACTER*4 IX2LT2(MAXCH) CHARACTER*4 IY1LT2(MAXCH) CHARACTER*4 IY2LT2(MAXCH) CHARACTER*4 IY1MNS CHARACTER*4 IY1MXS CHARACTER*4 IY1LJ2 CHARACTER*4 IY1LD2 CHARACTER*4 IY2MNS CHARACTER*4 IY2MXS CHARACTER*4 IX1MNS CHARACTER*4 IX1MXS CHARACTER*4 IX2MNS CHARACTER*4 IX2MXS CHARACTER*4 IX1FSV CHARACTER*4 IX2FSV CHARACTER*4 IY1FSV CHARACTER*4 IY2FSV C CCCCC CHARACTER*4 IWRITE CHARACTER*4 IEMPTY C CHARACTER*80 IFILE5 CHARACTER*12 ISTAT5 CHARACTER*12 IFORM5 CHARACTER*12 IACCE5 CHARACTER*12 IPROT5 CHARACTER*12 ICURS5 CHARACTER*4 IERRF5 CHARACTER*4 IENDF5 CHARACTER*4 IREWI5 INCLUDE 'DPCOF2.INC' C C C MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE C SCATTER PLOT MATRIX CURVE C PARAMETER(MAXY=25) C DIMENSION IVARN1(MAXY) DIMENSION IVARN2(MAXY) DIMENSION ILIS(MAXY) DIMENSION ICOLL(MAXY) C CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ISTEPN CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON------------------------------------------------------ C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)---------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------- C IFOUND='YES' IERROR='NO' C ISUBN1='DPSPMA' ISUBN2=' ' C ICASPL='SPMA' NDONE=0 C C ***************************************** C ** TREAT THE SCATTER PLOT MATRIX CASE ** C ***************************************** C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2 52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ 53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO69 DO61I=1,NUMARG WRITE(ICOUT,62)I,IHARG(I),IARGT(I) 62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE 90 CONTINUE C C ******************************************************* C ** STEP 1-- ** C ** SHIFT COMMAND LINE ARGMENTS ** C ******************************************************* C ISTEPN='1' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PLOT'.AND. 1 IHARG(2).EQ.'MATR')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'YOUD'.AND.IHARG(1).EQ.'MATR'.AND. 1 IHARG(2).EQ.'PLOT')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ISPMPZ=ISPMPT ISPMPT='YOUD' ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'DEX '.AND.IHARG(1).EQ.'INTE'.AND. 1 IHARG2(1).EQ.'RACT'.AND.IHARG(2).EQ.'PLOT')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ISPMPZ=ISPMPT ISPMPT='DEXI' ISPMTZ=ISPMTA ISPMTA='OFF' ELSEIF(NUMARG.GE.4.AND.ICOM.EQ.'DEX '.AND.IHARG(2).EQ.'INTE'.AND. 1 IHARG(3).EQ.'EFFE'.AND.IHARG(4).EQ.'PLOT')THEN ISHIFT=4 ISPMPZ=ISPMPT ISPMPT='DEXS' ISPMTZ=ISPMTA ISPMTA='OFF' ISPMZT=ISPMST ISPMZ2=ISPMS2 ISPMZ3=ISPMS3 ISPMZ4=ISPMS4 ISPMST=IHARG(1) ISPMS2=IHARG2(1) ISPMS3=' ' ISPMS4=' ' CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'DEX '.AND.IHARG(2).EQ.'INTE'.AND. 1 IHARG(3).EQ.'PLOT')THEN ISHIFT=3 ISPMPZ=ISPMPT ISPMPT='DEXS' ISPMTZ=ISPMTA ISPMTA='OFF' ISPMZT=ISPMST ISPMZ2=ISPMS2 ISPMZ3=ISPMS3 ISPMZ4=ISPMS4 ISPMST=IHARG(1) ISPMS2=IHARG2(1) ISPMS3=' ' ISPMS4=' ' CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(NUMARG.GE.5.AND.ICOM.EQ.'DEX '.AND.IHARG(3).EQ.'INTE'.AND. 1 IHARG(4).EQ.'EFFE'.AND.IHARG(5).EQ.'PLOT')THEN ISHIFT=5 ISPMPZ=ISPMPT ISPMPT='DEXS' ISPMTZ=ISPMTA ISPMTA='OFF' ISPMZT=ISPMST ISPMZ2=ISPMS2 ISPMZ3=ISPMS3 ISPMZ4=ISPMS4 ISPMST=IHARG(1) ISPMS2=IHARG2(1) ISPMS3=IHARG(2) ISPMS4=IHARG2(2) CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(NUMARG.GE.4.AND.ICOM.EQ.'DEX '.AND.IHARG(3).EQ.'INTE'.AND. 1 IHARG(4).EQ.'PLOT')THEN ISHIFT=4 ISPMPZ=ISPMPT ISPMPT='DEXS' ISPMTZ=ISPMTA ISPMTA='OFF' ISPMZT=ISPMST ISPMZ2=ISPMS2 ISPMZ3=ISPMS3 ISPMZ4=ISPMS4 ISPMST=IHARG(1) ISPMS2=IHARG2(1) ISPMS3=IHARG(2) ISPMS4=IHARG2(2) CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF C ICOM='PLOT' ICOM2=' ' IFOUND='YES' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINN2=2 MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 11-- ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1180 DO1100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1120 1100 CONTINUE GOTO1180 1110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1190 1120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1190 C 1180 CONTINUE GOTO1190 C 1190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SPMA')GOTO1195 WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1195 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ** IF THE TO FEATURE IS USED IN THE ** C ** ARGUMENT LIST, TRANSLATE THE TO TO ** C ** EXPLICIT VARIABLE NAMES ** C ************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ANDR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXY, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** ALSO CHECK TO ASSURE THAT EACH ** C ** OF THE VARIABLES HAS AT LEAST ** C ** 2 OBSERVATIONS. ** C *************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFLAG=0 DO1300I=1,NUMVAR C IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C NRIGHT=IN(ILOCV) IF(I.EQ.1)THEN NTEMP=NRIGHT ELSE IF(ISPMPT.EQ.'DEXC'.AND.I.EQ.NUMVAR)THEN CONTINUE ELSE IF(NRIGHT.NE.NTEMP)IFLAG=1 ENDIF ENDIF ILIS(I)=ILOCV IF(NRIGHT.GE.MINN2)GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPSPMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' SCATTER PLOT MATRIX WAS TO HAVE BEEN FORMED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)MINN2 1326 FORMAT(' MUST BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE', 1' HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100)) 1329 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1390 CONTINUE C 1300 CONTINUE C C C ****************************************************** C ** STEP 1.4-- ** C ** CHECK THAT VARIABLES HAVE THE SAME NUMBER OF ** C ** ELEMENTS. ** C ****************************************************** C 1400 CONTINUE ISTEPN='1.4' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFLAG.EQ.0)GOTO1490 IF(ISPMPT.EQ.'BIHI')GOTO1490 IF(ISPMPT.EQ.'QQPL')GOTO1490 C 1410 CONTINUE WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPSPMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') DO1417I=1,NUMVAR I2=ILIS(I) WRITE(ICOUT,1416)IVARN1(I),IVARN2(I),IN(I2) 1416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') 1417 CONTINUE WRITE(ICOUT,1420) 1420 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1421)(IANS(I),I=1,MIN(IWIDTH,100)) 1421 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SAVE INITIAL SETTINGS ** C ************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C PXMN2=PXMIN PXMX2=PXMAX PYMN2=PYMIN PYMX2=PYMAX PWXMN2=PWXMIN PWXMX2=PWXMAX PWYMN2=PWYMIN PWYMX2=PWYMAX IF(ISPMFR.EQ.'DEFA')THEN PXMIN=0.0 PXMAX=100.0 PYMIN=0.0 PYMAX=100.0 ENDIF C IFENC2=IFENSW IERAS2=IERASW IPPTB2=IPPTBI ISORS2=ISORSW IX1TSV=IX1TSW IX2TSV=IX2TSW IY1TSV=IY1TSW IY2TSV=IY2TSW IX1ZSV=IX1ZSW IX2ZSV=IX2ZSW IY1ZSV=IY1ZSW IY2ZSV=IY2ZSW PX1LD2=PX1LDS PX2LD2=PX2LDS PY1LD2=PY1LDS PY1LA2=PY1LAN IY1LJ2=IY1LJU IY1LD2=IY1LDI GY1MNS=GY1MIN GY1MXS=GY1MAX GY2MNS=GY2MIN GY2MXS=GY2MAX GX1MNS=GX1MIN GX1MXS=GX1MAX GX2MNS=GX2MIN GX2MXS=GX2MAX IY1MNS=IY1MIN IY1MXS=IY1MAX IY2MNS=IY2MIN IY2MXS=IY2MAX IX1MNS=IX1MIN IX1MXS=IX1MAX IX2MNS=IX2MIN IX2MXS=IX2MAX IX1FSV=IX1FSW IX2FSV=IX2FSW IY1FSV=IY1FSW IY2FSV=IY2FSW PX1ZD2=PX1ZDS PX2ZD2=PX2ZDS PY1ZD2=PY1ZDS PY2ZD2=PY2ZDS DO1495I=1,100 ICHAP2(I)=ICHAPA(I) ILINP2(I)=ILINPA(I) IBARS2(I)=IBARSW(I) ISPIS2(I)=ISPISW(I) 1495 CONTINUE C DO1500I=1,MAXCH IX1LT2(I)=IX1LTE(I) IX2LT2(I)=IX2LTE(I) IY1LT2(I)=IY1LTE(I) IY2LT2(I)=IY2LTE(I) 1500 CONTINUE NCX1L2=NCX1LA NCX2L2=NCX2LA NCY1L2=NCY1LA NCY2L2=NCY2LA C ISPMTZ=ISPMTA ISPMFZ=ISPMFR ISPMPZ=ISPMPT ISPMLZ=ISPMLD ISPML2=ISPMLA ISPMZT=ISPMST ISPMZ2=ISPMS2 ISPMZ3=ISPMS3 ISPMZ4=ISPMS4 ISPMXZ=ISPMXA ISPMYZ=ISPMYA ISPMDZ=ISPMDI IF(ISPMLA.EQ.'BOX'.AND.ISPMPT.EQ.'BIHI')ISPMLA='ON' IF(ISPMFR.EQ.'USER'.AND.ISPMLA.EQ.'BOX')ISPMLA='ON' IF(ISPMFR.EQ.'CONN')ISPMFR='DEFA' IF(ISPMLA.EQ.'BOX ')THEN ISPMLD='ON' CCCCC ISPMXA='BOTT' CCCCC ISPMYA='LEFT' IF(ISPMDI.EQ.'BLAN')ISPMDI='LINE' ENDIF C IOPTN=1 IDX=0 IDY=0 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1ISUBNU, 1ISUBSW, 1ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1ISUBN9, 1ISUBSZ, 1ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1PSPLSL,PSPLSU,PSPLSL,PSPLSU, 1IBUGG2,ISUBRO,IERROR) C IFEED9=IFEEDB C IF(ISPMPT.EQ.'YOUD'.OR.ISPMPT.EQ.'DEXC')THEN ISPMTA='ON' ENDIF C IF(ISPMTA.EQ.'ON')THEN ISHIFT=ILOCQ-1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ISHIFT=NUMVAR-1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DO1509I=1,NUMVAR-1 IHARG(I)=IVARN1(I) IHARG2(I)=IVARN2(I) 1509 CONTINUE NUMVAR=NUMVAR-1 IF(NUMVAR.LT.2)GOTO9000 ENDIF C DO1530I=1,NUMVAR IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C ICOLL(I)=IVALUE(ILOCV) 1530 CONTINUE C IMPSW3=IMPSW IMPCO2=IMPCO IMPNR2=IMPNR IMPNC2=IMPNC IMPSW='ON' IMPCO=1 IMPNR=NUMVAR IMPNC=NUMVAR NPLOTS=IMPNR*IMPNC C IOUNI5=IST5NU IFILE5=IST5NA ISTAT5=IST5ST IFORM5=IST5FO IACCE5=IST5AC IPROT5=IST5PR ICURS5=IST5CS ISUBN0='SPMA' IERRF5='NO' C IREWI5='ON' CALL DPOPFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5, 1IREWI5,ISUBN0,IERRF5,IBUGG3,ISUBRO,IERROR) IF(IERRF5.EQ.'YES')IOUNI5=0 C C C ************************************* C ** STEP 21-- ** C ** GENERATE THE SCATTER PLOTS ** C ************************************* C 2100 CONTINUE ISTEPN='21' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPSPMA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISHIFT=NUMVAR CALL ADJUST(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ISHIFT=2 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHARG(1)=IVARN1(1) IHARG2(1)=IVARN2(1) IHARG(2)=IVARN1(1) IHARG2(2)=IVARN2(1) C IF(ISPMLA.EQ.'BOX')THEN IMPNR=NUMVAR+1 IMPNC=NUMVAR+1 ENDIF C IF(ISPMPT.EQ.'BIHI')THEN ICT='RELA' IC2T='TIVE' IHT(1)='BIHI' IH2T(1)='STOG' NCCOMM=1 ICBT='RELA' IC2BT='TIVE' IHBT(1)='HIST' IH2BT(1)='OGRA' NCCOM2=1 IPLOTT='BIHI' GOTO5000 ENDIF C IF(ISPMPT.EQ.'DEXI')THEN ICT='INTE' IC2T='RACT' NCCOMM=1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' ICBT=ICT IC2BT=IC2T NCCOM2=NCCOMM DO2105II=1,NCCOMM IHBT(II)=IHT(II) IH2BT(II)=IH2T(II) 2105 CONTINUE IPLOTT='DEXI' IRESP=1 GOTO6599 ENDIF IF(ISPMPT.EQ.'DEXS')THEN IF(ISPMST.NE.' ')THEN ICT=ISPMST IC2T=ISPMS2 NCCOMM=0 IF(ISPMS3.NE.' ')THEN IHT(1)=ISPMS3 IH2T(1)=ISPMS4 NCCOMM=1 ENDIF ELSE ICT='MEAN' IC2T=' ' NCCOMM=0 ENDIF NCCOMM=NCCOMM+1 IHT(NCCOMM)='INTE' IH2T(NCCOMM)='RACT' NCCOMM=NCCOMM+1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' ICBT=ICT IC2BT=IC2T NCCOM2=NCCOMM DO2108II=1,NCCOMM IHBT(II)=IHT(II) IH2BT(II)=IH2T(II) 2108 CONTINUE IPLOTT='DEXS' IRESP=1 GOTO6599 ENDIF IF(ISPMPT.EQ.'CROS')THEN IF(ISPMST.NE.' ')THEN ICT='CROS' IC2T='S ' IHT(1)='TABU' IH2T(1)='LATE' IHT(2)=ISPMST IH2T(2)=ISPMS2 NCCOMM=2 IF(ISPMS3.NE.' ')THEN IHT(3)=ISPMS3 IH2T(3)=ISPMS4 NCCOMM=3 ENDIF NCCOMM=NCCOMM+1 IHT(NCCOMM)='PLOT' IH2T(NCCOMM)=' ' ICBT=ISPMST IC2BT=ISPMS2 NCCOM2=0 IF(ISPMS3.NE.' ')THEN IHT(1)=ISPMS3 IH2T(1)=ISPMS4 NCCOM2=1 ENDIF NCCOM2=NCCOM2+1 IHBT(NCCOM2)='PLOT' IH2BT(NCCOM2)=' ' IPLOTT='CRO2' IRESP=1 ELSE ICT='CROS' IC2T='S ' IHT(1)='TABU' IH2T(1)='LATE' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='PLOT' IC2BT=' ' NCCOM2=0 IPLOTT='CROS' IRESP=0 ENDIF GOTO6599 ENDIF IF(ISPMPT.EQ.'DEXC')THEN ICT='DEX ' IC2T=' ' IHT(1)='CONT' IH2T(1)='OUR ' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='DEX ' IC2BT=' ' IHBT(1)='CONT' IH2BT(1)='OUR ' IHBT(2)='PLOT' IH2BT(2)=' ' NCCOM2=2 IPLOTT='DEXC' IRESP=1 GOTO6599 ENDIF IF(ISPMPT.EQ.'QQPL')THEN ICT='QUAN' IC2T='TILE' IHT(1)='QUAN' IH2T(1)='TILE' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='PERC' IC2BT='ENT ' IHBT(1)='POIN' IH2BT(1)=' ' IHBT(2)='PLOT' IH2BT(2)=' ' NCCOM2=2 IPLOTT='QQSP' IPPTBI='UNBI' GOTO5000 ENDIF IF(ISPMPT.EQ.'CORR')THEN ICT='CROS' IC2T='S ' IHT(1)='CORR' IH2T(1)='ELAT' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='AUTO' IC2BT='CORR' IHBT(1)='PLOT' IH2BT(1)=' ' NCCOM2=1 IPLOTT='CCOR' GX1MIN=0.0 IX1MIN='FIXE' GOTO5000 ENDIF IF(ISPMPT.EQ.'SPEC')THEN ICT='CROS' IC2T='S ' IHT(1)='SPEC' IH2T(1)='TRAL' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='SPEC' IC2BT='TRAL' IHBT(1)='PLOT' IH2BT(1)=' ' NCCOM2=1 IPLOTT='CSPE' ISPMFZ=ISPMFR IF(IY1MIN.NE.'FIXE'.OR.IY1MAX.NE.'FIXE'.OR. 1 IY2MIN.NE.'FIXE'.OR.IY2MAX.NE.'FIXE')THEN ISPMFR='USER' ENDIF GOTO5000 ENDIF IF(ISPMPT.EQ.'LAG ')THEN ICT='CROS' IC2T='S ' IHT(1)='LAG ' IH2T(1)=' ' IHT(2)='PLOT' IH2T(2)=' ' NCCOMM=2 ICBT='LAG ' IC2BT=' ' IHBT(1)='PLOT' IH2BT(1)=' ' NCCOM2=1 IPLOTT='CLAG' GOTO5000 ENDIF C C ************************************* C ** SCATTER PLOT CASE ** C ************************************* C IF(ISPMTA.EQ.'ON')THEN ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IHARG(3)=IVARN1(NUMVAR+1) IHARG2(3)=IVARN2(NUMVAR+1) ENDIF C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPSPMA')THEN WRITE(ICOUT,1720)NUMVAR 1720 FORMAT(' NUMVAR = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C NARGT=NUMARG DO3000IROW=1,IMPNR DO4000ITEMP1=1,IMPNC C IF(IROW.LE.NUMVAR)THEN IHARG(1)=IVARN1(IROW) IHARG2(1)=IVARN2(IROW) IDX=IROW ELSE IHARG(1)=IVARN1(NUMVAR) IHARG2(1)=IVARN2(NUMVAR) IDX=NUMVAR ENDIF ICOL=ITEMP1 IEMPTY='NO' IF(ISPMLA.EQ.'BOX')THEN ICOL=ITEMP1-1 IF(ICOL.EQ.0)IEMPTY='YES' IF(IROW.EQ.IMPNR)IEMPTY='YES' ENDIF C IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN IMPCO=IMPCO+1 GOTO4000 ENDIF C IF(ICOL.EQ.0)THEN IHARG(2)=IVARN1(1) IHARG2(2)=IVARN2(1) IDY=1 ELSE IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IDY=ICOL ENDIF C IF(IEMPTY.EQ.'YES')THEN DO3104I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 3104 CONTINUE ENDIF IOPTN=3 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1 ISUBNU,ISUBSW, 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1 ISUBN9,ISUBSZ, 1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1 PSPLSL,PSPLSU,PSPLSL,PSPLSU, 1 IBUGG2,ISUBRO,IERROR) C ICASPL='SPMA' CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1 IMPNR,IMPNC,IROW,ICOL,IROW,ICOL,IPLOT, 1 NPLOTS,NUMVAR, 1 ICHAP2,ILINP2, 1 GY1MNS,GY1MXS,GY2MNS,GY2MXS, 1 GX1MNS,GX1MXS,GX2MNS,GX2MXS, 1 IY1MNS,IY1MXS,IY2MNS,IY2MXS, 1 IX1MNS,IX1MXS,IX2MNS,IX2MXS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 PX1LD2,PX2LD2, 1 IY1LJ2,IY1LD2,PY1LD2,PY1LA2, 1 IX1LT2,IX2LT2,IY1LT2,IY2LT2, 1 NCX1L2,NCX2L2,NCY1L2,NCY2L2, 1 PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL, 1 ISPMLA,ISPMLD,ISPMPT,ISPMFR,ISPMXA,ISPMYA, 1 ISPMDI, 1 ISPMTD,PSPMTD,IVNMEX, 1 IBUGG2,ISUBRO) IERROR='NO' C IF(IEMPTY.EQ.'YES')THEN DO3106I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' ISPISW(I)='OFF' IBARSW(I)='OFF' 3106 CONTINUE CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) GOTO4089 ENDIF C IF(IROW.EQ.ICOL)THEN IF(ISPMDI.NE.'LINE')THEN DO3110I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' ISPISW(I)='OFF' IBARSW(I)='OFF' 3110 CONTINUE ENDIF CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) IF(IERROR.EQ.'YES')GOTO4000 ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 DO3120I=1,100 ICHAPA(I)=ICHAP2(I) ILINPA(I)=ILINP2(I) ISPISW(I)=ISPIS2(I) IBARSW(I)=IBARS2(I) 3120 CONTINUE IERASW='OFF' IF(ISPMDI.EQ.'LINE'.OR.ISPMDI.EQ.'BLAN')GOTO4000 IX1TSW='OFF' IX1ZSW='OFF' IX2TSW='OFF' IX2ZSW='OFF' IY1TSW='OFF' IY1ZSW='OFF' IY2TSW='OFF' IY2ZSW='OFF' C IF(ISPMDI.EQ.'BOXP'.AND.ISPMTA.EQ.'ON')THEN IMPCO=IMPCO-1 DO3130I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' IBARSW(I)='OFF' ISPISW(I)='OFF' 3130 CONTINUE ICHAPA(1)='X' ICHAPA(4)='X' ICHAPA(7)='X' ICHAPA(21)='CIRC' ICHAPA(22)='CIRC' ICHAPA(23)='CIRC' ICHAPA(24)='CIRC' ILINPA(8)='SOLI' ILINPA(13)='SOLI' ILINPA(14)='SOLI' ILINPA(15)='SOLI' ILINPA(16)='SOLI' ILINPA(20)='SOLI' IFENSW='ON' GY1MIN=FY1MNZ GY1MAX=FY1MXZ GY2MIN=GY1MIN GY2MAX=GY1MAX IY1MIN='FIXE' IY1MAX='FIXE' IY2MIN='FIXE' IY2MAX='FIXE' IX1MIN='FLOA' IX1MAX='FLOA' IX2MIN='FLOA' IX2MAX='FLOA' IX1TSW='OFF' IX1ZSW='OFF' IX2TSW='OFF' IX2ZSW='OFF' IY1TSW='OFF' IY1ZSW='OFF' IY2TSW='OFF' IY2ZSW='OFF' ICOM='BOX ' ICOM2=' ' IHARG(1)='PLOT' IHARG2(1)=' ' IHARG(2)=IVARN1(IROW) IHARG2(2)=IVARN2(IROW) IHARG(3)=IVARN1(NUMVAR+1) IHARG2(3)=IVARN2(NUMVAR+1) CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM='PLOT' ICOM2=' ' IHARG(1)=IVARN1(IROW) IHARG2(1)=IVARN2(IROW) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IHARG(3)=IVARN1(NUMVAR+1) IHARG2(3)=IVARN2(NUMVAR+1) GOTO4089 ELSEIF(ISPMDI.EQ.'HIST')THEN IMPCO=IMPCO-1 ICOM='HIST' ICOM2=' ' ISHIFT=1 IF(ISPMTA.EQ.'ON')ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IHARG(1)=IVARN1(IROW) IHARG2(1)=IVARN2(IROW) CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) ISHIFT=1 IF(ISPMTA.EQ.'ON')ISHIFT=2 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM='PLOT' ICOM2=' ' IHARG(1)=IVARN1(ICOL) IHARG2(1)=IVARN2(ICOL) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IF(ISPMTA.EQ.'ON')THEN IHARG(3)=IVARN1(NUMVAR+1) IHARG2(3)=IVARN2(NUMVAR+1) ENDIF IY1MIN='FLOA' IY1MAX='FLOA' IY2MIN='FLOA' IY2MAX='FLOA' IX1MIN='FLOA' IX1MAX='FLOA' IX2MIN='FLOA' IX2MAX='FLOA' GOTO4089 ENDIF GOTO4000 ENDIF C CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) IF(IEMPTY.EQ.'NO')THEN IF( 1 (IROW.NE.ICOL.AND.(ISPX2L.EQ.'CORR'.OR.ISPX2L.EQ.'PCOR')) 1 .OR.ISPX2L.EQ.'PACC'.OR. 1 ISPX2L.EQ.'NACC'.OR.ISPX2L.EQ.'ATP '.OR. 1 ISPX2L.EQ.'AT ') 1 CALL DPSPM3(ICASPL,IOUNI5, 1 IROW,ICOL, 1 PX2LD2,NPLOTP, 1 IFORSW, 1 ISPX2L,ISPX2P,ISPX2S, 1 IHRIGH,IHRIG2,IHWUSE, 1 ISUBN1,ISUBN2,MESSAG, 1 IBUGG2,ISUBRO,IERROR) ENDIF C IF(IERROR.EQ.'YES')THEN IMPCO=IMPCO+1 GOTO4000 ENDIF C 4089 CONTINUE ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 IF(ISPMFI.EQ.'NONE')GOTO4090 IF(IEMPTY.EQ.'YES')GOTO4090 IF(IROW.EQ.ICOL)GOTO4090 IMPCO=IMPCO-1 IF(IMPCO.LE.1)IERASW='OFF' IF(IERROR.EQ.'YES')GOTO4000 C CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP, 1 IROW,ICOL,ICHAP2,ILINP2, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ALOWFR,ALOWDG, 1 IANGLU,MAXNPP,IAND1,IAND2, 1 ISPMFI,ISPMTA, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IREPCH, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4, 1 ISUBRO,IFOUND,IERROR) C 4090 CONTINUE PX1LDS=PX1LD2 GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 IF(IEMPTY.EQ.'YES')THEN DO4907I=1,MAXSUB ISUBSW(I)=ISU2SW(I) 4907 CONTINUE ENDIF DO4098I=1,100 ICHAPA(I)=ICHAP2(I) ILINPA(I)=ILINP2(I) ISPISW(I)=ISPIS2(I) IBARSW(I)=IBARS2(I) 4098 CONTINUE ISHIFT=NARGT-NUMARG IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN ISHIFT=-ISHIFT CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF ICOM='PLOT' ICOM2=' ' IHARG(1)=IVARN1(ICOL) IHARG2(1)=IVARN2(ICOL) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IF(ISPMTA.EQ.'ON')THEN IHARG(3)=IVARN1(NUMVAR+1) IHARG2(3)=IVARN2(NUMVAR+1) ENDIF C 4000 CONTINUE 3000 CONTINUE GOTO8000 C C ********************************************* C ** BIHISTOGRAM CASE ** C ** QUANTILE-QUANTILE CASE ** C ** CROSS-CORRELATION CASE ** C ** CROSS-SPECTRUM CASE ** C ** CROSS-LAG CASE ** C ** FOLLOWING ALL USE A SIMILAR STRUCTURE ** C ********************************************* 5000 CONTINUE NARGT=NUMARG DO5100IROW=1,IMPNR DO5200ITEMP1=1,IMPNC C ICOL=ITEMP1 IEMPTY='NO' IF(ISPMLA.EQ.'BOX')THEN ICOL=ITEMP1-1 IF(ICOL.EQ.0)IEMPTY='YES' IF(IROW.EQ.IMPNR)IEMPTY='YES' ENDIF C IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN IMPCO=IMPCO+1 GOTO5200 ENDIF C IF(IROW.LE.NUMVAR)THEN IHARG(1)=IVARN1(IROW) IHARG2(1)=IVARN2(IROW) IDX=IROW ELSE IHARG(1)=IVARN1(NUMVAR) IHARG2(1)=IVARN2(NUMVAR) IDX=NUMVAR ENDIF IF(ICOL.EQ.0)THEN IHARG(2)=IVARN1(1) IHARG2(2)=IVARN2(1) IDY=1 ELSE IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IDY=ICOL ENDIF C IF(IEMPTY.EQ.'YES')THEN DO5104I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 5104 CONTINUE ENDIF IOPTN=3 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1 ISUBNU,ISUBSW, 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1 ISUBN9,ISUBSZ, 1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1 PSPLSL,PSPLSU,PSPLSL,PSPLSU, 1 IBUGG2,ISUBRO,IERROR) C ICASPL='SPMA' CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1 IMPNR,IMPNC,IROW,ICOL,IROW,ICOL,IPLOT, 1 NPLOTS,NUMVAR, 1 ICHAP2,ILINP2, 1 GY1MNS,GY1MXS,GY2MNS,GY2MXS, 1 GX1MNS,GX1MXS,GX2MNS,GX2MXS, 1 IY1MNS,IY1MXS,IY2MNS,IY2MXS, 1 IX1MNS,IX1MXS,IX2MNS,IX2MXS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 PX1LD2,PX2LD2, 1 IY1LJ2,IY1LD2,PY1LD2,PY1LA2, 1 IX1LT2,IX2LT2,IY1LT2,IY2LT2, 1 NCX1L2,NCX2L2,NCY1L2,NCY2L2, 1 PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL, 1 ISPMLA,ISPMLD,IPLOTT,ISPMFR,ISPMXA,ISPMYA, 1 ISPMDI, 1 ISPMTD,PSPMTD,IVNMEX, 1 IBUGG2,ISUBRO) C IF(IEMPTY.EQ.'YES')THEN DO5106I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' ISPISW(I)='OFF' IBARSW(I)='OFF' 5106 CONTINUE ENDIF IF(IROW.EQ.ICOL)THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ISHIFT=NCCOM2 IF(NCCOM2.GT.0) 1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM=ICBT ICOM2=IC2BT IF(NCCOM2.GT.0)THEN DO5120II=1,NCCOM2 IHARG(II)=IHBT(II) IHARG2(II)=IH2BT(II) 5120 CONTINUE ENDIF ELSE ISHIFT=NCCOMM IF(NCCOMM.GT.0) 1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM=ICT ICOM2=IC2T IF(NCCOMM.GT.0)THEN DO5130II=1,NCCOMM IHARG(II)=IHT(II) IHARG2(II)=IH2T(II) 5130 CONTINUE ENDIF ENDIF CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) IF(IEMPTY.EQ.'NO')THEN IF( 1 ISPX2L.EQ.'PACC'.OR. 1 ISPX2L.EQ.'NACC'.OR.ISPX2L.EQ.'ATP '.OR. 1 ISPX2L.EQ.'AT ') 1 CALL DPSPM3(ICASPL,IOUNI5, 1 IROW,ICOL, 1 PX2LD2,NPLOTP, 1 IFORSW, 1 ISPX2L,ISPX2P,ISPX2S, 1 IHRIGH,IHRIG2,IHWUSE, 1 ISUBN1,ISUBN2,MESSAG, 1 IBUGG2,ISUBRO,IERROR) ENDIF C ISHIFT=NARGT-NUMARG IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN ISHIFT=-ISHIFT CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF ICOM='PLOT' ICOM2=' ' IHARG(1)=IVARN1(ICOL) IHARG2(1)=IVARN2(ICOL) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) C C ************************************************** C ** STEP 25-- ** C ** PLOT THE CURRENT PLOT ** C ************************************************** 5190 CONTINUE ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')THEN WRITE(ICOUT,5107)IMANUF,NUMDEV,IDMANU(1) 5107 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 IF(IEMPTY.EQ.'YES')THEN DO5207I=1,MAXSUB ISUBSW(I)=ISU2SW(I) 5207 CONTINUE ENDIF PX1LDS=PX1LD2 GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 C 5200 CONTINUE 5100 CONTINUE GOTO8000 C C ********************************************* C ** CROSS TABULATE PLOTS CASE ** C ** DEX PLOTS CASE ** C ** DEX INTERACTION PLOTS CASE ** C ** 3D-PLOT PLOTS CASE ** C ** DEX CONTOUR PLOTS CASE ** C ** ALL OF THESE USE SIMILAR STRUCTURE ** C ********************************************* C 6599 CONTINUE C IF(IRESP.EQ.1)THEN ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IHARG(1)=IVARN1(1) IHARG2(1)=IVARN2(1) IMPNR=IMPNR-1 IMPNC=IMPNC-1 ENDIF C IF(ISPMPT.EQ.'DEXC')THEN GY1MIN=-2.0 GY1MAX=2.0 GY2MIN=-2.0 GY2MAX=2.0 IY1MIN='FIXE' IY1MAX='FIXE' IY2MIN='FIXE' IY2MAX='FIXE' GX1MIN=-2.0 GX1MAX=2.0 GX2MIN=-2.0 GX2MAX=2.0 IX1MIN='FIXE' IX1MAX='FIXE' IX2MIN='FIXE' IX2MAX='FIXE' ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IHARG(4)=IVARN1(NUMVAR+1) IHARG2(4)=IVARN2(NUMVAR+1) IF(IERROR.EQ.'YES')GOTO9000 ENDIF C NARGT=NUMARG C NPLOTS=IMPNR NPLOT2=IMPNR*IMPNC DO6600IROW=1,NPLOTS DO6700ITEMP1=1,NPLOTS C ICOL=ITEMP1 IFACT=ICOL+IRESP IEMPTY='NO' IF(ISPMLA.EQ.'BOX')THEN ICOL=ITEMP1-1 IF(ICOL.EQ.0)IEMPTY='YES' IF(IROW.EQ.IMPNR)IEMPTY='YES' ENDIF C IF(IROW.EQ.ICOL.AND.ISPMPT.NE.'DEXC')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF C IFRST=0 IF(IRESP.EQ.1)THEN IHARG(1)=IVARN1(1) IHARG2(1)=IVARN2(1) IFRST=1 ENDIF C IRES=IROW+IRESP IFRST=IFRST+1 IF(IRES.LE.NUMVAR)THEN IHARG(IFRST)=IVARN1(IRES) IHARG2(IFRST)=IVARN2(IRES) ELSE IHARG(IFRST)=IVARN1(NUMVAR) IHARG2(IFRST)=IVARN2(NUMVAR) ENDIF C IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN IMPCO=IMPCO+1 GOTO6700 ENDIF C IF(IROW.NE.ICOL.OR.ISPMPT.EQ.'DEXC')THEN IFRST=IFRST+1 IF(ICOL.EQ.0)THEN IHARG(IFRST)=IVARN1(2) IHARG2(IFRST)=IVARN2(2) ELSE IHARG(IFRST)=IVARN1(IFACT) IHARG2(IFRST)=IVARN2(IFACT) ENDIF ENDIF C IF(ISPMPT.EQ.'DEXC')THEN IFRST=IFRST+1 IHARG(IFRST)=IVARN1(NUMVAR+1) IHARG2(IFRST)=IVARN2(NUMVAR+1) ENDIF C IF(ISPMPT.EQ.'DEXC'.AND.IROW.EQ.ICOL)IEMPTY='YES' IF(IEMPTY.EQ.'YES')THEN DO6604I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 6604 CONTINUE ENDIF IOPTN=3 IDY=1 IDX=2 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1 ISUBNU,ISUBSW, 1 ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1 ISUBN9,ISUBSZ, 1 ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1 PSPLSL,PSPLSU,PSPLSL,PSPLSU, 1 IBUGG2,ISUBRO,IERROR) C CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1 IMPNR,IMPNC,IROW,ICOL,IRES,IFACT,IPLOT, 1 NPLOT2,NUMVAR, 1 ICHAP2,ILINP2, 1 GY1MNS,GY1MXS,GY2MNS,GY2MXS, 1 GX1MNS,GX1MXS,GX2MNS,GX2MXS, 1 IY1MNS,IY1MXS,IY2MNS,IY2MXS, 1 IX1MNS,IX1MXS,IX2MNS,IX2MXS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 PX1LD2,PX2LD2, 1 IY1LJ2,IY1LD2,PY1LD2,PY1LA2, 1 IX1LT2,IX2LT2,IY1LT2,IY2LT2, 1 NCX1L2,NCX2L2,NCY1L2,NCY2L2, 1 PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL, 1 ISPMLA,ISPMLD,IPLOTT,ISPMFR,ISPMXA,ISPMYA, 1 ISPMDI, 1 ISPMTD,PSPMTD,IVNMEX, 1 IBUGG2,ISUBRO) C IF(IEMPTY.EQ.'YES')THEN DO6606I=1,100 ICHAPA(I)='BLAN' ILINPA(I)='BLAN' ISPISW(I)='OFF' IBARSW(I)='OFF' 6606 CONTINUE ENDIF IF(IROW.EQ.ICOL.AND.ISPMPT.EQ.'CROS'.AND.ISPMST.EQ.' ') 1 THEN ILINPA(1)='BLAN' ICHAPA(1)='BLAN' ISPISW(1)='OFF' IBARSW(1)='OFF' ENDIF IF(IROW.EQ.ICOL)THEN ISHIFT=NCCOM2 IF(NCCOM2.GT.0) 1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM=ICBT ICOM2=IC2BT IF(NCCOM2.GT.0)THEN DO6620II=1,NCCOM2 IHARG(II)=IHBT(II) IHARG2(II)=IH2BT(II) 6620 CONTINUE ENDIF ELSE ISHIFT=NCCOMM IF(NCCOMM.GT.0) 1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ICOM=ICT ICOM2=IC2T IF(NCCOMM.GT.0)THEN DO6630II=1,NCCOMM IHARG(II)=IHT(II) IHARG2(II)=IH2T(II) 6630 CONTINUE ENDIF ENDIF IF(IEMPTY.EQ.'YES'.AND.ISPMPT.EQ.'DEXC')THEN ISHIFT=NUMARG-2 IF(ISHIFT.GT.0)THEN CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF ICOM='PLOT' ICOM2=' ' IHARG(1)=IVARN1(IRES) IHARG2(1)=IVARN2(IRES) IHARG(2)=IVARN1(IFACT) IHARG2(2)=IVARN2(IFACT) ENDIF CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL, 1 MAXNPP,ISEED,IBOOSS, 1 IX1TSV,IX2TSV,IY1TSV,IY2TSV, 1 IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1 BARHEF,BARWEF, 1 IRHSTG,IHSTCW, 1 ICAPSW,IFORSW, 1 IAND1,IAND2,ICONT,NUMHPP,NUMVPP, 1 TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IFOUND,IERROR) IF(IEMPTY.EQ.'NO')THEN CALL DPSPM3(ICASPL,IOUNI5, 1 IROW,ICOL, 1 PX2LD2,NPLOTP, 1 IFORSW, 1 ISPX2L,ISPX2P,ISPX2S, 1 IHRIGH,IHRIG2,IHWUSE, 1 ISUBN1,ISUBN2,MESSAG, 1 IBUGG2,ISUBRO,IERROR) ENDIF C ISHIFT=NARGT-NUMARG IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN ISHIFT=-ISHIFT CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF IF(IERROR.EQ.'YES')GOTO6699 ICOM='PLOT' ICOM2=' ' IF(IRESP.EQ.0)THEN IHARG(1)=IVARN1(ICOL) IHARG2(1)=IVARN2(ICOL) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) ELSE IHARG(1)=IVARN1(1) IHARG2(1)=IVARN2(1) IHARG(2)=IVARN1(ICOL) IHARG2(2)=IVARN2(ICOL) IHARG(3)=IVARN1(ICOL) IHARG2(3)=IVARN2(ICOL) ENDIF IF(ISPMPT.EQ.'DEXC')THEN IHARG(4)=IVARN1(NUMVAR+1) IHARG2(4)=IVARN2(NUMVAR+1) ENDIF GOTO6690 C 6690 CONTINUE ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) 6699 CONTINUE IF(IERROR.EQ.'NO')IAND1=IAND2 IF(IEMPTY.EQ.'YES')THEN DO6207I=1,MAXSUB ISUBSW(I)=ISU2SW(I) 6207 CONTINUE ENDIF PX1LDS=PX1LD2 GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 C 6700 CONTINUE 6600 CONTINUE GOTO8000 C C ************************************************** C ** STEP 25-- ** C ** PLOT THE CURRENT PLOT ** C ************************************************** 7890 CONTINUE ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')THEN WRITE(ICOUT,7907)IMANUF,NUMDEV,IDMANU(1) 7907 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 IF(IERROR.EQ.'YES')GOTO7900 PX1LDS=PX1LD2 GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 C 7900 CONTINUE 7800 CONTINUE ISPMFR=ISPMFZ GOTO8000 C C C ************************************************** C ** STEP 28-- ** C ** REINSTATE INITIAL SETTINGS ** C ************************************************** C 8000 CONTINUE 2800 CONTINUE ISTEPN='28' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1) 8807 FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C PWXMIN=PWXMN2 PWXMAX=PWXMX2 PWYMIN=PWYMN2 PWYMAX=PWYMX2 PXMIN=PXMN2 PXMAX=PXMX2 PYMIN=PYMN2 PYMAX=PYMX2 GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS IX1TSW=IX1TSV IX2TSW=IX2TSV IY1TSW=IY1TSV IY2TSW=IY2TSV IX1ZSW=IX1ZSV IX2ZSW=IX2ZSV IY1ZSW=IY1ZSV IY2ZSW=IY2ZSV PX1LDS=PX1LD2 PX2LDS=PX2LD2 PY1LDS=PY1LD2 PY1LAN=PY1LA2 IY1LJU=IY1LJ2 IY1LDI=IY1LD2 PX1ZDS=PX1ZD2 PX2ZDS=PX2ZD2 PY1ZDS=PY1ZD2 PY2ZDS=PY2ZD2 C DO8820I=1,100 ICHAPA(I)=ICHAP2(I) ILINPA(I)=ILINP2(I) IBARSW(I)=IBARS2(I) ISPISW(I)=ISPIS2(I) 8820 CONTINUE C CCCCC IMPSW=IMPSW3 IMPSW='OFF' IMPCO=1 IMPNR=IMPNR2 IMPNC=IMPNC2 C IERASW=IERAS2 IFENSW=IFENC2 ISORSW=ISORS2 IPPTBI=IPPTB2 C DO3500I=1,MAXCH IX1LTE(I)=IX1LT2(I) IX2LTE(I)=IX2LT2(I) IY1LTE(I)=IY1LT2(I) IY2LTE(I)=IY2LT2(I) 3500 CONTINUE NCX1LA=NCX1L2 NCY1LA=NCY1L2 NCY2LA=NCY2L2 C ISPMTA=ISPMTZ ISPMFR=ISPMFZ ISPMPT=ISPMPZ ISPMLD=ISPMLZ ISPMLA=ISPML2 ISPMXA=ISPMXZ ISPMYA=ISPMYZ ISPMDI=ISPMDZ ISPMST=ISPMZT ISPMS2=ISPMZ2 ISPMS3=ISPMZ3 ISPMS4=ISPMZ4 C IOPTN=2 IDX=0 IDY=0 CALL DPSPM4(ICASPL,IOPTN,IDX,IDY, 1ISUBNU, 1ISUBSW, 1ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1ISUBN9, 1ISUBSZ, 1ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1PSPLSL,PSPLSU,PSPLSL,PSPLSU, 1IBUGG2,ISUBRO,IERROR) C IFEEDB=IFEED9 C IENDF5='OFF' IREWI5='ON' IF(IOUNI5.GT.0) 1CALL DPCLFI(IOUNI5,IFILE5,ISTAT5,IFORM5,IACCE5,IPROT5,ICURS5, 1IENDF5,IREWI5,ISUBN0,IERRF5,IBUGG3,ISUBRO,IERROR) IF(IERRF5.EQ.'YES')GOTO9000 C IF(IERROR.EQ.'YES')GOTO9000 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPMA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMARG 9014 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO9029 DO9021I=1,NUMARG WRITE(ICOUT,9022)I,IHARG(I),IARGT(I) 9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9029 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL, 1IMPNR,IMPNC,IROW,ICOL,IRES,IFACT,IPLOT,NPLOTS,NUMVAR, 1ICHAP2,ILINP2, 1GY1MNS,GY1MXS,GY2MNS,GY2MXS, 1GX1MNS,GX1MXS,GX2MNS,GX2MXS, 1IY1MNS,IY1MXS,IY2MNS,IY2MXS, 1IX1MNS,IX1MXS,IX2MNS,IX2MXS, 1IX1TSV,IX2TSV,IY1TSV,IY2TSV,IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV, 1PX1LD2,PX2LD2, 1IY1LJ2,IY1LD2,PY1LD2,PY1LA2, 1IX1LT2,IX2LT2,IY1LT2,IY2LT2, 1NCX1L2,NCX2L2,NCY1L2,NCY2L2, 1PSPXLL,PSPXUL,PSPYLL,PSPYUL,IXLIST, 1ISPMLA,ISPMLD,ISPMPT,ISPMFR,ISPMXA,ISPMYA,ISPMDI, 1ISPMTD,PSPMTD,IVNMEX, 1IBUGG2,ISUBRO) C C PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX. GENERATE C TIC MARKS, TIC MARK LABELS, AXIS LABELS. ALSO C USED BY FACTOR AND CONDITIONING PLOTS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBER 1999. C UPDATED --JUNE 2002. UPDATES FOR PARTIAL REGRESSION C UPDATED --JUNE 2002. UPDATES FOR PARTIAL RESIDUAL C UPDATED --JUNE 2002. UPDATES FOR PARTIAL LEVERAGE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 ICASPL CHARACTER*4 IBUGG2 C CHARACTER*4 ISUBRO C CHARACTER*4 ISPMLA CHARACTER*4 ISPMLD CHARACTER*4 ISPMPT CHARACTER*4 ISPMFR CHARACTER*4 ISPMXA CHARACTER*4 ISPMYA CHARACTER*4 ISPMDI CHARACTER*4 ISPMTD CHARACTER*4 IVNMEX C CHARACTER*105 IXT CHARACTER*52 IX2T CHARACTER*52 IY1T CHARACTER*4 IXLABT(52) CHARACTER*4 IXLAB2(52) CHARACTER*4 IYLABT(52) C CHARACTER*4 ICHAP2(100) CHARACTER*4 ILINP2(100) CHARACTER*4 IY1MNS CHARACTER*4 IY1MXS CHARACTER*4 IY2MNS CHARACTER*4 IY2MXS CHARACTER*4 IY1LJ2 CHARACTER*4 IY1LD2 CHARACTER*4 IX1MNS CHARACTER*4 IX1MXS CHARACTER*4 IX2MNS CHARACTER*4 IX2MXS CHARACTER*4 IX1TSV CHARACTER*4 IX2TSV CHARACTER*4 IY1TSV CHARACTER*4 IY2TSV CHARACTER*4 IX1ZSV CHARACTER*4 IX2ZSV CHARACTER*4 IY1ZSV CHARACTER*4 IY2ZSV CHARACTER*4 IX1LT2(*) CHARACTER*4 IX2LT2(*) CHARACTER*4 IY1LT2(*) CHARACTER*4 IY2LT2(*) C CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C DIMENSION ICOLL(*) DIMENSION IVARN1(*) DIMENSION IVARN2(*) DIMENSION PSPXLL(*) DIMENSION PSPXUL(*) DIMENSION PSPYLL(*) DIMENSION PSPYUL(*) C C-----COMMON------------------------------------------------------ C C-----COMMON VARIABLES (GENERAL)---------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------- C CCCCC IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM1')THEN CCCCC ENDIF C *************************************** C ** STEP 1-- ** C ** TURN EVERYTHING OFF IF DATAPLOT ** C ** DETERMINES AXIS APPEARANCE AND ** C ** RESET DEFAULTS WHERE APPROPRIATE ** C *************************************** C C DO10I=1,52 IXLABT(I)=' ' IXLAB2(I)=' ' IYLABT(I)=' ' 10 CONTINUE DO15I=1,MAXCH IX1LTE(I)=IX1LT2(I) IX2LTE(I)=IX2LT2(I) IY1LTE(I)=IY1LT2(I) IY2LTE(I)=IY2LT2(I) 15 CONTINUE IXT=' ' IX2T=' ' IY1T=' ' NCX1LA=NCX1L2 NCX2LA=NCX2L2 NCY1LA=NCY1L2 NCY2LA=NCY2L2 C IF(ISPMFR.EQ.'DEFA')THEN IX1TSW='OFF' IX1ZSW='OFF' IX2TSW='OFF' IX2ZSW='OFF' IY1TSW='OFF' IY1ZSW='OFF' IY2TSW='OFF' IY2ZSW='OFF' DO105I=1,MAXCH IX1LTE(I)=' ' IX2LTE(I)=' ' IY1LTE(I)=' ' IY2LTE(I)=' ' 105 CONTINUE NCX1LA=0 NCY1LA=0 NCY2LA=0 PX1LDS=PX1LD2 PY1LDS=PY1LD2 PY1LAN=PY1LA2 IY1LJU=IY1LJ2 IY1LDI=IY1LD2 ELSE IX1TSW=IX1TSV IX1ZSW=IX1ZSV IX2TSW=IX2TSV IX2ZSW=IX2ZSV IY1TSW=IY1TSV IY1ZSW=IY1ZSV IY2TSW=IY2TSV IY2ZSW=IY2ZSV ENDIF C DO110I=1,100 ICHAPA(I)=ICHAP2(I) ILINPA(I)=ILINP2(I) 110 CONTINUE C C *************************************** C ** STEP 2-- ** C ** DETERMINE Y AXIS LIMITS (I.E., ** C ** DEFAULT OR USER SPECIFIED) ** C *************************************** C IF(IRES.GT.0)THEN YLOWL=PSPYLL(IRES) YUPPL=PSPYUL(IRES) ELSE YLOWL=CPUMIN YUPPL=CPUMIN ENDIF IF(IXLIST.GT.0)THEN XLOWL=PSPXLL(IXLIST) XUPPL=PSPXUL(IXLIST) ELSE XLOWL=CPUMIN XUPPL=CPUMIN ENDIF IF(YLOWL.NE.CPUMIN.AND.YUPPL.NE.CPUMIN)THEN GY1MIN=YLOWL GY1MAX=YUPPL GY2MIN=YLOWL GY2MAX=YUPPL IY1MIN='FIXE' IY1MAX='FIXE' IY2MIN='FIXE' IY2MAX='FIXE' ELSE IF(IY1MIN.NE.'FIXE')GY1MIN=GY1MNS IF(IY2MIN.NE.'FIXE')GY2MIN=GY2MNS IF(IY1MAX.NE.'FIXE')GY1MAX=GY1MXS IF(IY2MAX.NE.'FIXE')GY2MAX=GY2MXS ENDIF C C *************************************** C ** STEP 3-- ** C ** DETERMINE X AXIS LIMITS (I.E., ** C ** DEFAULT OR USER SPECIFIED) ** C *************************************** C IF(XLOWL.NE.CPUMIN.AND.XUPPL.NE.CPUMIN)THEN GX1MIN=XLOWL GX1MAX=XUPPL GX2MIN=XLOWL GX2MAX=XUPPL IX1MIN='FIXE' IX1MAX='FIXE' IX2MIN='FIXE' IX2MAX='FIXE' ELSE IF(IX1MIN.NE.'FIXE')GX1MIN=GX1MNS IF(IX2MIN.NE.'FIXE')GX2MIN=GX2MNS IF(IX1MAX.NE.'FIXE')GX1MAX=GX1MXS IF(IX2MAX.NE.'FIXE')GX2MAX=GX2MXS ENDIF C C *************************************** C ** STEP 4-- ** C ** DETERMINE TEXT FOR X AND Y AXIS ** C ** LABELS. DO ONCE HERE TO SIMPLIFY** C ** CODE BELOW. ** C *************************************** C IF(ISPMLA.EQ.'OFF')GOTO9000 C IF(ISPMPT.EQ.'PLOT'.OR.ISPMPT.EQ.'QQSP'.OR.ISPMPT.EQ.'CROS')THEN IXT=' ' NX1=-1 IX1DS=1 IX2T=' ' NX2=0 IX2DS=0 IY1T=' ' NY1=-1 ELSEIF(ISPMPT.EQ.'PREG')THEN IXT=' ' IXT='Res: ' NX1=5 NX1=NX1+1 IXT(NX1:NX1+3)=IVARN1(IPLOT+1)(1:4) IXT(NX1+4:NX1+7)=IVARN2(IPLOT+1)(1:4) DO140I=NX1+7,NX1,-1 NXTEMP=I IF(IXT(I:I).NE.' ')GOTO145 140 CONTINUE 145 CONTINUE NX1=NXTEMP NX1=NX1+1 NXTEMP=NX1+14 IXT(NX1:NXTEMP)=' versus other X' NX1=NXTEMP C IX1DS=1 IX2T=' ' NX2=0 IX2DS=0 C NY1=5 IY1T(1:NY1)='Res: ' NY1=NY1+1 IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4) IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4) DO130I=NY1+7,NY1,-1 NYTEMP=I IF(IY1T(I:I).NE.' ')GOTO135 130 CONTINUE 135 CONTINUE NY1=NYTEMP NY1=NY1+1 NYTEMP=NY1+7 IY1T(NY1:NYTEMP)=' Removed' NY1=NYTEMP ELSEIF(ISPMPT.EQ.'PLEV')THEN IXT=' ' NX1=5 IXT(1:NX1)='Index' C IX1DS=1 IX2T=' ' NX2=0 IX2DS=0 C IY1T=' ' IY1T='Partial Leverage: ' NY1=18 NY1=NY1+1 IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4) IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4) DO170I=NY1+7,NY1,-1 NYTEMP=I IF(IY1T(I:I).NE.' ')GOTO175 170 CONTINUE 175 CONTINUE NY1=NYTEMP ELSEIF(ISPMPT.EQ.'PRES'.OR.ISPMPT.EQ.'CCPR')THEN NX1=1 IXT(NX1:NX1+3)=IVARN1(IPLOT+1)(1:4) IXT(NX1+4:NX1+7)=IVARN2(IPLOT+1)(1:4) DO150I=NX1+7,NX1,-1 NXTEMP=I IF(IXT(I:I).NE.' ')GOTO155 150 CONTINUE 155 CONTINUE NX1=NXTEMP C IX1DS=1 IX2T=' ' NX2=0 IX2DS=0 C IY1T=' ' IY1T='Residuals + A' NY1=13 IF(IPLOT.LE.9)THEN NY1=NY1+1 WRITE(IY1T(NY1:NY1),'(I1)')IPLOT ELSE NY1=NY1+1 NYTEMP=NY1+1 WRITE(IY1T(NY1:NYTEMP),'(I2)')IPLOT NY1=NYTEMP ENDIF NY1=NY1+1 IY1T(NY1:NY1)='*' NY1=NY1+1 IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4) IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4) DO160I=NY1+7,NY1,-1 NYTEMP=I IF(IY1T(I:I).NE.' ')GOTO165 160 CONTINUE 165 CONTINUE NY1=NYTEMP ELSEIF(ISPMPT.EQ.'DEXS'.OR.ISPMPT.EQ.'DEXI'.OR. 1 ISPMPT.EQ.'CRO2')THEN IXT=' ' NX1=-2 IX1DS=-1 IX2T=' ' NX2=0 IX2DS=0 IY1T=' ' NY1=-1 ELSEIF(ISPMPT.EQ.'DEXC')THEN IXT=' ' NX1=-2 IX1DS=-1 IX2T=' ' NX2=0 IX2DS=0 IY1T=' ' NY1=0 ELSEIF(ISPMPT.EQ.'BIHI')THEN IXT=' ' NX1=-1 IX1DS=-1 IX2T=' ' NX2=-1 IX2DS=-2 IY1T='Frequency' NY1=9 ELSEIF(ISPMPT.EQ.'CCOR')THEN IXT='Lag' NX1=3 IX1DS=1 IX2T=' ' NX2=-2 IX2DS=-1 IY1T='Correlation' NY1=11 ELSEIF(ISPMPT.EQ.'CSPE')THEN IXT='Frequency' NX1=9 IX1DS=1 IX2T=' ' NX2=-2 IX2DS=-1 IY1T='Power' NY1=5 ELSEIF(ISPMPT.EQ.'CLAG')THEN IXT='I+1' NX1=3 IX1DS=1 IX2T=' ' NX2=-2 IX2DS=-1 IY1T='I' NY1=1 ELSEIF(ISPMPT.EQ.'FPLO'.OR.ISPMPT.EQ.'QQFP'.OR. 1 ISPMPT.EQ.'STAT')THEN IXT=' ' NX1=-1 IX1DS=-1 IX2T=' ' NX2=0 IX2DS=0 IY1T=' ' NY1=-1 ELSEIF(ISPMPT.EQ.'BOXC')THEN IXT='Alpha' NX1=5 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T='Correlation' NY1=11 ELSEIF(ISPMPT.EQ.'CBXC')THEN IXT='Alpha' NX1=5 IX1DS=1 IX2T=' ' NX2=-2 IX2DS=-1 IY1T='Correlation' NY1=11 ELSEIF(ISPMPT.EQ.'HIST')THEN IXT=' ' NX1=-1 IX1DS=-1 IX2T=' ' NX2=0 IX2DS=-1 IY1T='Frequency' NY1=9 ELSEIF(ISPMPT.EQ.'CDEN')THEN IXT=' ' NX1=-1 IX1DS=-1 IX2T=' ' NX2=0 IX2DS=-1 IY1T='Density' NY1=7 ELSEIF(ISPMPT.EQ.'RUNS')THEN IXT='Sequence' NX1=8 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T=' ' NY1=0 ELSEIF(ISPMPT.EQ.'LAG ')THEN IXT='I+1' NX1=3 IX1DS=1 IX2T=' ' NX2=0 IX2DS=-1 IY1T='I' NY1=1 ELSEIF(ISPMPT.EQ.'PERC')THEN IXT='Percentile' NX1=10 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T=' ' NY1=0 ELSEIF(ISPMPT.EQ.'CPER')THEN IXT='Percentile' NX1=10 IX1DS=1 IX2T=' ' NX2=0 IX2DS=-1 IY1T=' ' NY1=-1 ELSEIF(ISPMPT.EQ.'AUTO')THEN IXT='Lag' NX1=3 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T='Frequency' NY1=9 ELSEIF(ISPMPT.EQ.'SPEC')THEN IXT='Frequency' NX1=9 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T='Power' NY1=5 ELSEIF(ISPMPT.EQ.'PROB')THEN IXT='Theoretical' NX1=11 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T='Data' NY1=4 ELSEIF(ISPMPT.EQ.'PPCC')THEN IXT='Parameter' NX1=9 IX1DS=1 IX2T=' ' NX2=-1 IX2DS=-1 IY1T='Correlation' NY1=11 ELSE IXT=' ' NX1=-1 IX1DS=1 IX2T=' ' NX2=0 IX2DS=0 IY1T=' ' ENDIF C C X1LABEL C C 1) IF NX1 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL. C 2) IF NX1 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C BUT NO DEFAULT PROVIDED. C 3) IF NX1 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE C LABEL IF PROVIDED). C 4) IF NX1 = -2, USE: VARIABLE1 * VARIABLE2 (AND SUBSTITUTE C VARIABLE LABEL IF PROVIDED). C IF(ICOL.EQ.0)THEN NCXLA=0 GOTO299 ENDIF C IF(NX1.GE.0)THEN IF(NCX1L2.GT.0)THEN DO210I=1,NCX1L2 IXLABT(I)=IX1LT2(I) 210 CONTINUE NCXLA=NCX1L2 ELSE NCXLA=0 IF(NX1.GT.0)THEN DO220I=1,NX1 IXLABT(I)(1:1)=IXT(I:I) 220 CONTINUE NCXLA=NX1 ENDIF ENDIF ELSEIF(NX1.LT.0)THEN ITEMP=IFACT IF(NX1.EQ.-2 .OR. NX2.EQ.-2)ITEMP=IRES IF(ISPMPT.EQ.'BIHI')ITEMP=IRES ICOLID=ICOLL(ITEMP) IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN DO230I=1,4 IXLABT(I)=IVARN1(ITEMP)(I:I) IXLABT(I+4)=IVARN2(ITEMP)(I:I) 230 CONTINUE NCXLA=8 DO240I=8,1,-1 NCXLA=I IF(IXLABT(I).NE.' ')GOTO245 240 CONTINUE 245 CONTINUE ELSE ILAST=40 DO250I=40,1,-1 IF(IVARLB(ICOLID)(I:I).NE.' ')THEN ILAST=I GOTO259 ENDIF 250 CONTINUE 259 CONTINUE DO270I=1,ILAST IXLABT(I)(1:1)=IVARLB(ICOLID)(I:I) 270 CONTINUE NCXLA=ILAST ENDIF IF(NX1.EQ.-1 .OR. IRES.EQ.IFACT)GOTO299 NCXLA=NCXLA+1 IXLABT(NCXLA)='*' ITEMP=IFACT ICOLID=ICOLL(ITEMP) IF(IVARLB(ICOLID).EQ.' ')THEN DO280I=1,4 IXLABT(NCXLA+I)=IVARN1(ITEMP)(I:I) IXLABT(NCXLA+I+4)=IVARN2(ITEMP)(I:I) 280 CONTINUE ILAST=NCXLA+8 DO285I=ILAST,1,-1 NCXLA=I IF(IXLABT(I).NE.' ')GOTO288 285 CONTINUE 288 CONTINUE ELSE ILAST=40 DO290I=40,1,-1 IF(IVARLB(ICOLID)(I:I).NE.' ')THEN ILAST=I GOTO293 ENDIF 290 CONTINUE 293 CONTINUE DO295I=1,ILAST NCXLA=NCXLA+1 IXLABT(NCXLA)(1:1)=IVARLB(ICOLID)(I:I) 295 CONTINUE ENDIF ENDIF 299 CONTINUE C C X2LABEL C C 1) IF NX2 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL. C 2) IF NX2 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C BUT NO DEFAULT PROVIDED. C 3) IF NX2 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE C LABEL IF PROVIDED). C 4) IF NX2 = -2, USE: VARIABLE1 * VARIABLE2 (AND SUBSTITUTE C VARIABLE LABEL IF PROVIDED). C IF(ICOL.EQ.0)THEN NCXLA2=0 GOTO399 ENDIF C IF((NX1.EQ.-1.AND.NX2.EQ.-1).AND.IRES.EQ.IFACT)THEN NCXLA2=0 GOTO399 ENDIF IF(NX2.GE.0)THEN IF(NCX2L2.GT.0)THEN DO310I=1,NCX2L2 IXLAB2(I)=IX2LT2(I) 310 CONTINUE NCXLA2=NCX2L2 ELSE NCXLA2=0 IF(NX2.GT.0)THEN DO320I=1,NX2 IXLAB2(I)(1:1)=IX2T(I:I) 320 CONTINUE NCXLA2=NX2 ENDIF ENDIF ELSEIF(NX2.LT.0)THEN ITEMP=IFACT IF(NX2.EQ.-2)ITEMP=IRES IF(ISPMPT.EQ.'BIHI')ITEMP=IFACT ICOLID=ICOLL(ITEMP) IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN DO330I=1,4 IXLAB2(I)=IVARN1(ITEMP)(I:I) IXLAB2(I+4)=IVARN2(ITEMP)(I:I) 330 CONTINUE NCXLA2=8 DO340I=8,1,-1 NCXLA2=I IF(IXLAB2(I).NE.' ')GOTO345 340 CONTINUE 345 CONTINUE ELSE ILAST=40 DO350I=40,1,-1 IF(IVARLB(ICOLID)(I:I).NE.' ')THEN ILAST=I GOTO359 ENDIF 350 CONTINUE 359 CONTINUE DO370I=1,ILAST IXLAB2(I)(1:1)=IVARLB(ICOLID)(I:I) 370 CONTINUE NCXLA2=ILAST ENDIF IF(NX2.EQ.-1.OR.IRES.EQ.IFACT)GOTO399 NCXLA2=NCXLA2+1 IXLAB2(NCXLA2)='*' ITEMP=IFACT ICOLID=ICOLL(ITEMP) IF(IVARLB(ICOLID).EQ.' ')THEN DO380I=1,4 IXLAB2(NCXLA2+I)=IVARN1(ITEMP)(I:I) IXLAB2(NCXLA2+I+4)=IVARN2(ITEMP)(I:I) 380 CONTINUE ILAST=NCXLA2+8 DO385I=ILAST,1,-1 NCXLA2=I IF(IXLAB2(I).NE.' ')GOTO388 385 CONTINUE 388 CONTINUE ELSE ILAST=40 DO390I=40,1,-1 IF(IVARLB(ICOLID)(I:I).NE.' ')THEN ILAST=I GOTO393 ENDIF 390 CONTINUE 393 CONTINUE DO395I=1,ILAST NCXLA2=NCXLA2+1 IXLAB2(NCXLA2)(1:1)=IVARLB(ICOLID)(I:I) 395 CONTINUE ENDIF ENDIF 399 CONTINUE C C Y1LABEL C C 1) IF NY1 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL. C 2) IF NY1 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED, C BUT NO DEFAULT PROVIDED. C 3) IF NY1 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE C LABEL IF PROVIDED). C IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IMPNR)THEN NCYLA=0 GOTO599 ENDIF C IF(NY1.GE.0)THEN IF(NCY1L2.GT.0)THEN DO510I=1,NCY1L2 IYLABT(I)=IY1LT2(I) 510 CONTINUE NCYLA=NCY1L2 ELSE NCYLA=0 IF(NY1.GT.0)THEN DO520I=1,NY1 IYLABT(I)(1:1)=IY1T(I:I) 520 CONTINUE NCYLA=NY1 ENDIF ENDIF ELSEIF(NY1.LT.0)THEN ITEMP=IRES IF(ISPMPT.EQ.'DEXI'.OR.ISPMPT.EQ.'DEXS')ITEMP=1 ICOLID=ICOLL(ITEMP) IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN DO530I=1,4 IYLABT(I)=IVARN1(ITEMP)(I:I) IYLABT(I+4)=IVARN2(ITEMP)(I:I) 530 CONTINUE NCYLA=8 DO540I=8,1,-1 NCYLA=I IF(IYLABT(I).NE.' ')GOTO545 540 CONTINUE 545 CONTINUE ELSE ILAST=40 DO560I=40,1,-1 IF(IVARLB(ICOLID)(I:I).NE.' ')THEN ILAST=I GOTO569 ENDIF 560 CONTINUE 569 CONTINUE DO570I=1,ILAST IYLABT(I)(1:1)=IVARLB(ICOLID)(I:I) 570 CONTINUE NCYLA=ILAST ENDIF ENDIF 599 CONTINUE C C *************************************** C ** STEP 5-- ** C ** USER SPECIFIES AXIS ATTRIBUTES, ** C ** BUT DATAPLOT MAY SUBSTITUTE ** C ** VARIABLE NAME (OR LABEL) FOR ** C ** X1LABEL AND Y1LABEL ** C *************************************** C 1000 CONTINUE IF(ISPMFR.EQ.'USER')THEN NCX1LA=NCXLA IF(NCX1LA.LE.0)GOTO1119 DO1110I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1110 CONTINUE 1119 CONTINUE IF(IX1DS.LT.0)PX1LDS=-((PYMAX-PYMIN)-PX1LD2) NCY1LA=NCYLA IF(NCY1LA.LE.0)GOTO1129 DO1120I=1,NCY1LA IY1LTE(I)=IYLABT(I) 1120 CONTINUE 1129 CONTINUE NCX2LA=NCXLA2 IF(NCX2LA.LE.0)GOTO1139 DO1130I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1130 CONTINUE PX2LDS=-((PYMAX-PYMIN)-PX2LD2) IF(IX2DS.EQ.-2)PX2LDS=-PX2LD2 1139 CONTINUE C C ******************************************* C ** STEP 6-- ** C ** DATAPLOT SPECIFIES AXIS ATTRIBUTES ** C ******************************************* C ELSEIF(ISPMFR.EQ.'DEFA')THEN C ITEMP1=MOD(ICOL,2) ITEMP2=MOD(IROW,2) IROWL=IMPNR IF(ISPMLA.EQ.'BOX'.AND.ICASPL.EQ.'SPMA')IROWL=NUMVAR+1 ICOLF=1 IF(ISPMLA.EQ.'BOX')ICOLF=0 C C IX1DS < 0 OR IX2DS < 0 SPECIFIES THAT THIS LABEL IS DRAWN C ON ALL PLOTS (AND DISPLACEMENT IS DISTANCE FROM TOP FRAME) C IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1505I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1505 CONTINUE ENDIF PX1LDS=-((PYMAX-PYMIN)-PX1LD2) ENDIF IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')THEN NCX2LA=NCXLA2 IF(NCX2LA.GT.0)THEN DO1508I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1508 CONTINUE ENDIF PX2LDS=-((PYMAX-PYMIN)-PX2LD2) IF(IX2DS.EQ.-2)PX2LDS=-PX1LD2 ENDIF C IF(ISPMXA.EQ.'YON')GOTO1499 IF(ISPMXA.EQ.'ALTE')THEN IF((IROW.EQ.IROWL.AND.ITEMP1.EQ.1).OR. 1 (ISPMLD.EQ.'OFF'.AND.ITEMP1.EQ.1.AND.IROW.EQ.ICOL).OR. 1 (IROW.EQ.IMPNR-1.AND.ICOL.EQ.IMPNC.AND.ITEMP.EQ.1.AND. 1 NPLOTS.LT.IMPNR*IMPNC).OR. 1 (ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL) 1 )THEN IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1519 IF(ISPMLA.EQ.'BOX'.AND.ITEMP1.EQ.0)GOTO1512 IF(ISPMLA.EQ.'YON')THEN IX1TSW='OFF' IX1ZSW='OFF' ELSE IX1TSW='ON' IX1ZSW='ON' ENDIF IX2TSW='OFF' IX2ZSW='OFF' 1512 CONTINUE IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1 IFLAG2=0 IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1 IF(IFLAG.EQ.0)THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1510I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1510 CONTINUE ENDIF ENDIF IF(IFLAG2.EQ.0)THEN NCX2LA=NCXLA2 IF(NCX2LA.GT.0)THEN DO1516I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1516 CONTINUE ENDIF ENDIF 1519 CONTINUE IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0) ENDIF C IF(IROW.EQ.1.AND.ITEMP1.EQ.0)THEN IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1529 IX1TSW='OFF' IX1ZSW='OFF' IF(ISPMLA.EQ.'YON')THEN IX2TSW='OFF' IX2ZSW='OFF' ELSE IX2TSW='ON' IX2ZSW='ON' ENDIF IFLAG=0 IF(ISPMLA.EQ.'BOX')IFLAG=1 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IX1DS.LT.0)IFLAG=1 IFLAG2=0 IF(IX2DS.LT.0)IFLAG2=1 IF(IFLAG.EQ.0)THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1520I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1520 CONTINUE ENDIF ENDIF IF(IFLAG2.EQ.0)THEN NCX2LA=NCXLA2 IF(NCX2LA.GT.0)THEN DO1526I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1526 CONTINUE ENDIF ENDIF 1529 CONTINUE IF(IX1DS.GT.0)PX1LDS=-((PYMAX-PYMIN)+PX1LD2) IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0) ENDIF ELSEIF(ISPMXA.EQ.'BOTT')THEN IF(IROW.EQ.IROWL.OR.(ISPMLD.EQ.'OFF'.AND.IROW.EQ.ICOL))THEN IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1619 IF(ISPMLA.EQ.'YON')THEN IX1TSW='OFF' IX1ZSW='OFF' ELSE IX1TSW='ON' IX1ZSW='ON' ENDIF IF(ISPMTD.EQ.'STAG'.AND.ITEMP1.EQ.0)PX1ZDS=PSPMTD IX2TSW='OFF' IX2ZSW='OFF' IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1 IFLAG2=0 IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1 IF(IFLAG.EQ.0)THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1610I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1610 CONTINUE ENDIF ENDIF IF(IFLAG2.EQ.0)THEN NCX2LA=NCXLA2 IF(NCX2LA.GT.0)THEN DO1616I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1616 CONTINUE ENDIF ENDIF 1619 CONTINUE IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0) ENDIF ELSEIF(ISPMXA.EQ.'TOP')THEN IF(IROW.EQ.1)THEN IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1719 IX1TSW='OFF' IX1ZSW='OFF' IF(ISPMLA.EQ.'YON')THEN IX2TSW='OFF' IX2ZSW='OFF' ELSE IX2TSW='ON' IX2ZSW='ON' ENDIF IF(ISPMTD.EQ.'STAG'.AND.ITEMP1.EQ.0)PX2ZDS=PSPMTD IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IX1DS.LT.0)IFLAG=1 IF(ISPMLA.EQ.'BOX')GOTO1719 IFLAG2=0 IF(IX2DS.LT.0)IFLAG2=1 IF(IFLAG.EQ.0)THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1710I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1710 CONTINUE ENDIF ENDIF IF(IFLAG2.EQ.0)THEN NCX2LA=NCXLA2 IF(NCX2LA.GT.0)THEN DO1716I=1,NCX2LA IX2LTE(I)=IXLAB2(I) 1716 CONTINUE ENDIF ENDIF 1719 CONTINUE PX1LDS=-(100.0+PX1LD2) ENDIF C IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL.AND.ICOL.GT.0)THEN IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1 IFLAG2=0 IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1 IF(IFLAG.EQ.0)THEN NCX1LA=NCXLA IF(NCX1LA.GT.0)THEN DO1720I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1720 CONTINUE ENDIF ENDIF PX1LDS=-(100.0+PX1LD2) ENDIF ENDIF C 1499 CONTINUE IF(ISPMYA.EQ.'OFF')GOTO1699 IF(ISPMYA.EQ.'ALTE')THEN IF((ICOL.EQ.IMPNC.AND.ITEMP2.EQ.0).OR. 1 (ISPMLA.EQ.'BOX'.AND.ICOL.EQ.IMPNC-1.AND.ITEMP2.EQ.0).OR. 1 (IPLOT.EQ.NPLOTS.AND.ITEMP2.EQ.0))THEN IY1TSW='OFF' IY1ZSW='OFF' IF(ISPMLA.EQ.'XON')THEN IY2TSW='OFF' IY2ZSW='OFF' ELSE IY2TSW='ON' IY2ZSW='ON' ENDIF IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(ISPMLA.EQ.'BOX')IFLAG=1 IF(IFLAG.EQ.0)THEN NCY2LA=NCYLA IF(NCY2LA.LE.0)GOTO1539 DO1530I=1,NCY2LA IY2LTE(I)=IYLABT(I) 1530 CONTINUE 1539 CONTINUE ENDIF ENDIF C IF(ICOL.EQ.ICOLF.AND.ITEMP2.EQ.1.OR. 1 (ISPMLA.EQ.'BOX'.AND.ICOL.EQ.ICOLF).OR. 1 (ISPMLD.EQ.'OFF'.AND.ITEMP2.EQ.1.AND.IROW.EQ.ICOL))THEN IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1549 IF(ISPMLA.EQ.'BOX'.AND.ITEMP2.EQ.0)GOTO1542 IF(ISPMLA.EQ.'XON')THEN IY1TSW='OFF' IY1ZSW='OFF' ELSE IY1TSW='ON' IY1ZSW='ON' ENDIF IY2TSW='OFF' IY2ZSW='OFF' 1542 CONTINUE IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IFLAG.EQ.0)THEN NCY1LA=NCYLA IF(NCY1LA.LE.0)GOTO1549 DO1540I=1,NCY1LA IY1LTE(I)=IYLABT(I) 1540 CONTINUE ENDIF IF(ISPMLA.EQ.'BOX')THEN IY1LJU='CENT' PY1LDS=-((PXMAX-PXMIN)/2.0) PY1LAN=0.0 IY1LDI='HORI' ENDIF 1549 CONTINUE ENDIF ELSEIF(ISPMYA.EQ.'LEFT')THEN IF(ICOL.EQ.ICOLF.OR.(ISPMLD.EQ.'OFF'.AND.IROW.EQ.ICOL))THEN IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1649 IF(ISPMLA.EQ.'XON')THEN IY1TSW='OFF' IY1ZSW='OFF' ELSE IY1TSW='ON' IY1ZSW='ON' ENDIF IF(ISPMTD.EQ.'STAG'.AND.ITEMP2.EQ.0)PY1ZDS=PSPMTD IY2TSW='OFF' IY2ZSW='OFF' IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IFLAG.EQ.0)THEN NCY1LA=NCYLA IF(NCY1LA.LE.0)GOTO1649 DO1640I=1,NCY1LA IY1LTE(I)=IYLABT(I) 1640 CONTINUE ENDIF 1649 CONTINUE IF(ISPMLA.EQ.'BOX')THEN IY1LJU='CENT' PY1LDS=-((PXMAX-PXMIN)/2.0) PY1LAN=0.0 IY1LDI='HORI' ENDIF ENDIF ELSEIF(ISPMYA.EQ.'RIGH')THEN IF(ICOL.EQ.IMPNC)THEN IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1839 IY1TSW='OFF' IY1ZSW='OFF' IF(ISPMLA.EQ.'XON')THEN IY2TSW='OFF' IY2ZSW='OFF' ELSE IY2TSW='ON' IY2ZSW='ON' ENDIF IF(ISPMTD.EQ.'STAG'.AND.ITEMP2.EQ.0)PY2ZDS=PSPMTD IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(ISPMLA.EQ.'BOX')IFLAG=1 IF(IFLAG.EQ.0)THEN NCY2LA=NCYLA IF(NCY2LA.LE.0)GOTO1839 DO1830I=1,NCY2LA IY2LTE(I)=IYLABT(I) 1830 CONTINUE ENDIF 1839 CONTINUE ENDIF C IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.ICOLF.AND.IROW.LT.IROWL)THEN IFLAG=0 IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN')IFLAG=1 IF(IFLAG.EQ.0)THEN NCY1LA=NCYLA IF(NCY1LA.LE.0)GOTO1849 DO1840I=1,NCY1LA IY1LTE(I)=IYLABT(I) 1840 CONTINUE ENDIF 1849 CONTINUE ENDIF ENDIF C IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND. 1 ISPMDI.EQ.'BLAN'.AND.IROW.EQ.ICOL)THEN NCX1LA=NCXLA NCY1LA=0 NCY2LA=0 IF(NCX1LA.LE.0)GOTO1919 DO1910I=1,NCX1LA IX1LTE(I)=IXLABT(I) 1910 CONTINUE 1919 CONTINUE PX1LDS=-((PYMAX-PYMIN)/2.0) ENDIF 1699 CONTINUE C ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SPM1')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPM1--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP, 1IROW,ICOL,ICHAP2,ILINP2, 1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT, 1ALOWFR,ALOWDG, 1IANGLU,MAXNPP,IAND1,IAND2, 1ISPMFI,ISPMTA, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IMPSW,IMPNR,IMPNC,IMPCO, 1IREPCH, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4, 1ISUBRO,IFOUND,IERROR) C C PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX. GENERATE C OVERLAID SMOOTH OR FITTED CURVE ON PLOT. ALSO C USED BY FACTOR AND CONDITIONING PLOTS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBERR 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C CHARACTER*4 ICASPL CHARACTER*4 ICASAN CHARACTER*4 IANGLU CHARACTER*4 IMPSW CHARACTER*4 IREPCH CHARACTER*4 ISQUAR CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IFTEXP CHARACTER*4 IFTORD CHARACTER*4 IOPTME CHARACTER*4 IOPTHE C CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGUG CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ C CHARACTER*4 ICONT CHARACTER*4 IWRITE CHARACTER*4 IFOUND CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISPMFI CHARACTER*4 ISPMTA C CHARACTER*4 ICAPSW CHARACTER*4 ICASP2 CHARACTER*4 ICOMT CHARACTER*4 ICOM2T C CHARACTER*4 ICHAP2(100) CHARACTER*4 ICH2PO(100) CHARACTER*4 ICH2FO(100) CHARACTER*4 ICH2CA(100) CHARACTER*4 ICH2JU(100) CHARACTER*4 ICH2DI(100) CHARACTER*4 ICH2FI(100) CHARACTER*4 ICH2CO(100) REAL PCH2HE(100) REAL PCH2WI(100) REAL PCH2VG(100) REAL PCH2HG(100) REAL PCH2HO(100) REAL PCH2VO(100) REAL ACH2AN(100) C CHARACTER*4 ILINP2(100) CHARACTER*4 ILI2CO(100) REAL PLI2TH(100) C CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C DIMENSION ICOLL(*) DIMENSION IVARN1(*) DIMENSION IVARN2(*) C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C CHARACTER*4 IY1MNS CHARACTER*4 IY1MXS CHARACTER*4 IY2MNS CHARACTER*4 IY2MXS CHARACTER*4 IX1MNS CHARACTER*4 IX1MXS CHARACTER*4 IX2MNS CHARACTER*4 IX2MXS C PARAMETER (MAXART=20) CHARACTER*4 ITHARG CHARACTER*4 ITHAR2 CHARACTER*4 ITARGT CHARACTER*4 ISU2SW(MAXSUB) CHARACTER*4 IANST DIMENSION ITHARG(MAXART) DIMENSION ITHAR2(MAXART) DIMENSION ITARG(MAXART) DIMENSION TARG(MAXART) DIMENSION ITARGT(MAXART) DIMENSION IANST(MAXSTR) C C-----COMMON VARIABLES (GENERAL)---------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------- C CCCCC IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM2')THEN CCCCC ENDIF C CCCCC NOTE: CURRENTLY, LOWESS (AND OTHER) TYPE FITS ONLY CCCCC USED FOR "PLOT Y X" TYPE COMMANDS. NOTE THAT CCCCC SOME OF THE LOGIC OF THIS ROUTINE WILL NEED TO CCCCC BE UPDATED IF THIS CAPABILITY IS EXTENDED TO CCCCC ADDITIONAL PLOT TYPES (I.E., SOME CARE NEEDS TO BE CCCCC TAKEN TO ENSURE THAT SUBSET CLAUSES ARE CARRIED CCCCC ALONG PROPERLY). C C *************************************** C ** STEP 1-- ** C *************************************** C ICAPSW='OFF' IERROR='NO' C C PARTIAL REGRESSION, PARTIAL RESIDUAL, AND PARTIAL C LEVERAGE PLOT ALLOW FITTED CURVE TO OVERLAID. C IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR. 1 ICASPL.EQ.'PLEV')THEN ICASP2='PLOT' ELSE IF(ICOM.NE.'PLOT')GOTO9000 ENDIF C ICOMT=ICOM ICOM2T=ICOM2 ICASP2=ICASPL NUMART=NUMARG DO100I=1,NUMARG ITHARG(I)=IHARG(I) ITHAR2(I)=IHARG2(I) ITARG(I)=IARG(I) TARG(I)=ARG(I) ITARGT(I)=IARGT(I) 100 CONTINUE DO102I=1,MAXSTR IANST(I)=IANS(I) 102 CONTINUE IWIDT=IWIDTH DO105I=1,MAXSUB ISU2SW(I)=ISUBSW(I) ISUBSW(I)='OFF' 105 CONTINUE DO110I=1,100 ILI2CO(I)=ILINCO(I) PLI2TH(I)=PLINTH(I) ICH2PO(I)=ICHAPO(I) ICH2FO(I)=ICHAFO(I) ICH2CA(I)=ICHACA(I) ICH2JU(I)=ICHAJU(I) ICH2DI(I)=ICHADI(I) ICH2FI(I)=ICHAFI(I) ICH2CO(I)=ICHACO(I) PCH2HE(I)=PCHAHE(I) PCH2WI(I)=PCHAWI(I) PCH2VG(I)=PCHAVG(I) PCH2HG(I)=PCHAHG(I) PCH2HO(I)=PCHAHO(I) PCH2VO(I)=PCHAVO(I) ACH2AN(I)=ACHAAN(I) 110 CONTINUE C IF(ISPMTA.EQ.'ON')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ITAGCO=3 DO119I=1,NUMARG IF(I.EQ.ITAGCO)GOTO119 IHARG(I)=ITHARG(I) IHARG2(I)=ITHAR2(I) IARG(I)=ITARG(I) ARG(I)=TARG(I) IARGT(I)=ITARGT(I) 119 CONTINUE ENDIF C GY1MNS=GY1MIN GY1MXS=GY1MAX GY2MNS=GY2MIN GY2MXS=GY2MAX GX1MNS=GX1MIN GX1MXS=GX1MAX GX2MNS=GX2MIN GX2MXS=GX2MAX IY1MNS=IY1MIN IY1MXS=IY1MAX IY2MNS=IY2MIN IY2MXS=IY2MAX IX1MNS=IX1MIN IX1MXS=IX1MAX IX2MNS=IX2MIN IX2MXS=IX2MAX C GY1MIN=FY1MNZ GY1MAX=FY1MXZ GY2MIN=GY1MIN GY2MAX=GY1MAX GX1MIN=FX1MNZ GX1MAX=FX1MXZ GX2MIN=GX1MIN GX2MAX=GX1MAX IY1MIN='FIXE' IY1MAX='FIXE' IY2MIN='FIXE' IY2MAX='FIXE' IX1MIN='FIXE' IX1MAX='FIXE' IX2MIN='FIXE' IX2MAX='FIXE' IX1TSW='OFF' IX1ZSW='OFF' IX2TSW='OFF' IX2ZSW='OFF' IY1TSW='OFF' IY1ZSW='OFF' IY2TSW='OFF' IY2ZSW='OFF' C IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR. 1 ICASPL.EQ.'PLEV')THEN NUMARG=2 ICOM='PLOT' ICOM2=' ' IHARG(1)='YPLO' IHARG2(1)='T ' IHARG(2)='XPLO' IHARG2(2)='T ' ENDIF C IF(ISPMFI.EQ.'LOES')THEN ICOM='LOWE' ICOM2='SS ' CALL DPLOW(ALOWFR,ALOWDG, 1 TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, 1 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) ELSEIF(ISPMFI.EQ.'LINE')THEN ICOM='FIT ' ICOM2=' ' ICASAN='FIT' CALL DPFIT(ICAPSW,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) ELSEIF(ISPMFI.EQ.'QUAD')THEN ISHIFT=1 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOM='QUAD' ICOM2='RATI' IHARG(1)='FIT ' IHARG2(1)=' ' ICASAN='FIT' CALL DPFIT(ICAPSW,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) ELSEIF(ISPMFI.EQ.'SMOO')THEN ICOM='SMOO' ICOM2='TH ' ICASAN='SMOO' CALL DPSMOO(IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) ENDIF C ICOM='PLOT' ICOM2=' ' ISHIFT=1 IF(ISHIFT.GT.0)THEN CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ELSEIF(ISHIFT.LT.0)THEN CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGG2,IERROR) ENDIF IF(ISPMTA.EQ.'OFF')THEN ITEMP=2 ELSE IWRITE='OFF' CALL MAXIM(TAGPLO,NPLOTP,IWRITE,XMAX,IBUGG3,IERROR) ITEMP=1+INT(XMAX) IF(ITEMP.LT.1.OR.ITEMP.GT.100)ITEMP=2 ENDIF ICHAPA(1)=ICHAP2(ITEMP) ILINPA(1)=ILINP2(ITEMP) ILINCO(1)=ILI2CO(ITEMP) PLINTH(1)=PLI2TH(ITEMP) ICHAPO(1)=ICH2PO(ITEMP) ICHAFO(1)=ICH2FO(ITEMP) ICHACA(1)=ICH2CA(ITEMP) ICHAJU(1)=ICH2JU(ITEMP) ICHADI(1)=ICH2DI(ITEMP) ICHAFI(1)=ICH2FI(ITEMP) ICHACO(1)=ICH2CO(ITEMP) PCHAHE(1)=PCH2HE(ITEMP) PCHAWI(1)=PCH2WI(ITEMP) PCHAVG(1)=PCH2VG(ITEMP) PCHAHG(1)=PCH2HG(ITEMP) PCHAHO(1)=PCH2HO(ITEMP) PCHAVO(1)=PCH2VO(ITEMP) ACHAAN(1)=ACH2AN(ITEMP) IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR. 1 ICASPL.EQ.'PLEV')THEN NUMARG=3 ICOM='LET ' ICOM2=' ' IHARG(1)='XTEM' IHARG2(1)='P ' IHARG(2)='= ' IHARG2(2)=' ' IHARG(3)='XPLO' IHARG2(3)='T ' IANS(1)='L ' IANS(2)='E ' IANS(3)='T ' IANS(4)=' ' IANS(5)='X ' IANS(6)='T ' IANS(7)='E ' IANS(8)='M ' IANS(9)='P ' IANS(10)=' ' IANS(11)='= ' IANS(12)=' ' IANS(13)='X ' IANS(14)='P ' IANS(15)='L ' IANS(16)='O ' IANS(17)='T ' IWIDTH=17 CALL DPLET(IANGLU,ISEED,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ, 1 TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, 1 IFTEXP,IFTORD, 1 ROOTAC,OPTACC,IOPTME,IOPTHE, 1 ISUBRO,IFOUND,IERROR) C IF(IERROR.EQ.'YES')GOTO9000 ICOM='PLOT' ICOM2=' ' IHARG(1)='PRED' IHARG2(1)=' ' IHARG(2)='VS ' IHARG2(2)=' ' IHARG(3)='XTEM' IHARG2(3)='P ' ELSE IHARG(1)='PRED' IHARG2(1)=' ' IHARG(2)='VS ' IHARG2(2)=' ' IHARG(3)=IVARN1(ICOL) IHARG2(3)=IVARN2(ICOL) ENDIF CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1 IANGLU,MAXNPP, 1 IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) ICASPL=ICASP2 C C C ************************************************** C ** STEP 25-- ** C ** PLOT THE CURRENT PLOT ** C ************************************************** C ICONT=IDCONT(1) NUMHPP=IDNHPP(1) IMPARG=2 CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1 XMATN,YMATN,XMITN,YMITN, 1 ISQUAR, 1 IVGMSW,IHGMSW, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1 IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1 YPLOT,XPLOT,X2PLOT,TAGPLO, 1 IMPSW,IMPNR,IMPNC,IMPCO, 1 IMPARG, 1 PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1 MAXCOL, 1 DSIZE,DSYMB,DCOLOR,DFILL, 1 ICAPSW, 1 IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1 IERROR) IF(IERROR.EQ.'NO')IAND1=IAND2 IERROR='NO' C GX1MIN=GX1MNS GX1MAX=GX1MXS GX2MIN=GX2MNS GX2MAX=GX2MXS GY1MIN=GY1MNS GY1MAX=GY1MXS GY2MIN=GY2MNS GY2MAX=GY2MXS IX1MIN=IX1MNS IX1MAX=IX1MXS IX2MIN=IX2MNS IX2MAX=IX2MXS IY1MIN=IY1MNS IY1MAX=IY1MXS IY2MIN=IY2MNS IY2MAX=IY2MXS C NUMARG=NUMART ICOM=ICOMT ICOM2=ICOM2T DO900I=1,NUMARG IHARG(I)=ITHARG(I) IHARG2(I)=ITHAR2(I) IARG(I)=ITARG(I) ARG(I)=TARG(I) IARGT(I)=ITARGT(I) 900 CONTINUE DO902I=1,MAXSTR IANS(I)=IANST(I) 902 CONTINUE IWIDTH=IWIDT DO905I=1,MAXSUB ISUBSW(I)=ISU2SW(I) 905 CONTINUE DO910I=1,100 ILINCO(I)=ILI2CO(I) PLINTH(I)=PLI2TH(I) ICHAPO(I)=ICH2PO(I) ICHAFO(I)=ICH2FO(I) ICHACA(I)=ICH2CA(I) ICHAJU(I)=ICH2JU(I) ICHADI(I)=ICH2DI(I) ICHAFI(I)=ICH2FI(I) ICHACO(I)=ICH2CO(I) PCHAHE(I)=PCH2HE(I) PCHAWI(I)=PCH2WI(I) PCHAVG(I)=PCH2VG(I) PCHAHG(I)=PCH2HG(I) PCHAHO(I)=PCH2HO(I) PCHAVO(I)=PCH2VO(I) ACHAAN(I)=ACH2AN(I) 910 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SPM2')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPM2--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPM3(ICASPL,IOUNI5, 1IROW,ICOL, 1PX2LD2,NPLOTP, 1IFORSW, 1ISPX2L,ISPX2P,ISPX2S, 1IHRIGH,IHRIG2,IHWUSE, 1ISUBN1,ISUBN2,MESSAG, 1IBUGG2,ISUBRO,IERROR) C C PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX. GENERATE C AN X2LABEL BASED ON CORRELATION, EFFECT SIZE, OR C NUMBER OF DEFECTIVES. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBERR 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IBUGG2 CHARACTER*4 ICASPL C CHARACTER*4 IFORSW CHARACTER*4 IWRITE CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISPX2L CHARACTER*16 ISPX2P CHARACTER*16 ISPX2S C CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHWUSE CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 MESSAG C C-----COMMON VARIABLES (GENERAL)---------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------- C CCCCC IF(ISUBRO.EQ.'SPM3')THEN CCCCC ENDIF C *************************************** C ** STEP 1-- ** C *************************************** C IERROR='NO' IF(ISPX2L.EQ.'OFF ')GOTO9000 IF(ISPX2L.EQ.'NONE')GOTO9000 IF(ISPX2L.EQ.'BLAN')GOTO9000 C ALOWH=0.0 ACORR=0.0 NACC=0 NREJ=0 C IHRIGH='ALOW' IHRIG2='HIGH' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'NO')ALOWH=VALUE(ILOCP) C IHRIGH='PLOT' IHRIG2='CORR' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'NO')ACORR=VALUE(ILOCP) C IHRIGH='NACC' IHRIG2='EPT ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'NO')NACC=INT(VALUE(ILOCP)+0.5) C IHRIGH='NREJ' IHRIG2='ECT ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IERROR='NO' C NUMDIG=-1 IF(IFORSW.EQ.'0')NUMDIG=0 IF(IFORSW.EQ.'1')NUMDIG=1 IF(IFORSW.EQ.'2')NUMDIG=2 IF(IFORSW.EQ.'3')NUMDIG=3 IF(IFORSW.EQ.'4')NUMDIG=4 IF(IFORSW.EQ.'5')NUMDIG=5 IF(IFORSW.EQ.'6')NUMDIG=6 IF(IFORSW.EQ.'7')NUMDIG=7 IF(IFORSW.EQ.'8')NUMDIG=8 IF(IFORSW.EQ.'9')NUMDIG=9 IF(IFORSW.EQ.'10')NUMDIG=10 C IF(ISPX2L.EQ.'CORR'.OR.ISPX2L.EQ.'PCOR')THEN IWRITE='OFF' IF(ISPX2P.EQ.'DEFAULT')THEN IX2LTE(1)='C' IX2LTE(2)='O' IX2LTE(3)='R' IX2LTE(4)='R' IX2LTE(5)=' ' IX2LTE(6)='=' IX2LTE(7)=' ' NCX2LA=7 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO110I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO120J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 120 CONTINUE GOTO129 ENDIF 110 CONTINUE 129 CONTINUE ENDIF CONST=0.5 IF(ACORR.LT.0.0)CONST=-0.5 IF(ISPX2L.EQ.'PCOR')ACORR=100.0*ACORR IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')ACORR NDEF=3 IF(ISPX2L.EQ.'PCOR')NDEF=1 IF(NUMDIG.LT.0)THEN ICORR=INT(ACORR*10**NDEF + CONST) ACORR=REAL(ICORR)/(10**NDEF) ELSE ICORR=INT(ACORR*10**NUMDIG + CONST) ACORR=REAL(ICORR)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(ICORR,ACORR,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN IF(ISPX2L.EQ.'PCOR')THEN NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)='%' ENDIF ELSEIF(ISPX2S.NE.' ')THEN DO210I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO220J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2S(J:J) 220 CONTINUE GOTO229 ENDIF 210 CONTINUE 229 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) ELSEIF(ISPX2L.EQ.'PACC')THEN IF(ISPX2P.EQ.'DEFAULT')THEN NCX2LA=0 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO310I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO320J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 320 CONTINUE GOTO329 ENDIF 310 CONTINUE 329 CONTINUE ENDIF CONST=0.5 AV=REAL(NACC)/REAL(NACC+NREJ) AV=100.0*AV IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN CONTINUE ELSEIF(ISPX2P.NE.' ')THEN DO360I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO370J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J) 370 CONTINUE GOTO379 ENDIF 360 CONTINUE 379 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) C ELSEIF(ISPX2L.EQ.'NACC')THEN IF(ISPX2P.EQ.'DEFAULT')THEN NCX2LA=0 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO410I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO420J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 420 CONTINUE GOTO429 ENDIF 410 CONTINUE 429 CONTINUE ENDIF CONST=0.5 AV=REAL(NACC) IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN CONTINUE ELSEIF(ISPX2P.NE.' ')THEN DO460I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO470J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J) 470 CONTINUE GOTO479 ENDIF 460 CONTINUE 479 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) C ELSEIF(ISPX2L.EQ.'AT ')THEN IF(ISPX2P.EQ.'DEFAULT')THEN NCX2LA=0 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO810I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO820J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 820 CONTINUE GOTO829 ENDIF 810 CONTINUE 829 CONTINUE ENDIF CONST=0.5 AV=REAL(NACC) AV1=AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)='/' AV=REAL(NACC+NREJ) IF(IOUNI5.GT.0)WRITE(IOUNI5,'(2G15.7)')AV1,AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN CONTINUE ELSEIF(ISPX2P.NE.' ')THEN DO860I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO870J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J) 870 CONTINUE GOTO879 ENDIF 860 CONTINUE 879 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) C ELSEIF(ISPX2L.EQ.'ATP ')THEN IF(ISPX2P.EQ.'DEFAULT')THEN NCX2LA=0 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO710I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO720J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 720 CONTINUE GOTO729 ENDIF 710 CONTINUE 729 CONTINUE ENDIF CONST=0.5 AV=REAL(NACC) AV1=AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)='/' AV=REAL(NACC+NREJ) AV2=AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=' ' NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)='=' NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=' ' AV=REAL(NACC)/REAL(NACC+NREJ) AV=100.0*AV IF(IOUNI5.GT.0)WRITE(IOUNI5,'(3G15.7)')AV1,AV2,AV IF(AV.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AV*10**NUMDIG + CONST) AV=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN CONTINUE ELSEIF(ISPX2P.NE.' ')THEN DO760I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO770J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J) 770 CONTINUE GOTO779 ENDIF 760 CONTINUE 779 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) C ELSEIF(ISPX2L.EQ.'EFFE')THEN IF(ISPX2P.EQ.'DEFAULT')THEN IX2LTE(1)='E' IX2LTE(2)='F' IX2LTE(3)='F' IX2LTE(4)='E' IX2LTE(5)='C' IX2LTE(6)='T' IX2LTE(7)=' ' IX2LTE(8)='=' IX2LTE(9)=' ' NCX2LA=9 ELSEIF(ISPX2P.EQ.' ')THEN NCX2LA=0 ELSE DO610I=16,1,-1 IF(ISPX2P(I:I).NE.' ')THEN NCX2LA=I DO620J=1,NCX2LA IX2LTE(J)(1:1)=ISPX2P(J:J) 620 CONTINUE GOTO629 ENDIF 610 CONTINUE 629 CONTINUE ENDIF CONST=0.5 AVAL=ALOWH IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AVAL IF(AVAL.LT.0.0)CONST=-0.5 IF(NUMDIG.GE.0)THEN IVAL=INT(AVAL*10**NUMDIG + CONST) AVAL=REAL(IVAL)/(10**NUMDIG) ENDIF NCX2LA=NCX2LA+1 CALL DPCONH(IVAL,AVAL,IX2LTE(NCX2LA),NH,IBUGG2,IERROR) NCX2LA=NCX2LA+NH IF(ISPX2S.EQ.'DEFAULT')THEN CONTINUE ELSEIF(ISPX2P.NE.' ')THEN DO660I=16,1,-1 IF(ISPX2S(I:I).NE.' ')THEN NTEMP=I DO670J=1,NTEMP NCX2LA=NCX2LA+1 IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J) 670 CONTINUE GOTO679 ENDIF 660 CONTINUE 679 CONTINUE ENDIF CONST=0.5 PX2LDS=-((PYMAX-PYMIN)-PX2LD2) C ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SPM3')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPM3--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPM4(ICASPL,IOPTN,IDX,IDY, 1ISUBNU, 1ISUBSW, 1ASUBXL,ASUBXU,ASUBYL,ASUBYU, 1ISUBN9, 1ISUBSZ, 1ASBXL2,ASBXU2,ASBYL2,ASBYU2, 1PSPXSL,PSPXSU,PSPYSL,PSPYSU, 1IBUGG2,ISUBRO,IERROR) C C PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX. SET SUBREGION C LIMITS (IF SPECIFIED BY USER). C IOPTN = 1 - SAVE CURENT SETTINGS C IOPTN = 2 - RESTORE CURENT SETTINGS C IOPTN = 3 - SET SUBREGION LIMITS FOR GIVEN Y, X C PAIR OF VARIABLES. NOTE IF LIMIT SET TO C CPUMIN OR CPUMAX, THEN NOTHING SET. C ALSO, MATRIX PLOTS ONLY RESET FIRST C SUBREGION (OTHERS ARE LEFT AS IS) C IDX = SETTING OF PSPXSL, PSPXSU TO USE C IDY = SETTING OF PSPYSL, PSPYSU TO USE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/12 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--DECEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------- C CHARACTER*4 IBUGG2 CHARACTER*4 ICASPL C CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBSW CHARACTER*4 ISUBSZ C DIMENSION ISUBSW(*) DIMENSION ASUBXL(*) DIMENSION ASUBXU(*) DIMENSION ASUBYL(*) DIMENSION ASUBYU(*) DIMENSION PSPXSL(*) DIMENSION PSPXSU(*) DIMENSION PSPYSL(*) DIMENSION PSPYSU(*) C C-----COMMON VARIABLES (GENERAL)---------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT------------------------------------------------- C CCCCC IF(ISUBRO.EQ.'SPM4')THEN CCCCC ENDIF C *************************************** C ** STEP 1--SAVE INITIAL SETTINGS ** C *************************************** C IF(IOPTN.EQ.1)THEN ISUBSZ=ISUBSW(1) ASBXL2=ASUBXL(1) ASBXU2=ASUBXU(1) ASBYL2=ASUBYL(1) ASBYU2=ASUBYU(1) ISUBN9=ISUBNU ELSEIF(IOPTN.EQ.2)THEN ISUBSW(1)=ISUBSZ ASUBXL(1)=ASBXL2 ASUBXU(1)=ASBXU2 ASUBYL(1)=ASBYL2 ASUBYU(1)=ASBYU2 ISUBNU=ISUBN9 ELSEIF(IOPTN.EQ.3)THEN IF(PSPXSL(IDX).NE.CPUMIN .AND. PSPXSU(IDX).NE.CPUMIN)THEN ISUBSW(1)='ON' IF(ISUBNU.EQ.0)ISUBNU=1 ASUBXL(1)=PSPXSL(IDX) ASUBXU(1)=PSPXSU(IDX) ENDIF IF(PSPYSL(IDY).NE.CPUMIN .AND. PSPYSU(IDY).NE.CPUMIN)THEN ISUBSW(1)='ON' IF(ISUBNU.EQ.0)ISUBNU=1 ASUBYL(1)=PSPYSL(IDY) ASUBYU(1)=PSPYSU(IDY) ENDIF ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'SPM4')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPM4--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSPPA(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPSPPA(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE LINE PATTERNS. C THESE ARE LOCATED IN THE VECTOR ISPILI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSL C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISPILI (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C UPDATED --AUGUST 1995. DASH2 BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IHARG2 CHARACTER*4 IDEFSL CHARACTER*4 ISPILI C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION ISPILI(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='PA ' C NUMSPI=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSL 55 FORMAT('IDEFSL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISPILI(1) 70 FORMAT('ISPILI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISPILI(I) 76 FORMAT('I,ISPILI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 GOTO1130 C 1100 CONTINUE GOTO1200 C 1110 CONTINUE IF(IHARG(1).EQ.'ALL')IHOLD1=' ' IF(IHARG(1).EQ.'ALL')GOTO1300 GOTO1200 C 1120 CONTINUE CCCCC IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2) CCCCC IF(IHARG(1).EQ.'ALL')GOTO1300 CCCCC IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1) CCCCC IF(IHARG(2).EQ.'ALL')GOTO1300 CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW IF(IHARG(1).EQ.'ALL')THEN IHOLD1=IHARG(2) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF IF(IHARG(2).EQ.'ALL')THEN IHOLD1=IHARG(1) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF GOTO1200 C 1130 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ISPILI(1)=' ' GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I IHOLD1=IHARG(J) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5' IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL ISPILI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ISPILI(I) 1276 FORMAT('SPIKE ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL DO1315I=1,NUMSPI ISPILI(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISPILI(I) 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSL 9015 FORMAT('IDEFSL = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISPILI(1) 9030 FORMAT('ISPILI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISPILI(I) 9036 FORMAT('I,ISPILI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPSM(X,N,XS,ICHANG,IBUGG3,IERROR) C C PURPOSE--THIS SUBROUTINE TAKES THE DATA IN THE VECTOR X, C DETERMINES THE VARIOUS MESAS, C AND APPLIES A 3-TERM MEDIAN SMOOTH TO THE DATA C BETWEEN EACH MESA. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C CONTAINING SMOOTHED VALUES. C --ICHANG = THE CHARACTER VARIABLE C CONTAINING EITHER YES OR NO C DEPENDING ON WHETHER OR NOT THE C SMOOTHED DATA IS CHANGED OR NOT C FROM THE ORIGINAL DATA. C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR C OF SMOOTHED VALUES. C NOTE--THE VECTOR X REMAINS UNCHANGED. C ASSUMPTION--THE VECTOR X HAS AT LEAST 3 VALUES. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS C 1977, PAGE 146 C (= SOURCE OF ALGORITHM). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C VERSION NUMBER--83.6 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHANG C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION XS(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3 52 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************************* C ** SPLIT THE DATA AT EACH MESA ** C ** AND THEN APPLY A 3-TERM MEDIAN SMOOTH ** C ** TO THE SUBSET OF THE DATA ** C ** BETWEEN EACH MESA. ** C ********************************************* C C **************************************** C ** STEP 1-- ** C ** COPY THE DATA FROM X(.) TO XS(.) ** C **************************************** C DO1100I=1,N XS(I)=X(I) 1100 CONTINUE C C ******************************** C ** STEP 2-- ** C ** SEARCH FOR A MESA IN THE ** C ** FIRST 3 OBSERVATIONS ** C ******************************** C IF(X(2).NE.X(3))GOTO1290 IF(X(1).LE.X(2).AND.X(3).LE.X(4))GOTO1290 IF(X(1).GE.X(2).AND.X(3).GE.X(4))GOTO1290 XS(2)=X(1) ARG1=X(3) ARG2=X(4) ARG3=3*X(4)-2*X(5) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(3)=XMED3 1290 CONTINUE C C *********************************** C ** STEP 3-- ** C ** SEARCH FOR MESAS ** C ** IN THE MIDDLE OF THE SERIES ** C *********************************** C NM2=N-2 IF(3.GT.NM2)GOTO1390 DO1300I=3,NM2 C IM2=I-2 IM1=I-1 IP1=I+1 IP2=I+2 IP3=I+3 C IF(X(I).NE.X(IP1))GOTO1300 IF(X(IM1).LE.X(I).AND.X(IP1).LE.X(IP2))GOTO1300 IF(X(IM1).GE.X(I).AND.X(IP1).GE.X(IP2))GOTO1300 C ARG1=X(I) ARG2=X(IM1) ARG3=3*X(IM1)-2*X(IM2) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(I)=XMED3 C ARG1=X(IP1) ARG2=X(IP2) ARG3=3*X(IP2)-2*X(IP3) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(IP1)=XMED3 C 1300 CONTINUE 1390 CONTINUE C C ******************************** C ** STEP 4-- ** C ** SEARCH FOR A MESA IN THE ** C ** LAST 3 OBSERVATIONS ** C ******************************** C NM1=N-1 NM2=N-2 NM3=N-3 NM4=N-4 IF(X(NM1).NE.X(NM2))GOTO1490 IF(X(N).LE.X(NM1).AND.X(NM2).LE.X(NM3))GOTO1490 IF(X(N).GE.X(NM1).AND.X(NM2).GE.X(NM3))GOTO1490 XS(NM1)=X(N) ARG1=X(NM2) ARG2=X(NM3) ARG3=3*X(NM3)-2*X(NM4) CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR) XS(NM2)=XMED3 1490 CONTINUE C ********************************************* C ** STEP 5-- ** C ** CHECK TO SEE IF A CHANGE HAS OCCURRED ** C ** BETWEEN THE RAW DATA AND ** C ** THE SPLIT & SMOOTHED DATA. ** C ********************************************* C ICHANG='NO' DO1500I=1,N IF(XS(I).NE.X(I))GOTO1510 1500 CONTINUE GOTO1590 1510 CONTINUE ICHANG='YES' 1590 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPSM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3 9012 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHANG 9013 FORMAT('ICHANG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N 9014 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XS(I) 9016 FORMAT('I,X(I),XS(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPSW(IHARG,NUMARG,IDEFSS,MAXSPI,ISPISW, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE SWITCHES. C THESE ARE LOCATED IN THE VECTOR ISPISW(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFSS C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ISPISW (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFSS CHARACTER*4 ISPISW C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 CHARACTER*4 IHOLD2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION ISPISW(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='SW ' C NUMSPI=0 IHOLD1='-999' IHOLD2='-999' C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPSW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,IHOLD2 54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IDEFSS 55 FORMAT('IDEFSS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I) 66 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)ISPISW(1) 70 FORMAT('ISPISW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ISPISW(I) 76 FORMAT('I,ISPISW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 GOTO1130 C 1100 CONTINUE GOTO1200 C 1110 CONTINUE IF(IHARG(1).EQ.'ALL')IHOLD1='OFF' IF(IHARG(1).EQ.'ALL')GOTO1300 GOTO1200 C 1120 CONTINUE IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(1).EQ.'ALL')GOTO1300 IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1) IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 ISPISW(1)='ON' GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSS CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSS ISPISW(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,ISPISW(I) 1276 FORMAT('SPIKE ',I6,' HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSS CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSS DO1315I=1,NUMSPI ISPISW(I)=IHOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)ISPISW(I) 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPSW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,IHOLD2 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFSS 9015 FORMAT('IDEFSS = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I) 9026 FORMAT('IHARG(I) = ',A4) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)ISPISW(1) 9030 FORMAT('ISPISW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ISPISW(I) 9036 FORMAT('I,ISPISW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSPTH(IHARG,IARGT,ARG,NUMARG,PDEFST,MAXSPI,PSPITH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE SPIKE THICKNESSES. C THESE ARE LOCATED IN THE VECTOR PSPITH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEFST C --MAXSPI C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PSPITH (A FLOATING POINT VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1983. C UPDATED --JANUARY 1989. ERROR IN FORMAT STATEMENT (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD1 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) DIMENSION PSPITH(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPSP' ISUBN2='TH ' C NUMSPI=0 IHOLD1='-999' HOLD1=-999.0 HOLD2=-999.0 C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSPTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR 52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXSPI,NUMSPI 53 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2 54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)PDEFST 55 FORMAT('PDEFST = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)NUMARG 60 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,NUMARG WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I) 66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE WRITE(ICOUT,70)PSPITH(1) 70 FORMAT('PSPITH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PSPITH(I) 76 FORMAT('I,PSPITH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ************************************** C ISTEPN='1' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO9000 IF(NUMARG.EQ.1)GOTO1110 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 GOTO1140 C 1110 CONTINUE GOTO1200 C 1120 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=' ' IF(IHARG(2).EQ.'ALL')HOLD1=PDEFST IF(IHARG(2).EQ.'ALL')GOTO1300 GOTO1200 C 1130 CONTINUE IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(2).EQ.'ALL')GOTO1300 IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE GOTO1200 C C ************************************************* C ** STEP 2-- ** C ** TREAT THE INDIVIDUAL SPECIFICATIONS CASE ** C ************************************************* C 1200 CONTINUE ISTEPN='2' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)GOTO1210 GOTO1220 C 1210 CONTINUE NUMSPI=1 PSPITH(1)=PDEFST GOTO1270 C 1220 CONTINUE NUMSPI=NUMARG-1 IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI DO1225I=1,NUMSPI J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFST IF(IHOLD1.EQ.'OFF')HOLD2=PDEFST IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFST IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFST PSPITH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMSPI WRITE(ICOUT,1276)I,PSPITH(I) 1276 FORMAT('SPIKE THICKNESS ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1278 CONTINUE 1279 CONTINUE IFOUND='YES' GOTO9000 C C ************************** C ** STEP 2-- ** C ** TREAT THE ALL CASE ** C ************************** C 1300 CONTINUE ISTEPN='3' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSPI=MAXSPI HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEFST IF(IHOLD1.EQ.'OFF')HOLD2=PDEFST IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFST IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFST DO1315I=1,NUMSPI PSPITH(I)=HOLD2 1315 CONTINUE GOTO1370 C 1370 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1316)PSPITH(I) 1316 FORMAT('ALL SPIKE THICKNESSES HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSPTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXSPI,NUMSPI 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PDEFST 9015 FORMAT('PDEFST = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9025I=1,NUMARG WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I) 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9030)PSPITH(1) 9030 FORMAT('PSPITH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PSPITH(I) 9036 FORMAT('I,PSPITH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSQUE(PX,PY,NP, 1PXMIN,PXMAX,PYMIN,PYMAX) C C PURPOSE--SCAN EACH VALUE OF PX(.) AND C COMPARE IT TO (PXMIN,PXMAX). C IF ONLY SLIGHTLY SMALLER THAN PXMIN, C THEN CHANGE PX(I) TO PXMAX. C IF ONLY SLIGHTLY LARGER THAN PXMAX, C THEN CHANGE PX(I) TO PXMAX. C SIMILARLY, SCAN EACH VALUE OF PY(.) AND C COMPARE IT TO (PYMIN,PYMAX). C IF ONLY SLIGHTLY SMALLER THAN PYMIN, C THEN CHANGE PY(I) TO PYMAX. C IF ONLY SLIGHTLY LARGER THAN PYMAX, C THEN CHANGE PY(I) TO PYMAX. C NOTE--THIS SUBROUTINE COUNTERACTS INCORRECT C COORDINATE CALCULATIONS FOR P WHICH ARE C INCORRECT DUE TO ROUNDOFF ERROR C AND SQUEEZES THEM BACK TO THEIR PROPER VALUE. C DANGER--PX(.) AND PY(.) SERVE AS BOTH INPUT AND C OUTPUT ARGUMENTS IN THIS SUBROUTINE. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C C-------------------------------------------------------- C DIMENSION PX(*) DIMENSION PY(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SQUE')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSQUE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)PXMIN,PXMAX,PYMIN,PYMAX 52 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NP 54 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NP DELXMN=PXMIN-PX(I) DELXMX=PX(I)-PXMAX DELYMN=PYMIN-PY(I) DELYMX=PY(I)-PYMAX WRITE(ICOUT,56)I,PX(I),PY(I) 56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)DELXMN,DELXMX,DELYMN,DELYMN 57 FORMAT('DELXMN,DELXMX,DELYMN,DELYMN = ',4E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4 59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************* C ** STEP 1-- ** C ** CHECK TO SEE IF PX(.) NEAR PXMIN OR PXMAX ** C ************************************************* C IF(NP.LE.0)GOTO1190 DO1100I=1,NP C IF(PX(I).LT.PXMIN)GOTO1110 IF(PX(I).GT.PXMAX)GOTO1120 GOTO1100 C 1110 CONTINUE DELMIN=PXMIN-PX(I) IF(DELMIN.LE.0.0001)PX(I)=PXMIN GOTO1100 C 1120 CONTINUE DELMAX=PX(I)-PXMAX IF(DELMAX.LE.0.0001)PX(I)=PXMAX GOTO1100 C 1100 CONTINUE 1190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** CHECK TO SEE IF PY(.) NEAR PYMIN OR PYMAX ** C ************************************************* C IF(NP.LE.0)GOTO1290 DO1200I=1,NP C IF(PY(I).LT.PYMIN)GOTO1210 IF(PY(I).GT.PYMAX)GOTO1220 GOTO1200 C 1210 CONTINUE DELMIN=PYMIN-PY(I) IF(DELMIN.LE.0.0001)PY(I)=PYMIN GOTO1200 C 1220 CONTINUE DELMAX=PY(I)-PYMAX IF(DELMAX.LE.0.0001)PY(I)=PYMAX GOTO1200 C 1200 CONTINUE 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SQUE')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSQUE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)PXMIN,PXMAX,PYMIN,PYMAX 9012 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NP DELXMN=PXMIN-PX(I) DELXMX=PX(I)-PXMAX DELYMN=PYMIN-PY(I) DELYMX=PY(I)-PYMAX WRITE(ICOUT,9016)I,PX(I),PY(I) 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)DELXMN,DELXMX,DELYMN,DELYMN 9017 FORMAT('DELXMN,DELXMX,DELYMN,DELYMN = ',4E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPSTAC(ICASL8,ILOCV, 1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1TEMP,TEMP2,XTEMP1,XTEMP2,XTEMP3,MAXNXT, CCCCC JULY 2002. ADD ISEED FOR HODHES-LEHMAN 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--TREAT THE TYPE 8 LET CASE-- C COMPUTE ELEMENTARY STATISTICS (MOSTLY). C LET A = NUMBER X C LET A = SIZE X C LET A = COUNT X C C LET A = SUM X C LET A = PRODUCT X C LET A = INTEGRAL X C LET A = RATIO X1 X2 C C LET A = MIDRANGE X C LET A = MEAN X C LET A = AVERAGE X C LET A = MIDMEAN X C LET A = MEDIAN X C LET A = TRIMMED MEAN X C LET A = WINDSORIZED MEAN X C LET A = STANDARD DEVIATION X C LET A = VARIANCE X C LET A = COEFFICIENT OF VARIATION X C LET A = RELATIVE STANDARD DEVIATION X C LET A = RELATIVE VARIANCE X C LET A = AVERAGE ABSOLUTE DEVIATION X C LET A = RANGE X C LET A = MINIMUM X C LET A = MIN X C LET A = MAXIMUM X C LET A = MAX X C LET A = EXTREME X C LET A = STANDARDIZED THIRD CENTRAL MOMENT X C LET A = SKEWNESS X C LET A = STANDARDIZED FOURTH CENTRAL MOMENT X C LET A = KURTOSIS X C LET A = AUTOCORRELATION X C LET A = COVARIANCE X Y C LET A = CORRELATION X Y C LET A = RANK CORRELATION X Y C LET A = KENDELLS TAU X Y C LET A = COMOVEMENT X Y (LEIGH-PEARLMAN) C LET A = RANK COMOVEMENT X Y C LET A = STANDARD DEVIATION OF MEAN X C LET A = VARIANCE OF MEAN X C LET A = STANDARD DEVIATION OF THE MEAN X C LET A = STANDARD DEVIATION MEAN X C C LET A = WEIGHTED MEAN X W C LET A = WEIGHTED MEDIAN X W C LET A = WEIGHTED STANDARD DEVIATION X W C LET A = WEIGHTED VARIANCE X W C LET A = WEIGHTED TRIMMED MEAN X W C C LET A = CP X C LET A = CPL X C LET A = CPU X C LET A = CPK X C LET A = CNPK X C LET A = CPM X C LET A = CC X C LET A = PERCENT DEFECTIVE X C LET A = EXPECTED LOSS X C C LET A = NORMAL PPCC X C C LET A = LINEAR INTERCEPT Y X C LET A = LINEAR SLOPE Y X C LET A = LINEAR RESSD Y X C LET A = LINEAR CORRELATION Y X C LET A = REPEATABILITY SD Y X C LET A = REPRODUCABILITY SD Y X C C LET A = (TAGUCHI) SN- X C LET A = (TAGUCHI) SN0 X C LET A = (TAGUCHI) SN+ X C LET A = (TAGUCHI) SN00 X C C LET A = MEDIAN ABSOLUTE DEVIATION X C LET A = MAD X C LET A = SN X C LET A = QN X C LET A = 95 PERCENTILE X C C LET A = GEOMETRIC MEAN X W C LET A = GEOMETRIC STANDARD DEVIATION X W C C LET A = COMMON DIGITS X C LET A = NUMBER OF COMMON DIGITS X C C LET A = INTERQUARTILE RANGE X C C LET A = BIWEIGHT LOCATION X C LET A = BIWEIGHT SCALE X C C LET A = WINSORIZED VARIANCE X C LET A = WINSORIZED SD X C LET A = WINSORIZED COVARIANCE X Y C LET A = WINSORIZED CORRELATION X Y C LET A = PERCENTAGE BEND MIDVARIANCE X C LET A = PERCENTAGE BEND CORRELATION X1 X2 C LET A = HODGES LEHMAN X C LET A = BIWEIGHT MIDVARIANCE X C LET A = BIWEIGHT MIDCOVARIANCE X Y C LET A = BIWEIGHT MIDCORRELATION X Y C LET A = TRIMMED MEAN STANDARD ERROR X C LET A = ... QUANTILE X C LET A = ... QUANTILE STANDARD ERROR X C C FOLLOWING STATISTICS COMPUTE DIFFERENCE IN C STATISTIC FOR TWO RESPONSE VARIABLES (USED FOR C LOCATION AND SCALE STATISTICS): C C LOCATION: C LET A = DIFFERENCE OF MEANS X1 X2 C LET A = DIFFERENCE OF MIDMEANS X1 X2 C LET A = DIFFERENCE OF MEDIANS X1 X2 C LET A = DIFFERENCE OF TRIMMED MEANS X1 X2 C LET A = DIFFERENCE OF WINSORIZED MEANS X1 X2 C LET A = DIFFERENCE OF GEOMETRIC MEANS X1 X2 C LET A = DIFFERENCE OF HARMONIC MEANS X1 X2 C LET A = DIFFERENCE OF HODGES-LEHMAN X1 X2 C LET A = DIFFERENCE OF BIWEIGHT LOCATION X1 X2 C C SCALE: C LET A = DIFFERENCE OF STANDARD DEVIATIONS X1 X2 C LET A = DIFFERENCE OF VARIANCES X1 X2 C LET A = DIFFERENCE OF AAD X1 X2 C LET A = DIFFERENCE OF MAD X1 X2 C LET A = DIFFERENCE OF SN X1 X2 C LET A = DIFFERENCE OF QN X1 X2 C LET A = DIFFERENCE OF INTERQUARTILE RANGE X1 X2 C LET A = DIFFERENCE OF WINSORIZED SD X1 X2 C LET A = DIFFERENCE OF WINSORIZED VARIANCE X1 X2 C LET A = DIFFERENCE OF BIWEIGHT MIDVARIANCE X1 X2 C LET A = DIFFERENCE OF BIWEIGHT SCALE X1 X2 C LET A = DIFFERENCE OF PERCENTAGE BEND X1 X2 C LET A = DIFFERENCE OF GEOMETRIC SD X1 X2 C LET A = DIFFERENCE OF RANGE X1 X2 C LET A = DIFFERENCE OF MIDRANGE X1 X2 C LET A = DIFFERENCE OF QUANTILE X1 X2 C LET A = DIFFERENCE OF SKEWNESS X1 X2 C LET A = DIFFERENCE OF KURTOSIS X1 X2 C LET A = DIFFERENCE OF RELATIVE SD X1 X2 C LET A = DIFFERENCE OF SD OF MEAN X1 X2 C LET A = DIFFERENCE OF RELATIVE VARIANCE X1 X2 C LET A = DIFFERENCE OF VARIANCE OF THE MEAN X1 X2 C LET A = DIFFERENCE OF MINIMUM X1 X2 C LET A = DIFFERENCE OF MAXIMUM X1 X2 C LET A = DIFFERENCE OF EXTREMES X1 X2 C LET A = DIFFERENCE OF COEFFICENT OF VARI X1 X2 C LET A = DIFFERENCE OF COUNTS X1 X2 C LET A = DIFFERENCE OF SUM X1 X2 C C NOTE--THIS SUBROUTINE OPERATES ON A VECTOR C AND PRODUCES A PARAMETER (= A SCALAR); C THIS IS TO BE CONTRASTED WITH DPLET7 WHICH C OPERATES ON A VECTOR C BUT PRODUCES A VECTOR. C NOTE-INPUT WILL NECESSARILY BE A VECTOR (OR 2 VECTORS). C OUTPUT WILL NECESSARILY BE A SCALAR-- C 1) PARAMETER, OR C 2) ELEMENT OF A VECTOR. C THE STATISTICS CAN BE CALCULATED ON A FULL VARIABLE C OR ON A PARTIAL VARIABLE. C EXAMPLE--LET A = MEAN X (A FULL VARIABLE) C --LET Y(4) = MEAN X (A FULL VARIABLE) C --LET A = MEAN X SUBSET 2 3 5 (A PARTIAL VAR.) C --LET Y(4) = MEAN X SUBSET 2 3 5 (A PARTIAL VAR.) C --LET A = MEAN X FOR I = 1 2 10 (A PARTIAL VAR.) C --LET Y(4) = MEAN X FOR I = 1 2 10 (A PARTIAL VAR.) C --LET A = CORRELATION X Y (A FULL VARIABLE C --LET Y(4) = CORRELATION X Y (A FULL VARIABLE C --LET A = CORRELATION X Y SUBSET 2 3 5 (A PARTIAL C --LET Y(4) = CORRELATION X Y SUBSET 2 3 5 (A PARTIAL C --LET A = CORRELATION X Y FOR I = 1 2 10 (A PARTIAL C --LET Y(4) = CORRELATION X Y FOR I = 1 2 10 (A PARTIAL C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A PART OF DPLET)--DECEMBER 1977. C UPDATED --MAY 1982. C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1978. C UPDATED --JULY 1978. C UPDATED --NOVEMBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --JULY 1979. C UPDATED --JUNE 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --NOVEMBER 1987. (EXIT OUT IF ERROR) C UPDATED --AUGUST 1988. (WEIGHTED MEAN, MEDIAN, SD, VARIANCE) C UPDATED --DECEMBER 1988. LET Y(K) = MEAN X INSIDE LOOP C UPDATED --JANUARY 1989. TRY TO REUSE A PARAM. AS A VAR. C UPDATED --FEBRUARY 1989. AVERAGE ABSOLUTE DEVIATION (ALAN) C UPDATED --APRIL 1990. EXTREME C UPDATED --SEPTEMBER 1990. CP, CPK, % DEF, EXP. LOSS C UPDATED --AUGUST 1991. COMOVEMENT C UPDATED --FEBRUARY 1994. CHANGE ICASL8: RSD => RESD C UPDATED --FEBRUARY 1994. CHANGE ICASL8: SDM => SDME C UPDATED --FEBRUARY 1994. RELATIVE VARIANCE C UPDATED --FEBRUARY 1994. VARIANCE OF THE MEAN C UPDATED --FEBRUARY 1994. NORMAL PPCC C UPDATED --FEBRUARY 1994. TAGUCHI SN- SN0 SN+ SN00 C UPDATED --NOVEMBER 1994. DISTINGUISH RELATIVE SD AND C COEF OF VARIATION CASES. C UPDATED --MARCH 1995. MAD C UPDATED --NOVEMBER 1998. PERCENTILE C UPDATED --NOVEMBER 1998. CPM, CC C UPDATED --MARCH 1999. CNPK C UPDATED --MARCH 1999. GEOMETRIC MEAN C UPDATED --MARCH 1999. GEOMETRIC STANDARD DEVIATION C UPDATED --APRIL 2001. ARGUMENT LIST TO CP, CPK, CPM C UPDATED --APRIL 2001. CPL, CPU C UPDATED --AUGUST 2001. COMMON DIGITS C UPDATED --AUGUST 2001. NUMBER OF COMMON DIGITS C UPDATED --SEPTEMBER 2001. IQ RANGE C UPDATED --NOVEMBER 2001. BIWEIGHT LOCATION C UPDATED --NOVEMBER 2001. BIWEIGHT SCALE C UPDATED --JULY 2002. WINSORIZED VARIANCE C UPDATED --JULY 2002. WINSORIZED SD C UPDATED --JULY 2002. WINSORIZED COVARIANCE C UPDATED --JULY 2002. WINSORIZED CORRELATION C UPDATED --JULY 2002. HODGES LEHMAN C UPDATED --JULY 2002. PERCENTAGE BEND MIDVARIANCE C UPDATED --JULY 2002. PERCENTAGE BEND CORRELATION C UPDATED --JULY 2002. BIWEIGHT MIDVARIANCE C UPDATED --JULY 2002. BIWEIGHT MIDCOVARIANCE C UPDATED --JULY 2002. BIWEIGHT MIDCORRELATION C UPDATED --JULY 2002. TRIMMED MEAN STANDARD ERROR C UPDATED --JULY 2002. QUANTILE STANDARD ERROR C UPDATED --JULY 2002. QUANTILE C UPDATED --MARCH 2003. ADD 32 "DIFFERENCE OF" C STATISTICS C UPDATED --APRIL 2003. ADD SN AND QN (AND DIFFERENCE C OF). REQUIRED ADDITIONAL C SCRATCH ARRAYS. C UPDATED --MAY 2003. ADD WEIGHTED TRIMMED MEAN C UPDATED --DECEMBER 2003. BUG IN INTEGRAL (DETERMINE C WHETHER 1 OR 2 VARIABLES C SPECIFIED) C UPDATED --OCTOBER 2004. KENDELLS TAU C UPDATED --FEBRUARY 2005. REPEATABILITY SD C UPDATED --FEBRUARY 2005. REPRODUCABILITY SD C UPDATED --SEPTEMBER 2005. RATIO C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASL8 CHARACTER*4 IFOUNZ CHARACTER*4 ITYPE CHARACTER*4 IHOL CHARACTER*4 IHOL2 CHARACTER*4 IERRO1 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 ICASEL CHARACTER*4 ICASEQ CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IWRITE CHARACTER*4 IHARG3 CHARACTER*4 IHARG4 CHARACTER*4 IHARG5 CHARACTER*4 IHARG6 CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 CHARACTER*4 ISUBSF CHARACTER*4 IFORF CHARACTER*4 IARG4T CHARACTER*4 IARG4F CHARACTER*4 IHSET CHARACTER*4 IHSET2 CHARACTER*4 IH CHARACTER*4 IH2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 ISUBRO CHARACTER*4 IFLAGD C C--------------------------------------------------------------------- C DIMENSION IFOUNZ(*) DIMENSION IBEGIN(*) DIMENSION IEND(*) DIMENSION ITYPE(*) DIMENSION IHOL(*) DIMENSION IHOL2(*) DIMENSION INT1(*) DIMENSION FLOAT1(*) DIMENSION IERRO1(*) C DIMENSION TEMP(*) DIMENSION TEMP2(*) C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION XTEMP3(*) C DIMENSION ITEMP1(*) DIMENSION ITEMP2(*) DIMENSION ITEMP3(*) DIMENSION ITEMP4(*) DIMENSION ITEMP5(*) DIMENSION ITEMP6(*) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C INCLUDE 'DPCOST.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPST' ISUBN2='AC ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='NO' IERROR='NO' C ICOLL=0 ICOL2=0 NIRIG2=0 ILOCSV=0 CCCCC FEBRUARY 1998. ADD FOLLOWING LINE. CAUSED A PROBLEM IN CCCCC SOME CASES (RS_6000 COMPILED WITH f2c) NIOLD=0 C ICASEL='UNKN' C C ********************************************************** C ** TREAT THE SUBCASE OF CALCULATING CERTAIN ** C ** ELEMENTARY STATISTICS (MEAN, SD, ETC.) ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C ********************************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,IBUGQ 52 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASL8,ILOCV 53 FORMAT('ICASL8,ILOCV = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C ISUBRO='UNKN' IFLAGD='OFF' IF(ICASL8.EQ.'DMEA')IFLAGD='ON' IF(ICASL8.EQ.'DMDM')IFLAGD='ON' IF(ICASL8.EQ.'DMED')IFLAGD='ON' IF(ICASL8.EQ.'DTRM')IFLAGD='ON' IF(ICASL8.EQ.'DWNM')IFLAGD='ON' IF(ICASL8.EQ.'DGEO')IFLAGD='ON' IF(ICASL8.EQ.'DHAR')IFLAGD='ON' IF(ICASL8.EQ.'DHDL')IFLAGD='ON' IF(ICASL8.EQ.'DBIW')IFLAGD='ON' IF(ICASL8.EQ.'DSD ')IFLAGD='ON' IF(ICASL8.EQ.'DVAR')IFLAGD='ON' IF(ICASL8.EQ.'DAAD')IFLAGD='ON' IF(ICASL8.EQ.'DMAD')IFLAGD='ON' IF(ICASL8.EQ.'DIQR')IFLAGD='ON' IF(ICASL8.EQ.'DWSD')IFLAGD='ON' IF(ICASL8.EQ.'DWVA')IFLAGD='ON' IF(ICASL8.EQ.'DBIM')IFLAGD='ON' IF(ICASL8.EQ.'DBIS')IFLAGD='ON' IF(ICASL8.EQ.'DPBN')IFLAGD='ON' IF(ICASL8.EQ.'DGSD')IFLAGD='ON' IF(ICASL8.EQ.'DRAN')IFLAGD='ON' IF(ICASL8.EQ.'DMDR')IFLAGD='ON' IF(ICASL8.EQ.'DQUA')IFLAGD='ON' IF(ICASL8.EQ.'DSKE')IFLAGD='ON' IF(ICASL8.EQ.'DKUR')IFLAGD='ON' IF(ICASL8.EQ.'DRSD')IFLAGD='ON' IF(ICASL8.EQ.'DSDM')IFLAGD='ON' IF(ICASL8.EQ.'DRVA')IFLAGD='ON' IF(ICASL8.EQ.'DVAM')IFLAGD='ON' IF(ICASL8.EQ.'DMIN')IFLAGD='ON' IF(ICASL8.EQ.'DMAX')IFLAGD='ON' IF(ICASL8.EQ.'DEXT')IFLAGD='ON' IF(ICASL8.EQ.'DCVA')IFLAGD='ON' IF(ICASL8.EQ.'DCOU')IFLAGD='ON' IF(ICASL8.EQ.'DSUM')IFLAGD='ON' IF(ICASL8.EQ.'DSN')IFLAGD='ON' IF(ICASL8.EQ.'DQN')IFLAGD='ON' C C **************************************************************** C ** STEP 2-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC CALL DPTYP8(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3, CCCCC1 IFOUNZ,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1) ILEFT=IHOL(2) ILEFT2=IHOL2(2) DO200I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO215 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO210 200 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO220 GOTO230 C 220 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) 222 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,223)MAXNAM 223 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,224) 224 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,225) 225 FORMAT(' ENTER STATUS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,226) 226 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,227) 227 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,228) 228 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 230 CONTINUE IARG4F=IFOUNZ(4) ISUBSF=IFOUNZ(11) IFORF=IFOUNZ(21) IF(IARG4F.EQ.'NO')GOTO290 NIOLD=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO240 MAXNI=0 DO235I=1,12 IF(IUSE(I).EQ.'V')GOTO236 GOTO235 236 CONTINUE IF(IN(I).GT.MAXNI)MAXNI=IN(I) 235 CONTINUE IF(MAXNI.EQ.0)MAXNI=MAXN GOTO290 C 240 CONTINUE WRITE(ICOUT,241) 241 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,242) 242 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,243)MAXCOL 243 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,244) 244 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,245) 245 FORMAT(' ENTER STATUS VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,246) 246 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,247) 247 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,248) 248 FORMAT(' IF (E.G.) LET Y(3) = MEAN X FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,249) 249 FORMAT(' THEN ONE MIGHT ENTER NAME Y 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,250) 250 FORMAT(' (THEREBY EQUATING THE NAME Y WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,251) 251 FORMAT(' FOLLOWED BY LET Y(3) = MEAN X ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,252) 252 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE ROW 3 ', 1'OF COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,253) 253 FORMAT(' WITH THE CALCULATED MEAN OF VARIABLE X)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 215 CONTINUE ILISTL=I2 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT (JANUARY 1989) CCCCC AND REPLACED BY THE SUCCEEDING 12 LINES (JANUARY 1989) CCCCC TO FIX PROBLEM OF REUSING A PARAMETER AS A VARIABLE (JANUARY 1989) CCCCC GOTO290 IF(IFOUNZ(4).EQ.'NO')GOTO290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,216) 216 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,217)IHOL(2),IHOL2(2) 217 FORMAT(' AN ATTEMPT WAS MADE TO USE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,218) 218 FORMAT(' AS A VARIABLE, EVEN THOUGH IT ALREADY EXISTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,219) 219 FORMAT(' AS A PARAMETER.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 210 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NIOLD=IN(ILISTL) 290 CONTINUE C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE RIGHT-HAND SIDE-- * C ** HAS THE VARIABLE OR COLUMN ON THE RIGHT * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT IRIGHT IS THE NAME OF THE VARIABLE * C ** ON THE RIGHT. * C ** NOTE THAT ILISTR IS THE LINE IN THE TABLE * C ** OF THE VARIABLE OR COLUMN ON THE RIGHT. * C ** NOTE THAT ICOLR IS THE DATA COLUMN (1 TO 12) * C ** FOR THE VARIABLE OR COLUMN ON THE RIGHT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ******************************************** C ** STEP 4-- ** C ** BRANCH BETWEEN 1-VARIABLE STATISTICS ** C ** (E.G., MEAN, SD, MIN, ETC.) ** C ** AND 2-VARIABLE STATISTICS ** C ** (CORRELATION AND RANK CORRELATION). ** C ******************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVIN=1 IF(ICASL8.EQ.'COVA')GOTO2000 IF(ICASL8.EQ.'CORR')GOTO2000 CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1991 JJF IF(ICASL8.EQ.'COMO')GOTO2000 IF(ICASL8.EQ.'RACV')GOTO2000 IF(ICASL8.EQ.'RACR')GOTO2000 CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1991 JJF IF(ICASL8.EQ.'RACM')GOTO2000 IF(ICASL8.EQ.'LIIN')GOTO2000 IF(ICASL8.EQ.'LISL')GOTO2000 IF(ICASL8.EQ.'LIRE')GOTO2000 IF(ICASL8.EQ.'LICO')GOTO2000 IF(ICASL8.EQ.'KTAU')GOTO2000 IF(ICASL8.EQ.'REPE')GOTO2000 IF(ICASL8.EQ.'REPR')GOTO2000 IF(ICASL8.EQ.'WICV')GOTO2000 IF(ICASL8.EQ.'WICR')GOTO2000 IF(ICASL8.EQ.'BIMC')GOTO2000 IF(ICASL8.EQ.'BICR')GOTO2000 IF(ICASL8.EQ.'PBCR')GOTO2000 IF(ICASL8.EQ.'WEME')GOTO500 IF(ICASL8.EQ.'WEMD')GOTO500 IF(ICASL8.EQ.'WESD')GOTO500 IF(ICASL8.EQ.'WEVA')GOTO500 IF(ICASL8.EQ.'WETM')GOTO500 IF(ICASL8.EQ.'INTE')GOTO500 IF(ICASL8.EQ.'RATI')GOTO500 IF(IFLAGD.EQ.'ON')GOTO500 GOTO1000 C 500 CONTINUE NUMVIN=1 ILOCVP=ILOCV+1 IF(ILOCVP.GT.NUMARG)GOTO1000 IHARG5=IHARG(ILOCVP) IHARG6=IHARG2(ILOCVP) IF(IHARG5.EQ.'SUBS'.AND.IHARG6.EQ.'ET ')GOTO1000 IF(IHARG5.EQ.'EXCE'.AND.IHARG6.EQ.'PT ')GOTO1000 IF(IHARG5.EQ.'FOR '.AND.IHARG6.EQ.' ')GOTO1000 NUMVIN=2 GOTO2000 C C *************************************** C ** STEP 5-- ** C ** TREAT THE 1-VARIABLE STATISTICS ** C *************************************** C 1000 CONTINUE C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=1 C 1100 CONTINUE IH=IHARG(ILOCV) IH2=IHARG2(ILOCV) DO1110I=1,NUMNAM I2=I IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1190 IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1150 1110 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE SPECIFIED ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)(IANS(I),I=1,IWIDTH) 1117 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 1150 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' THE SPECIFIED ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1157) 1157 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1158) 1158 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1159)(IANS(I),I=1,IWIDTH) 1159 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 1190 CONTINUE ILISTR=I2 ICOLR=IVALUE(ILISTR) NIRIGH=IN(ILISTR) GOTO700 C C ************************************************ C ** STEP 6.2-- ** C ** TREAT THE 2 VARIABLE CASE. ** C ** CHECK THE VALIDITY OF THE FIRST ARGUMENT ** C ************************************************ C 2000 CONTINUE C ISTEPN='6.2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=2 C IHARG3=IHARG(ILOCV) IHARG4=IHARG2(ILOCV) DO2210I=1,NUMNAM I2=I IF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO2290 IF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO2219 2210 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE SPECIFIED FIRST ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216) 2216 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2217)(IANS(I),I=1,IWIDTH) 2217 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2219 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2221) 2221 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2222) 2222 FORMAT(' THE SPECIFIED FIRST ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2223) 2223 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2224) 2224 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2225) 2225 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2226) 2226 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2227) 2227 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2228) 2228 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2229)(IANS(I),I=1,IWIDTH) 2229 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2290 CONTINUE C ILISTR=I2 ICOLR=IVALUE(ILISTR) NIRIGH=IN(ILISTR) C C ***************************************************** C ** STEP 6.3-- ** C ** CHECK THE VALIDITY OF THE SECOND ARGUMENT ** C ***************************************************** C 2300 CONTINUE C ISTEPN='6.3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCVP=ILOCV+1 IF(ILOCVP.LE.NUMARG)GOTO2309 C WRITE(ICOUT,2301) 2301 FORMAT('***** ERROR IN DPSTAC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2302) 2302 FORMAT(' NO SECOND VARIABLE NAME OR COLUMN NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2303) 2303 FORMAT(' WAS GIVEN AFTER THE STATISTIC ', 1'CALCULATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2304) 2304 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2305)(IANS(I),I=1,IWIDTH) 2305 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2309 CONTINUE C IHARG5=IHARG(ILOCVP) IHARG6=IHARG2(ILOCVP) DO2310I=1,NUMNAM I2=I IF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO2390 IF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO2319 2310 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2311) 2311 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2312) 2312 FORMAT(' THE SPECIFIED SECOND ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2313) 2313 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2314) 2314 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2315) 2315 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2316) 2316 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2317)(IANS(I),I=1,IWIDTH) 2317 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2319 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2321) 2321 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2322) 2322 FORMAT(' THE SPECIFIED SECOND ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2323) 2323 FORMAT(' (VARIABLE NAME OR COLUMN NUMBER)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2324) 2324 FORMAT(' ON THE RIGHT OF THE = SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2325) 2325 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2326) 2326 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2327) 2327 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2328) 2328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2329)(IANS(I),I=1,IWIDTH) 2329 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2390 CONTINUE C ILIST2=I2 ICOL2=IVALUE(ILIST2) NIRIG2=IN(ILIST2) C C ****************************************************** C ** STEP 6.4-- ** C ** CHECK THAT THE 2 VARIABLES HAVE THE SAME ** C ** NUMBER OF ELEMENTS. ** C ****************************************************** C ISTEPN='6.4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NIRIG2.EQ.NIRIGH)GOTO2490 IF(IFLAGD.EQ.'ON')GOTO2490 C WRITE(ICOUT,2411) 2411 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2412) 2412 FORMAT(' FOR A 2-VARIABLE STATISTIC CALCULATION,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2413) 2413 FORMAT(' THE NUMBER OF OBSERVATIONS IN EACH VARIABLE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2414) 2414 FORMAT(' MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2415) 2415 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2416)IHARG3,IHARG4,NIRIGH 2416 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2417)IHARG5,IHARG6,NIRIG2 2417 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2418) 2418 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2419)(IANS(I),I=1,IWIDTH) 2419 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 2490 CONTINUE C C ******************************* C ** STEP 7-- ** C ** DETERMINE THE SUBCASE ** C ** AND BRANCH ACCORDINGLY. ** C ******************************* C 700 CONTINUE ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IARG4F=IFOUNZ(4) IARG4T=ITYPE(4) C ICASEL='UNKN' IF(IARG4F.EQ.'NO')ICASEL='PARA' IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB')ICASEL='ELEM' CCCCC THE FOLLOWING LINE WAS REPLACED (DECEMBER 1988) CCCCC BY THE SUCCEEDING LINE (DECEMBER 1988) CCCCC TO ALLOW LET X(K) = MEAN ETC. INSIDE LOOP (DECEMBER 1988) CCCCC IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')ICASEL='VAR' IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')ICASEL='ELEM' IF(ICASEL.EQ.'UNKN'.OR.ICASEL.EQ.'VAR')GOTO710 GOTO729 C 710 CONTINUE WRITE(ICOUT,711) 711 FORMAT('***** ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,712) 712 FORMAT(' UNKNOWN VARIABLE/PARAMETER EXPRESSION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,713) 713 FORMAT(' TO THE LEFT OF THE EQUAL SIGN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,718) 718 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719)(IANS(I),I=1,IWIDTH) 719 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 729 CONTINUE C ICASEQ='UNKN' IMIN=ILOCV+1 IF(IMIN.GT.NUMARG)GOTO741 DO740I=IMIN,NUMARG IF(IHARG(I).EQ.'SUBS'.AND.IHARG2(I).EQ.'ET ')GOTO742 IF(IHARG(I).EQ.'EXCE'.AND.IHARG2(I).EQ.'PT ')GOTO742 IF(IHARG(I).EQ.'FOR '.AND.IHARG2(I).EQ.' ')GOTO743 740 CONTINUE 741 CONTINUE ICASEQ='FULL' GOTO749 742 CONTINUE ICASEQ='SUBS' GOTO749 743 CONTINUE ICASEQ='FOR' GOTO749 749 CONTINUE IF(ICASEQ.EQ.'UNKN')GOTO750 C IF(ICASEQ.EQ.'FULL')GOTO8000 IF(ICASEQ.EQ.'SUBS')GOTO9000 IF(ICASEQ.EQ.'FOR')GOTO10000 C 750 CONTINUE WRITE(ICOUT,751) 751 FORMAT('***** INTERNAL ERROR IN DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,752) 752 FORMAT(' UNKNOWN QUALIFIER TYPE FOR LET COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,758) 758 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,759)(IANS(I),I=1,IWIDTH) 759 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C C ************************************************ C ** STEP 8-- ** C ** TREAT THE FULL VARIABLE CASE. ** C ** EXAMPLE--LET Y = SORT(X) ** C ** --LET Y(I) = SORT(X) ** C ** JUMP TO STEP NUMBER 11 BELOW ** C ** FOR THE ACTUAL STATISTICAL CALCULATION, ** C ** FOR THE LIST UPDATING, AND ** C ** FOR SOME INFORMATIVE PRINTING. ** C ************************************************ C 8000 CONTINUE ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NIOLD=NIRIGH IF(NUMVAR.GE.2.AND.NIRIG2.GT.NIOLD)NIOLD=NIRIG2 NINEW=NIOLD DO8100I=1,NINEW ISUB(I)=1 8100 CONTINUE GOTO11000 C C **************************************************************** C ** STEP 9-- * C ** TREAT THE PARTIAL VARIABLE SUBSET CASE. * C ** EXAMPLE--LET Y = SORT(X) SUBSET 2 3 5 * C ** --LET Y(I) = SORT(X) SUBSET 2 3 5 * C ** JUMP TO STEP NUMBER 11 BELOW * C ** FOR THE ACTUAL STATISTICAL CALCULATION, * C ** FOR THE LIST UPDATING, AND * C ** FOR SOME INFORMATIVE PRINTING. * C **************************************************************** C 9000 CONTINUE ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMVAR.EQ.1)ILOCSV=ILOCV+2 IF(NUMVAR.EQ.2)ILOCSV=ILOCV+3 IHSET=IHARG(ILOCSV) IHSET2=IHARG2(ILOCSV) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHSET,IHSET2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO19000 NIOLD=IN(ILOC) CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) CCCCC NINEW=NS NINEW=NIOLD GOTO11000 C C **************************************************************** C ** STEP 10-- * C ** TREAT THE PARTIAL VARIABLE FOR CASE. * C ** EXAMPLE--LET Y = SORT(X) FOR I = 1 2 10 * C ** --LET Y(I) = SORT(X) FOR I = 1 2 10 * C ** JUMP TO STEP NUMBER 11 BELOW * C ** FOR THE ACTUAL STATISTICAL CALCULATION, * C ** FOR THE LIST UPDATING, AND * C ** FOR SOME INFORMATIVE PRINTING. * C **************************************************************** C 10000 CONTINUE ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPFOR(NIOLD,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIFOR=NINEW GOTO11000 C C ******************************************* C ** STEP 11-- ** C ** CARRY OUT THE ** C ** ACTUAL STATISTICAL CALCULATION, ZZ C ** THE LIST UPDATING, AND ** C ** GENERATE THE INFORMATIVE PRINTING ** C ** FOR STEP NUMBERS 7, 8, AND 9 ABOVE. ** C ******************************************* C 11000 CONTINUE ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 NS3=0 CCCCC NINEW=NIRIGH CCCCC IMAX=NINEW CCCCC IF(ICASEQ.EQ.'FOR'.AND.IMAX.GT.NIFOR)IMAX=NIFOR CCCCC DO11100I=1,IMAX DO11100I=1,NINEW IF(ISUB(I).EQ.0)GOTO11100 IF(I.GT.NIRIGH)GOTO11105 NS2=NS2+1 C IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)TEMP(NS2)=V(IJ) IF(ICOLR.EQ.MAXCP1)TEMP(NS2)=PRED(I) IF(ICOLR.EQ.MAXCP2)TEMP(NS2)=RES(I) IF(ICOLR.EQ.MAXCP3)TEMP(NS2)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)TEMP(NS2)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I) IF(NUMVAR.LE.1)GOTO11100 C 11105 CONTINUE IF(I.GT.NIRIG2)GOTO11100 IF(NUMVAR.LE.1)GOTO11100 NS3=NS3+1 IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)TEMP2(NS3)=V(IJ) IF(ICOL2.EQ.MAXCP1)TEMP2(NS3)=PRED(I) IF(ICOL2.EQ.MAXCP2)TEMP2(NS3)=RES(I) IF(ICOL2.EQ.MAXCP3)TEMP2(NS3)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)TEMP2(NS3)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)TEMP2(NS3)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)TEMP2(NS3)=TAGPLO(I) C 11100 CONTINUE C IF(NS2.LE.0)THEN IF(ICASL8.EQ.'NUMB')THEN RIGHT=0 IFOUND='YES' IF(ICASEL.EQ.'PARA')GOTO15000 IF(ICASEL.EQ.'ELEM')GOTO16000 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12111)ICASL8 12111 FORMAT('****** ERROR--AFTER SUBSET/FOR/EXCEPT CLAUSE ', 1 'APPLIED FOR STATISTIC ',A4,',') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12113) 12113 FORMAT(' THE RESPONSE VARIABLE IS EMPTY. THE ', 1 'STATISTIC WAS NOT COMPUTED.') CALL DPWRST('XXX','BUG ') IFOUND='YES' IERROR='YES' GOTO19000 ENDIF ENDIF C IWRITE='ON' IF(IPRINT.EQ.'OFF')IWRITE='OFF' IF(IFEEDB.EQ.'OFF')IWRITE='OFF' C CCCCC MARCH 2003: CALL CMPSTA TO COMPUTE THE STATISTIC. C CALL CMPSTA( 1 TEMP,TEMP2,XTEMP1,XTEMP2,XTEMP3, 1 MAXNXT,NS2,NS3,NUMVAR,ICASL8, 1 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 RIGHT, 1 ISUBRO,IBUGA3,IERROR) C GOTO11900 C 11900 CONTINUE IFOUND='YES' IF(IERROR.EQ.'YES')GOTO19000 IF(ICASEL.EQ.'PARA')GOTO15000 IF(ICASEL.EQ.'ELEM')GOTO16000 C C ***************************************************** C ** STEP 15-- ** C ** TREAT THE PARAMETER CASE. ** C ** EXAMPLE--LET A = MEAN X ** C ** WHERE A WAS PREVIOUSLY UNDEFINED ** C ** OR WHERE A WAS PREVIOUSLY A PARAMETER.** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ** THEN EXIT. ** C ***************************************************** C 15000 CONTINUE ISTEPN='15' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='P' VALUE(ILISTL)=RIGHT C ***** THE FOLLOWING LINE WAS ADDED 7/83 ***** IVALUE(ILISTL)=VALUE(ILISTL)+0.5 IN(ILISTL)=1 IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 C IF(IPRINT.EQ.'OFF')GOTO15119 IF(IFEEDB.EQ.'OFF')GOTO15119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15111)ILEFT,ILEFT2,RIGHT 15111 FORMAT('THE COMPUTED VALUE OF THE CONSTANT ', 1A4,A4,' = ',E15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 15119 CONTINUE GOTO19000 C C ********************************************* C ** STEP 16-- ** C ** TREAT THE ELEMENT SPECIFICATION CASE. ** C ** EXAMPLE--LET Y(4)=MEAN X ** C ** ALSO, CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ********************************************* C 16000 CONTINUE ISTEPN='16' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IARGL=INT1(4) IF(1.LE.IARGL.AND.IARGL.LE.MAXN)GOTO16100 WRITE(ICOUT,16001) 16001 FORMAT('***** ERROR IN DPSTAC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16002)IARGL,ILEFT 16002 FORMAT(' THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16003)RIGHT 16003 FORMAT(' (THAT WAS TO BE SET = ',E15.7,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16004) 16004 FORMAT(' WAS LESS THAN 1 OR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16005)MAXN 16005 FORMAT(' GREATER THAN THE MAX ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO19000 C 16100 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE ADDED (DECEMBER 1988) CCCCC TO FIX PROBLEM OF LET Y(K) = MEAN X (DECEMBER 1988) CCCCC INSIDE A LOOP (DECEMBER 1988) IF(NEWNAM.EQ.'NO')NIOLD=IN(ILISTL) IF(NEWNAM.EQ.'YES')NIOLD=1 NINEW=NIOLD IF(IARGL.GT.NINEW)NINEW=IARGL NS2=1 C IJ=MAXN*(ICOLL-1)+IARGL IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 C DO16200J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO16205 GOTO16200 16205 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 16200 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO16119 IF(IFEEDB.EQ.'OFF')GOTO16119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,16111)ILEFT,ILEFT2,IARGL,RIGHT 16111 FORMAT('THE COMPUTED VALUE OF ', 1A4,A4,'(',I6,') = ',E15.8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 16119 CONTINUE GOTO19000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 19000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO19090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19011) 19011 FORMAT('***** AT THE END OF DPSTAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19012)IFOUND,IERROR 19012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGA3,IBUGQ 9013 FORMAT('IBUGA3,IBUGQ = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICASL8,ILOCV,IWRITE,IFLAGD 9014 FORMAT('ICASL8,ILOCV,IWRITE,IFLAGD = ',A4,2X,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19015)NS2,NS3 19015 FORMAT('NS2,NS3 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19017)ICASEL,RIGHT 19017 FORMAT('ICASEL,RIGHT = ',A4,E15.7) CALL DPWRST('XXX','BUG ') 19090 CONTINUE C RETURN END SUBROUTINE DPSTAR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A STAR PLOT-- C A MULTIVARIATE TECHNICQUE WHICH PLOTS A SEQUENCE C OF RADIAL SPOKES AT EQUAL ANGLES AROUND A CIRCLE. C EACH RADIAL SPOKE REPRESENTS A SEPARATE VARIABLE. C THE LENGTH OF EACH RADIAL SPOKE IS PROPORTIONAL C TO THE RELATIVE SIZE OF THE RESPONSE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/2 C ORIGINAL VERSION--FEBRUARY 1988. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CCCCC CHARACTER*4 IH CCCCC CHARACTER*4 IH2 CCCCC CHARACTER*4 IERRO2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CCCCC CHARACTER*4 IHHOR CCCCC CHARACTER*4 IHHOR2 CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Z1(MAXOBV) DIMENSION Z2(MAXOBV) DIMENSION Z3(MAXOBV) DIMENSION YSUB(MAXOBV) DIMENSION YFULL(MAXOBV) DIMENSION XTEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Z1(1)) EQUIVALENCE (GARBAG(IGARB2),Z2(1)) EQUIVALENCE (GARBAG(IGARB3),Z3(1)) EQUIVALENCE (GARBAG(IGARB4),YSUB(1)) EQUIVALENCE (GARBAG(IGARB5),YFULL(1)) EQUIVALENCE (GARBAG(IGARB6),XTEMP(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IERROR='NO' C ISUBN1='DPST' ISUBN2='AR ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=2 C ICOLH=0 C C *********************************** C ** TREAT THE STAR PLOT CASE ** C *********************************** C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'STAR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSTAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO 52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASPL='STAR' C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO111 GOTO119 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO119 C 119 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C *********************************************************** C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 11-- ** C ** FOR A STAR PLOT, ** C ** WE MUST HAVE A SUBSET OR FOR ** C ** SO AS TO INDICATE EXACTLY WHICH ** C ** CAR, ETC. THE SINGLE STAR PLOT ** C ** WILL BE FORMED FOR. ** C ** CHECK TO SEE THE TYPE SUBCASE ** C ** (BASED ON THE QUALIFIER)-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1180 DO1100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO1110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO1110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO1120 1100 CONTINUE GOTO1180 1110 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1190 1120 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1190 C 1180 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('***** ERROR IN DPSTAR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182) 1182 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1183) 1183 FORMAT(' NUMARG LESS THAN 1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1184) 1184 FORMAT(' POSSIBLE CAUSE--AN OMITTED (BUT NEEDED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1185) 1185 FORMAT(' SUBSET/EXCEPT/FOR QUALIIFICATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186) 1186 FORMAT(' AT THE END OF THE STAR PLOT COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1187) 1187 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1188)(IANS(I),I=1,IWIDTH) 1188 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1190 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'STAR')GOTO1195 WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 1195 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF VARIABLES ** C ** TO BE INCLUDED AS PLOT COMPONENTS ** C ************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.GE.1)GOTO1290 C WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPSTAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' TO BE INCLUDED AS COMPONENTS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' IN A STAR PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' MUST BE 1 OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217) 1217 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1218)(IANS(I),I=1,IWIDTH) 1218 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' RETURN C 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** ALSO CHECK TO ASSURE THAT EACH ** C ** OF THE VARIABLES HAS AT LEAST ** C ** 2 OBSERVATIONS. ** C *************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1300I=1,NUMVAR C IHRIGH=IHARG(I) IHRIG2=IHARG2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C NRIGHT=IN(ILOCV) IF(NRIGHT.GE.MINN2)GOTO1390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPSTAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' (FOR WHICH A STAR PLOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT(' WAS TO HAVE BEEN FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)MINN2 1326 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1327) 1327 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,IWIDTH) 1329 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1390 CONTINUE C 1300 CONTINUE C C ************************************************* C ** STEP 21-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FOR EACH OF THE RESPONSE VARIABLES ** C ** EXTRACT THE DATA SUBSET ** C ** (USUALLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO2110 IF(ICASEQ.EQ.'SUBS')GOTO2120 IF(ICASEQ.EQ.'FOR')GOTO2130 C 2110 CONTINUE DO2115I=1,NRIGHT ISUB(I)=1 2115 CONTINUE NQ=NRIGHT GOTO2190 C 2120 CONTINUE NIOLD=NRIGHT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO2190 C 2130 CONTINUE NIOLD=NRIGHT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO2190 C 2190 CONTINUE C C ************************************************* C ** STEP 22-- ** C ** FOR EACH OF THE RESPONSE VARIABLES, ** C ** EXTRACT THE DATA SUBSET ** C ** (FREQUENTLY ONLY 1 OBSERVATION) ** C ** AND ALSO EXTRACT THE ** C ** MIN AND MAX FOR THE FULL VARIABLE ** C ************************************************* C ISTEPN='22' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2200K=1,NUMVAR IHRIGH=IHARG(K) IHRIG2=IHARG2(K) C DO2210I=1,NUMNAM I2=I IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO2219 2210 CONTINUE WRITE(ICOUT,2211) 2211 FORMAT('***** INTERNAL ERROR IN DPSTAR AT POINT 2210--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE VARIABLE ',I4,I4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' NOT NOW FOUND IN INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' ALTHOUGH ALREADY FOUND EARLIER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2216)(IANS(I),I=1,IWIDTH) 2216 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2219 CONTINUE C ILISTR=I2 ICOLR=IVALUE(ILISTR) NRIGHT=IN(ILISTR) C J=0 IMAX=NRIGHT IF(NQ.LT.NRIGHT)IMAX=NQ DO2240I=1,IMAX IF(ISUB(I).EQ.0)GOTO2240 J=J+1 IJ=MAXN*(ICOLR-1)+I IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1WRITE(ICOUT,2241)I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX 2241 FORMAT('I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX = ',8I8) IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL DPWRST('XXX','BUG ') IF(ICOLR.LE.MAXCOL)YSUB(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)YSUB(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)YSUB(J)=RES(I) IF(ICOLR.EQ.MAXCP3)YSUB(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)YSUB(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)YSUB(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)YSUB(J)=TAGPLO(I) 2240 CONTINUE NLOCAL=J NSUB=NLOCAL C J=0 IMAX=NRIGHT DO2250I=1,IMAX J=J+1 IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)YFULL(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)YFULL(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)YFULL(J)=RES(I) IF(ICOLR.EQ.MAXCP3)YFULL(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)YFULL(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)YFULL(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)YFULL(J)=TAGPLO(I) 2250 CONTINUE NFULL=J C IWRITE='OFF' CALL MEDIAN(YSUB,NSUB,IWRITE,XTEMP,MAXN,XMED,IBUGG3,IERROR) CALL MINIM(YFULL,NFULL,IWRITE,XMIN,IBUGG3,IERROR) CALL MAXIM(YFULL,NFULL,IWRITE,XMAX,IBUGG3,IERROR) Z1(K)=XMED Z2(K)=XMIN Z3(K)=XMAX C 2200 CONTINUE NZ=NUMVAR C C ************************************************************* C ** STEP 31-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S ** C ** FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, ** C ** AND THE UPPER CONFIDENCE LINE. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSTA2(Z1,Z2,Z3,NZ,ICASPL, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'STAR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSTAR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFOUND,IERROR 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ', 1I8,I8,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NSUB 9021 FORMAT('NSUB = ',I8) CALL DPWRST('XXX','BUG ') IF(NSUB.LE.0)GOTO9024 DO9022I=1,NSUB WRITE(ICOUT,9023)I,YSUB(I) 9023 FORMAT('I,YSUB(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9024 CONTINUE WRITE(ICOUT,9031)NFULL 9031 FORMAT('NFULL = ',I8) CALL DPWRST('XXX','BUG ') IF(NFULL.LE.0)GOTO9034 DO9032I=1,NFULL WRITE(ICOUT,9033)I,YFULL(I) 9033 FORMAT('I,YFULL(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9034 CONTINUE WRITE(ICOUT,9041)NZ 9041 FORMAT('NZ = ',I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO9044 DO9042I=1,NZ WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I) 9043 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9044 CONTINUE WRITE(ICOUT,9051)NPLOTP 9051 FORMAT('NPLOTP = ',I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9054 DO9052I=1,NPLOTP WRITE(ICOUT,9053)I,Y(I),X(I),D(I) 9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9054 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSTAT( 1IFOUND,IERROR) C C PURPOSE--WRITE OUT A STATUS LISTING OF PARAMETERS, C VARIABLES, AND PLOT SPECIFICATIONS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --APRIL 1978. C UPDATED --JULY 1978. C UPDATED --DECEMBER 1978. C UPDATED --MARCH 1979. C UPDATED --JULY 1979. C UPDATED --NOVEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1991. DIME, VARI, PARA, ETC. ARGS C UPDATED --DECEMBER 1991. VARI/PARAM FORMAT STATEMENTS C UPDATED --SEPTEMBER 1993. WRITE MESSAGE IF NO VAR., C PAR. FUNC., ETC. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IJUNK CHARACTER*4 IJUNK2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION IJUNK(100) DIMENSION IJUNK2(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCODB.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOF2.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPST' ISUBN2='AT ' C IFOUND='NO' IERROR='NO' C NI=0 NUMELE=0 KMAX=0 C IF(IBUGS2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPSTAT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2 53 FORMAT('IBUGS2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IPR 54 FORMAT('IPR = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)NUMARG 55 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IHARG(1) 56 FORMAT('IHARG(1) = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)NUMNAM 61 FORMAT('NUMNAM = ',I4) CALL DPWRST('XXX','BUG ') DO69I=1,NUMNAM WRITE(ICOUT,62)I,IHNAME(I),IHNAM2(I),IUSE(I) 62 FORMAT('I,IHNAME,IHNAM2,IUSE = ',I4,3(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IN(I),IVALUE(I),IVALU2(I) 63 FORMAT('IN,IVALUE,IVALU2 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IVSTAR(I),IVSTOP(I),VALUE(I) 64 FORMAT('IVSTAR,IVSTOP,VALUE = ',2I8,E15.7) CALL DPWRST('XXX','BUG ') 69 CONTINUE 90 CONTINUE C C ***************************** C ** TREAT THE STATUS CASE ** C ***************************** C IFOUND='YES' C C ********************************************* C ** STEP 10-- ** C ** PRINT OUT DETAILED STATUS INFORMATION ** C ********************************************* C C **************************************** C ** STEP 11-- ** C ** TREAT THE MACHINE CONSTANTS CASE ** C **************************************** C IF(IHARG(1).EQ.'MACH')GOTO1100 IF(IHARG(1).EQ.'COMP')GOTO1100 IF(IHARG(1).EQ.'SITE')GOTO1100 IF(IHARG(1).EQ.'HOST')GOTO1100 GOTO1190 C 1100 CONTINUE ISTEPN='11' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('STATUS OF MACHINE CONSTANTS--') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112)IHOST1,IHOST2 1112 FORMAT('IHOST1,IHOST2 (HOST) = ',A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1113)IHMOD1,IHMOD2 1113 FORMAT('IHMOD1,IHMOD2 (MODEL) = ',A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1114)IOPSY1,IOPSY2 1114 FORMAT('IOPSY1,IOPSY2 (OPERATING SYSTEM) = ',A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1115)ICOMPI 1115 FORMAT('ICOMPI (COMPILER) = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1116)ISITE 1116 FORMAT('ISITE (SITE) = ',A4) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1123)IPR,IRD,CPUMIN,CPUMAX 1123 FORMAT('IPR,IRD,CPUMIN,CPUMAX = ',2I6,2E15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1124)NUMBPC,NUMCPW,NUMBPW 1124 FORMAT('NUMBPC,NUMCPW,NUMBPW = ',3I6) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO1130I=1,16 IF(NUMBPW.LT.32)WRITE(ICOUT,1131)I,I1MACH(I) 1131 FORMAT('I,I1MACH(I) = ',I8,2X,I8) IF(NUMBPW.LT.32)CALL DPWRST('XXX','WRIT') IF(NUMBPW.EQ.32)WRITE(ICOUT,1132)I,I1MACH(I) 1132 FORMAT('I,I1MACH(I) = ',I8,2X,I11) IF(NUMBPW.EQ.32)CALL DPWRST('XXX','WRIT') IF(NUMBPW.EQ.36)WRITE(ICOUT,1133)I,I1MACH(I) 1133 FORMAT('I,I1MACH(I) = ',I8,2X,I12) IF(NUMBPW.EQ.36)CALL DPWRST('XXX','WRIT') IF(NUMBPW.EQ.48)WRITE(ICOUT,1134)I,I1MACH(I) 1134 FORMAT('I,I1MACH(I) = ',I8,2X,I16) IF(NUMBPW.EQ.48)CALL DPWRST('XXX','WRIT') IF(NUMBPW.GE.60)WRITE(ICOUT,1135)I,I1MACH(I) 1135 FORMAT('I,I1MACH(I) = ',I8,2X,I20) IF(NUMBPW.GE.60)CALL DPWRST('XXX','WRIT') IF(NUMBPW.GT.32.AND.NUMBPW.NE.36.AND. 1 NUMBPW.NE.48.AND.NUMBPW.NE.60)WRITE(ICOUT,1136)I,I1MACH(I) 1136 FORMAT('I,I1MACH(I) = ',I8,2X,I8) IF(NUMBPW.GT.32.AND.NUMBPW.NE.36.AND. 1 NUMBPW.NE.48.AND.NUMBPW.NE.60)CALL DPWRST('XXX','WRIT') 1130 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO1140I=1,5 WRITE(ICOUT,1141)I,R1MACH(I) 1141 FORMAT('I,R1MACH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','WRIT') 1140 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO1150I=1,5 WRITE(ICOUT,1151)I,D1MACH(I) 1151 FORMAT('I,D1MACH(I) = ',I8,2X,D15.7) CALL DPWRST('XXX','WRIT') 1150 CONTINUE GOTO9000 C 1190 CONTINUE C C *************************** C ** STEP 12-- ** C ** TREAT THE FILE CASE ** C *************************** C IF(IHARG(1).EQ.'FILE')GOTO1200 IF(IHARG(1).EQ.'I/O')GOTO1200 GOTO1290 C 1200 CONTINUE ISTEPN='12' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1211) 1211 FORMAT('STATUS OF FILES--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1253)IPR,IRD,CPUMIN,CPUMAX 1253 FORMAT('IPR,IRD,CPUMIN,CPUMAX = ',2I6,2E15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1254)NUMBPC,NUMCPW,NUMBPW 1254 FORMAT('NUMBPC,NUMCPW,NUMBPW = ',3I6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1261)IMESNU,IMESST,IMESNA 1261 FORMAT('IMESNU,IMESST,IMESNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1262)INEWNU,INEWST,INEWNA 1262 FORMAT('INEWNU,INEWST,INEWNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1263)IMAINU,IMAIST,IMAINA 1263 FORMAT('IMAINU,IMAIST,IMAINA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1264)IHELNU,IHELST,IHELNA 1264 FORMAT('IHELNU,IHELST,IHELNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1265)IBUGNU,IBUGST,IBUGNA 1265 FORMAT('IBUGNU,IBUGST,IBUGNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1266)IQUENU,IQUEST,IQUENA 1266 FORMAT('IQUENU,IQUEST,IQUENA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1267)ISYSNU,ISYSST,ISYSNA 1267 FORMAT('ISYSNU,ISYSST,ISYSNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1268)ILOGNU,ILOGST,ILOGNA 1268 FORMAT('ILOGNU,ILOGST,ILOGNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1271)IREANU,IREAST,IREANA 1271 FORMAT('IREANU,IREAST,IREANA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1272)IWRINU,IWRIST,IWRINA 1272 FORMAT('IWRINU,IWRIST,IWRINA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1273)ISAVNU,ISAVST,ISAVNA 1273 FORMAT('ISAVNU,ISAVST,ISAVNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1274)ICRENU,ICREST,ICRENA 1274 FORMAT('ICRENU,ICREST,ICRENA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') CCCCC WRITE(ICOUT,1275)IMACNU,IMACST,IMACNA C1275 FORMAT('IMACNU,IMACST,IMACNA = ',I8,2X,A12,2X,A80) CCCCC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1276)ISCRNU,ISCRST,ISCRNA 1276 FORMAT('ISCRNU,ISCRST,ISCRNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1277)IDATNU,IDATST,IDATNA 1277 FORMAT('IDATNU,IDATST,IDATNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1278)IPL1NU,IPL1ST,IPL1NA 1278 FORMAT('IPL1NU,IPL1ST,IPL1NA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1279)IPL2NU,IPL2ST,IPL2NA 1279 FORMAT('IPL2NU,IPL2ST,IPL2NA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1280)IPRONU,IPROST,IPRONA 1280 FORMAT('IPRONU,IPROST,IPRONA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1281)ICONNU,ICONST,ICONNA 1281 FORMAT('ICONNU,ICONST,ICONNA = ',I8,2X,A12,2X,A80) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') GOTO9000 C 1290 CONTINUE C C ***************************** C ** STEP 21-- ** C ** TREAT THE ARROWS CASE ** C ***************************** C IF(IHARG(1).EQ.'ARRO')GOTO2100 GOTO2190 C 2100 CONTINUE ISTEPN='21' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2111) 2111 FORMAT('STATUS OF ARROWS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2112)NUMARR 2112 FORMAT(' NUMBER OF ARROWS = ',I8) CALL DPWRST('XXX','WRIT') C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMARR.LE.0)GOTO2180 IF(NUMARR.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2105) 2105 FORMAT('NO ARROWS DEFINED') CALL DPWRST('XXX','WRIT') GOTO2180 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2115I=1,NUMARR IF(PARRXC(I,1).LT.0.0.OR.PARRXC(I,1).GT.100.0)GOTO2115 IF(PARRYC(I,1).LT.0.0.OR.PARRYC(I,1).GT.100.0)GOTO2115 IF(PARRXC(I,2).LT.0.0.OR.PARRXC(I,2).GT.100.0)GOTO2115 IF(PARRYC(I,2).LT.0.0.OR.PARRYC(I,2).GT.100.0)GOTO2115 WRITE(ICOUT,2116)I,PARRXC(I,1),PARRYC(I,1),PARRXC(I,2),PARRYC(I,2) 2116 FORMAT(' ARROW ',I8,' COORDINATES --',4F10.4) CALL DPWRST('XXX','WRIT') 2115 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2125I=1,NUMARR WRITE(ICOUT,2126)I,IARRCO(I) 2126 FORMAT(' ARROW ',I8,' COLOR --',A4) CALL DPWRST('XXX','WRIT') 2125 CONTINUE C 2180 CONTINUE GOTO9000 C 2190 CONTINUE C C ******************************* C ** STEP 22-- ** C ** TREAT THE SEGMENTS CASE ** C ******************************* C IF(IHARG(1).EQ.'SEGM')GOTO2200 GOTO2290 C 2200 CONTINUE ISTEPN='22' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2211) 2211 FORMAT('STATUS OF SEGMENTS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2212)NUMSEG 2212 FORMAT(' NUMBER OF SEGMENTS = ',I8) CALL DPWRST('XXX','WRIT') C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMSEG.LE.0)GOTO2280 IF(NUMSEG.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2205) 2205 FORMAT('NO SEGMENTS DEFINED') CALL DPWRST('XXX','WRIT') GOTO2280 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2215I=1,NUMSEG IF(PSEGXC(I,1).LT.0.0.OR.PSEGXC(I,1).GT.100.0)GOTO2215 IF(PSEGYC(I,1).LT.0.0.OR.PSEGYC(I,1).GT.100.0)GOTO2215 IF(PSEGXC(I,2).LT.0.0.OR.PSEGXC(I,2).GT.100.0)GOTO2215 IF(PSEGYC(I,2).LT.0.0.OR.PSEGYC(I,2).GT.100.0)GOTO2215 WRITE(ICOUT,2216)I,PSEGXC(I,1),PSEGYC(I,1),PSEGXC(I,2),PSEGYC(I,2) 2216 FORMAT(' SEGMENT ',I8,' COORDINATES --',4F10.4) CALL DPWRST('XXX','WRIT') 2215 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2225I=1,NUMSEG WRITE(ICOUT,2226)I,ISEGCO(I) 2226 FORMAT(' SEGMENT ',I8,' COLOR --',A4) CALL DPWRST('XXX','WRIT') 2225 CONTINUE C 2280 CONTINUE GOTO9000 C 2290 CONTINUE C C ****************************** C ** STEP 23-- ** C ** TREAT THE LEGENDS CASE ** C ****************************** C IF(IHARG(1).EQ.'LEGE')GOTO2300 GOTO2390 C 2300 CONTINUE ISTEPN='23' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2311) 2311 FORMAT('STATUS OF LEGENDS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2312)NUMLEG 2312 FORMAT(' NUMBER OF LEGENDS = ',I8) CALL DPWRST('XXX','WRIT') C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMLEG.LE.0)GOTO2380 IF(NUMLEG.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2305) 2305 FORMAT('NO LEGENDS DEFINED') CALL DPWRST('XXX','WRIT') GOTO2380 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2315I=1,NUMLEG JMIN=ILEGST(I) JMAX=ILEGSP(I) WRITE(ICOUT,2316)I,(ILEGTE(J),J=JMIN,JMAX) 2316 FORMAT(' LEGEND ',I8,'--',100A1) CALL DPWRST('XXX','WRIT') 2315 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2325I=1,NUMLEG IF(PLEGXC(I).LT.0.0.OR.PLEGXC(I).GT.100.0)GOTO2325 IF(PLEGYC(I).LT.0.0.OR.PLEGYC(I).GT.100.0)GOTO2325 WRITE(ICOUT,2326)I,PLEGXC(I),PLEGYC(I) 2326 FORMAT(' LEGEND ',I8,' COORDINATES --',2F10.4) CALL DPWRST('XXX','WRIT') 2325 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2335I=1,NUMLEG WRITE(ICOUT,2336)I,ILEGCO(I) 2336 FORMAT(' LEGEND ',I8,' COLOR --',A4) CALL DPWRST('XXX','WRIT') 2335 CONTINUE C 2380 CONTINUE GOTO9000 C 2390 CONTINUE C C **************************** C ** STEP 24-- ** C ** TREAT THE BOXES CASE ** C **************************** C IF(IHARG(1).EQ.'BOXE')GOTO2400 IF(IHARG(1).EQ.'BOX')GOTO2400 GOTO2490 C 2400 CONTINUE ISTEPN='24' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2411) 2411 FORMAT('STATUS OF BOXES--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2412)NUMBOX 2412 FORMAT(' NUMBER OF BOXES = ',I8) CALL DPWRST('XXX','WRIT') C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMBOX.LE.0)GOTO2480 IF(NUMBOX.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2405) 2405 FORMAT('NO BOXES DEFINED') CALL DPWRST('XXX','WRIT') GOTO2480 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2415I=1,NUMBOX IF(PBOXXC(I,1).LT.0.0.OR.PBOXXC(I,1).GT.100.0)GOTO2415 IF(PBOXYC(I,1).LT.0.0.OR.PBOXYC(I,1).GT.100.0)GOTO2415 IF(PBOXXC(I,2).LT.0.0.OR.PBOXXC(I,2).GT.100.0)GOTO2415 IF(PBOXYC(I,2).LT.0.0.OR.PBOXYC(I,2).GT.100.0)GOTO2415 WRITE(ICOUT,2416)I,PBOXXC(I,1),PBOXYC(I,1),PBOXXC(I,2),PBOXYC(I,2) 2416 FORMAT(' BOX ',I8,' CORNER COORDINATES--',4F10.4) CALL DPWRST('XXX','WRIT') 2415 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO2425I=1,NUMBOX WRITE(ICOUT,2426)I,IBOPCO(I) 2426 FORMAT(' BOX ',I8,' COLOR --',A4) CALL DPWRST('XXX','WRIT') 2425 CONTINUE C 2480 CONTINUE GOTO9000 C 2490 CONTINUE C C **************************** C ** STEP 31-- ** C ** TREAT THE SPIKE CASE ** C **************************** C IF(IHARG(1).EQ.'SPIK')GOTO3100 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(IHARG(1).EQ.'S ')GOTO3100 GOTO3190 C 3100 CONTINUE ISTEPN='31' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3111) 3111 FORMAT('STATUS OF SPIKE SETTINGS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3112) 3112 FORMAT(' SET SPIKE SPIKE SPIKE SPIKE ', 1' SPIKE ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3113) 3113 FORMAT(' INDEX SWITCH LINE COLOR THICKNESS', 1' BASE ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IMAX=10 CCCCC IF(NUMSET.GT.IMAX)IMAX=NUMSET DO3120I=1,IMAX WRITE(ICOUT,3121)I,ISPISW(I),ISPILI(I),ISPICO(I),PSPITH(I), 1ASPIBA(I) 3121 FORMAT(I5,8X,A4,6X,A4,6X,A4,6X,F7.3,3X,E15.7) CALL DPWRST('XXX','WRIT') 3120 CONTINUE WRITE(ICOUT,3122)IDEFSS,IDEFSL,IDEFSC,PDEFST,ADEFSB 3122 FORMAT('DEFAULT',6X,A4,6X,A4,6X,A4,6X,F7.3,3X,E15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C 3190 CONTINUE C C **************************** C ** STEP 32-- ** C ** TREAT THE BAR CASE ** C **************************** C IF(IHARG(1).EQ.'BAR ')GOTO3200 CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 IF(IHARG(1).EQ.'BARS')GOTO3200 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(IHARG(1).EQ.'B ')GOTO3200 GOTO3290 C 3200 CONTINUE ISTEPN='32' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3211) 3211 FORMAT('STATUS OF BAR SETTINGS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3212) 3212 FORMAT(' SET BAR BAR BAR BAR ', 1' BAR ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3213) 3213 FORMAT(' INDEX SWITCH FILL DIMENSION PATTERN', 1' BASE ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IMAX=10 CCCCC IF(NUMSET.GT.IMAX)IMAX=NUMSET DO3220I=1,IMAX WRITE(ICOUT,3221)I,IBARSW(I),IBAFSW(I),IBARTY(I),IBAPTY(I), 1ABARBA(I) 3221 FORMAT(I5,8X,A4,6X,A4,6X,A4,6X,A4,6X,E15.7) CALL DPWRST('XXX','WRIT') 3220 CONTINUE WRITE(ICOUT,3222)IDEBSW,IDEBFS,IDEBTY,IDEBPT,ADEBBA 3222 FORMAT('DEFAULT',6X,A4,6X,A4,6X,A4,6X,A4,6X,E15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C 3290 CONTINUE C C ************************************* C ** STEP 70-- ** C ** TREAT THE GENERAL STATUS CASE ** C ************************************* C C ***************************** C ** STEP 70.1-- ** C ** PRINT OUT A ** C ** STORAGE SUMMARY TABLE ** C ***************************** C 100 CONTINUE C ISTEPN='70.1' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING 4 LINES WERE ADDED DECEMBER 1991 IF(NUMARG.LE.0)GOTO109 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIME')GOTO109 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'D ')GOTO109 GOTO149 109 CONTINUE C NUMN=0 DO110I=1,NUMNAM IF(IHNAME(I).EQ.'PRED')GOTO110 IF(IHNAME(I).EQ.'RES')GOTO110 IF(IHNAME(I).EQ.'YPLO')GOTO110 IF(IHNAME(I).EQ.'XPLO')GOTO110 IF(IHNAME(I).EQ.'X2PL')GOTO110 IF(IHNAME(I).EQ.'TAGP')GOTO110 IF(IUSE(I).EQ.'V')NI=IN(I) IF(NI.GT.NUMN)NUMN=NI 110 CONTINUE C NUMNK=MAXN*NUMCOL IDELCO=MAXCOL-NUMCOL IDELN=MAXN-NUMN IDELNK=MAXNK-NUMNK IDELCF=MAXCHF-NUMCHF IDELNA=MAXNAM-NUMNAM C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,131) 131 FORMAT('****************************************************') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,132) 132 FORMAT('* STORAGE INFORMATION *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,131) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,133) 133 FORMAT('* NUMBER OF ... * MAXIMUM * UNUSED * USED *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,131) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,141)MAXCOL,IDELCO,NUMCOL 141 FORMAT('* VARIABLES (COLUMNS)*',I7,' *',I7,' *',I7,' *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,142)MAXN,IDELN,NUMN 142 FORMAT('* OBS PER VARIABLE *',I7,' *',I7,' *',I7,' *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,143)MAXNK,IDELNK,NUMNK 143 FORMAT('* OBS (TOTAL) *',I7,' *',I7,' *',I7,' *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,144)MAXCHF,IDELCF,NUMCHF 144 FORMAT('* FUNC CHAR (TOTAL) *',I7,' *',I7,' *',I7,' *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,145)MAXNAM,IDELNA,NUMNAM 145 FORMAT('* VAR/PAR/FUNC NAMES *',I7,' *',I7,' *',I7,' *') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,131) CALL DPWRST('XXX','WRIT') CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1991 149 CONTINUE C C ******************************* C ** STEP 70.2-- ** C ** PRINT OUT PLOT LINE, ** C ** PLOT CHARACTER, AND ** C ** PLOT LIMITS INFORMATION ** C ******************************* C ISTEPN='70.2' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING 4 LINES WERE ADDED DECEMBER 1991 IF(NUMARG.LE.0)GOTO209 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO209 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'C ')GOTO209 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LINE')GOTO209 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'L ')GOTO209 GOTO239 209 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,211) 211 FORMAT(' SET PLOT PLOT PLOT PLOT ', 1' PLOT ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,212) 212 FORMAT(' INDEX LINE LINE CHARACTER CHARACTER', 1' CHARACTER') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,213) 213 FORMAT(' TYPE COLOR TYPE COLOR ', 1' SIZE ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IMAX=10 CCCCC IF(NUMSET.GT.IMAX)IMAX=NUMSET DO220I=1,IMAX WRITE(ICOUT,221)I,ILINPA(I),ILINCO(I),ICHAPA(I),ICHACO(I), 1PCHAHE(I) 221 FORMAT(I5,8X,A4,6X,A4,6X,A4,6X,A4,4X,F7.3) CALL DPWRST('XXX','WRIT') 220 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,231)FX1MIN 231 FORMAT('X-AXIS PLOT MINIMUM = ',E15.8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,232)FX1MAX 232 FORMAT('X-AXIS PLOT MAXIMUM = ',E15.8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,233)FY1MIN 233 FORMAT('Y-AXIS PLOT MINIMUM = ',E15.8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,234)FY1MAX 234 FORMAT('Y-AXIS PLOT MAXIMUM = ',E15.8) CALL DPWRST('XXX','WRIT') CCCCC THE FOLLOWING LINE WAS INSERTED DECEMBER 1991 239 CONTINUE C C *************************************** C ** STEP 70.3-- ** C ** PRINT OUT VARIABLES INFORMATION ** C *************************************** C ISTEPN='70.3' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO379 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'VARI')GOTO379 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'VAR ')GOTO379 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'V ')GOTO379 GOTO399 379 CONTINUE C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMCOL.LE.0)GOTO399 IF(NUMCOL.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,355) 355 FORMAT('NO VARIABLES (= VECTORS) DEFINED') CALL DPWRST('XXX','WRIT') GOTO399 ENDIF C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') DO390I=1,NUMCOL NJUNK=0 DO391J=1,NUMNAM IF(I.EQ.IVALUE(J).AND.IUSE(J).EQ.'V')GOTO395 GOTO391 395 CONTINUE NJUNK=NJUNK+1 IJUNK(NJUNK)=IHNAME(J) IJUNK2(NJUNK)=IHNAM2(J) NUMELE=IN(J) 391 CONTINUE IF(NJUNK.GE.1)WRITE(ICOUT,397)I,NUMELE, 1(IJUNK(K),IJUNK2(K),K=1,NJUNK) CCCCC THE FOLLOWING 2 LINES WERE CHANGED DECEMBER 1991 CC397 FORMAT('VARIABLE ',I6,' (WITH ',I8,' ELEMENTS) ', CCCCC1'HAS THE FOLLOWING NAMES: ',10A4) 397 FORMAT('VARIABLE ',I5,' (',I8,' ELEMENTS) ', 1'IS: ',10A4) IF(NJUNK.GE.1)CALL DPWRST('XXX','WRIT') 390 CONTINUE 399 CONTINUE C CCCCC THE FOLLOWING SECTION WAS CHANGED SEPTEMBER 1993 C **************************** C ** STEP 70.4-- ** C ** PRINT OUT PARAMETERS ** C **************************** C ISTEPN='70.4' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO429 IF(NUMARG.LE.1)THEN IF(IHARG(1).EQ.'PARA')GOTO429 IF(IHARG(1).EQ.'PAR ')GOTO429 IF(IHARG(1).EQ.'P ')GOTO429 ENDIF GOTO490 429 CONTINUE C NUMPAR=0 IF(NUMNAM.LE.0)GOTO480 C DO430J=1,NUMNAM IF(IUSE(J).EQ.'P')THEN NUMPAR=NUMPAR+1 IF(NUMPAR.LE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,436)IHNAME(J),IHNAM2(J),VALUE(J) CALL DPWRST('XXX','WRIT') 436 FORMAT('PARAMETER ',2A4,' HAS THE VALUE: ',E15.7) ENDIF 430 CONTINUE C 480 CONTINUE IF(NUMPAR.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,481) 481 FORMAT('NO PARAMETERS (= SCALARS) DEFINED') CALL DPWRST('XXX','WRIT') ENDIF C 490 CONTINUE C C CCCCC THE FOLLOWING SECTION WAS CHANGED SEPTEMBER 1993 C **************************** C ** STEP 70.5-- ** C ** PRINT OUT FUNCTIONS ** C **************************** C ISTEPN='70.5' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO529 IF(NUMARG.LE.1)THEN IF(IHARG(1).EQ.'FUNC')GOTO529 IF(IHARG(1).EQ.'FUN ')GOTO529 IF(IHARG(1).EQ.'F ')GOTO529 ENDIF GOTO590 529 CONTINUE C NUMFUN=0 IF(NUMNAM.LE.0)GOTO580 C DO530J=1,NUMNAM IF(IUSE(J).EQ.'F')THEN NUMFUN=NUMFUN+1 IF(NUMFUN.LE.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF IMIN=IVSTAR(J) IMAX=IVSTOP(J) IDEL=IMAX-IMIN+1 NUMLIN=((IDEL-1)/100)+1 C IF(NUMLIN.LE.0)GOTO530 DO540KLINE=1,NUMLIN IF(KLINE.EQ.1)THEN KMIN=IMIN KMAX=KMIN+100-1 IF(KMAX.GT.IMAX)KMAX=IMAX WRITE(ICOUT,552)IHNAME(J),IHNAM2(J), 1 (IFUNC(K),K=KMIN,KMAX) 552 FORMAT('FUNCTION ',2A4,'--',100A1) CALL DPWRST('XXX','WRIT') ENDIF C IF(KLINE.GE.2)THEN KMIN=KMAX+1 KMAX=KMIN+100-1 IF(KMAX.GT.IMAX)KMAX=IMAX WRITE(ICOUT,562)(IFUNC(K),K=KMIN,KMAX) 562 FORMAT(18X,100A1) CALL DPWRST('XXX','WRIT') ENDIF 540 CONTINUE C ENDIF 530 CONTINUE C 580 CONTINUE IF(NUMFUN.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,581) 581 FORMAT('NO FUNCTIONS (= STRINGS) DEFINED') CALL DPWRST('XXX','WRIT') ENDIF C 590 CONTINUE C C *************************************** C ** STEP 70.6-- ** C ** PRINT OUT MATRIX INFORMATION ** C *************************************** C ISTEPN='70.6' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING 4 LINES WERE ADDED DECEMBER 1991 IF(NUMARG.LE.0)GOTO629 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MATR')GOTO629 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'M ')GOTO629 GOTO639 629 CONTINUE C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC IF(NUMNAM.LE.0)GOTO619 IF(NUMNAM.LE.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,605) 605 FORMAT('NO MATRICES DEFINED') CALL DPWRST('XXX','WRIT') GOTO619 ENDIF C IPASS=0 DO610J=1,NUMNAM IF(IUSE(J).EQ.'M')GOTO615 GOTO610 C 615 CONTINUE IPASS=IPASS+1 IF(IPASS.EQ.1)WRITE(ICOUT,999) IF(IPASS.EQ.1)CALL DPWRST('XXX','WRIT') IF(IPASS.EQ.1)WRITE(ICOUT,999) IF(IPASS.EQ.1)CALL DPWRST('XXX','WRIT') NR1=IN(J) NC1=IVALU2(J)-IVALUE(J)+1 WRITE(ICOUT,616)IHNAME(J),IHNAM2(J),NR1,NC1,IVALUE(J) 616 FORMAT('MATRIX ',2A4,' HAS ',I8,' ROWS AND ',I8,' COLUMNS ', 1'(AND STARTS IN COLUMN ',I8,')') CALL DPWRST('XXX','WRIT') 610 CONTINUE 619 CONTINUE 639 CONTINUE C C ************************** C ** STEP 70.7-- ** C ** PRINT OUT THE LAST ** C ** MODEL FITTED ** C ************************** C ISTEPN='70.7' IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING 4 LINES WERE ADDED DECEMBER 1991 IF(NUMARG.LE.0)GOTO729 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')GOTO729 GOTO749 729 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') IF(NUMCHM.EQ.0)WRITE(ICOUT,731) 731 FORMAT('MODEL--NO MODEL YET DEFINED') IF(NUMCHM.EQ.0)CALL DPWRST('XXX','WRIT') IF(NUMCHM.EQ.0)GOTO749 DO740I=1,20 I2=I IF(MODEL(I).NE.' ')GOTO748 740 CONTINUE 748 CONTINUE WRITE(ICOUT,741)(MODEL(I),I=I2,NUMCHM) 741 FORMAT('MODEL--',120A1) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 749 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPSTAT--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9013)IBUGS2,IFOUND,IERROR 9013 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','WRIT') 9090 CONTINUE C RETURN END SUBROUTINE DPSTA2(Z1,Z2,Z3,NZ,ICASPL, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C A STAR PLOT C (USEFUL FOR MULTIVARIATE ANALYSIS). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/2 C ORIGINAL VERSION--JANUARY 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Z1(*) DIMENSION Z2(*) DIMENSION Z3(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPST' ISUBN2='A2 ' C IERROR='NO' C TWOPI=2.0*3.1415926 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NZ.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPSTA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,33) 33 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)NZ 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'STA2')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPSTA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV 72 FORMAT('ICASPL,NZ,N2,NPLOTV = ',A4,2X,3I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO83 DO81I=1,NZ WRITE(ICOUT,82)I,Z1(I),Z2(I),Z3(I) 82 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 81 CONTINUE 83 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** DETERMINE PLOT COORDINATES ** C **************************************** C ANZ=NZ C J=0 K=1 DO1100I=1,NZ AI=I ANUM=Z1(I)-Z2(I) ADEN=Z3(I)-Z2(I) P=0.0 IF(ADEN.GT.0.0)P=ANUM/ADEN THETA=((AI-1.0)/ANZ)*TWOPI J=J+1 Y2(J)=P*SIN(THETA) X2(J)=P*COS(THETA) D2(J)=K 1100 CONTINUE J=J+1 Y2(J)=Y2(1) X2(J)=X2(1) D2(J)=D2(1) C DO1200I=1,NZ AI=I THETA=((AI-1.0)/ANZ)*TWOPI J=J+1 K=K+1 Y2(J)=0.0 X2(J)=0.0 D2(J)=K J=J+1 Y2(J)=SIN(THETA) X2(J)=COS(THETA) D2(J)=K 1200 CONTINUE C N2=J NPLOTV=3 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'STA2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSTA2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR 9012 FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N2,J,K 9013 FORMAT('N2,J,K = ',3I8) CALL DPWRST('XXX','BUG ') IF(NZ.LE.0)GOTO9023 DO9021I=1,NZ WRITE(ICOUT,9022)I,Z1(I),Z2(I),Z3(I) 9022 FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE WRITE(ICOUT,9031)N2,NPLOTV 9031 FORMAT('N2,NPLOTV = ',2I8) CALL DPWRST('XXX','BUG ') DO9035I=1,N2 WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I) 9036 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSTE2(Y,W,N,YS,MAXN,IBUGG3,IERROR) C C PURPOSE--FORM A STEM AND LEAF DIAGRAM C OUTPUT--A STEM AND LEAF DIAGRAM C OF SMOOTHED VALUES. C NOTE--THE VECTOR Y REMAINS UNCHANGED. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS C 1977, PAGE 23 C (= SOURCE OF ALGORITHM). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C VERSION NUMBER--83.6 C ORIGINAL VERSION--JULY 1983. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*1 IA CHARACTER*1 M CHARACTER*1 IOUT C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION W(*) DIMENSION YS(*) C DIMENSION IOUT(132) DIMENSION IA(20) DIMENSION M(4) C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C DATA IA(1)/'0'/ DATA IA(2)/'1'/ DATA IA(3)/'2'/ DATA IA(4)/'3'/ DATA IA(5)/'4'/ DATA IA(6)/'5'/ DATA IA(7)/'6'/ DATA IA(8)/'7'/ DATA IA(9)/'8'/ DATA IA(10)/'9'/ DATA IA(11)/'0'/ DATA IA(12)/'1'/ DATA IA(13)/'2'/ DATA IA(14)/'3'/ DATA IA(15)/'4'/ DATA IA(16)/'5'/ DATA IA(17)/'6'/ DATA IA(18)/'7'/ DATA IA(19)/'8'/ DATA IA(20)/'9'/ C DATA M(1)/'-'/ DATA M(2)/' '/ DATA M(3)/':'/ DATA M(4)/'+'/ C C-----START POINT----------------------------------------------------- C IERROR='NO' C IWIDTH=50 SCALE=1.0 EPS=0.00000001 C IF(IBUGG3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3 52 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I) 56 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************ C ** FORM A STEM-AND-LEAF DIAGRAM ** C ************************************ C IF(N.GE.1)GOTO190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPSTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' NUMBER OF OBSERVATIONS IS NON-POSITIVE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113)N 113 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 190 CONTINUE C C C ********************* C ** STEP 1-- ** C ** SORT THE DATA ** C ********************* C CALL SORT(Y,N,YS) C C STEP 2-- C DEFINE C C RANGE=YS(N)-YS(1) R=EPS+RANGE/SCALE C C=10.0**(11-INT(ALOG10(R)+10.0)) ARG1=INT(R*C/25.0) ARG2=0 MAX=ARG1 IF(ARG2.GT.ARG1)MAX=ARG2 C ARG1=2 ARG2=MAX MM=ARG1 IF(ARG2.LT.ARG1)MM=ARG2 C K=3*MM+2-150/(N+50) IPROD=(K-1)*(K-2)*(K-5) IF(IPROD.EQ.0)C=C*10 C C STEP 3-- C DEFINE MU C MU=10 IPROD=K*(K-4)*(K-8) IF(IPROD.EQ.0)MU=5 IPROD=(K-1)*(K-5)*(K-6) IF(IPROD.EQ.0)MU=20 C I=1 IF(YS(1).GE.0)I=2 I2=1 TERM=INT(YS(I2)*C/MU)+I-2 D=MU*TERM/10.0 C C ***************************************** C ** STEP XX-- ** C ** SET UP A LOOP IN WHICH ** C ** EACH ITERATION OF THE LOOP ** C ** WILL FORM A NEW LINE (ROW) OF THE ** C ** STEM AND LEAF DIAGRAM ** C ***************************************** C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 1000 CONTINUE C C *************************************************************** C ** STEP XX-- ** C ** FORM THE NEXT OUTPUT LINE OF THE STEM AND LEAF DIAGRAM. ** C ** FILL THE OUTPUT LINE WITH BLANKS. ** C *************************************************************** C DO1100K=1,IWIDTH IOUT(K)=' ' 1100 CONTINUE C IF(I.EQ.2.OR.D.LE.0)GOTO1290 I=2 D=D-MU/10.0 1290 CONTINUE C ICOL=0 1300 CONTINUE ICOL=ICOL+1 TERM1=YS(I2)*C-10*INT(D) IY=INT(0.5+ABS(TERM1)) IF(YS(I2)*C-10*D.GE.0.5+(MU-1)*(I-1))GOTO1390 IF(ICOL.LE.IWIDTH)IOUT(ICOL)=IA(1+IY) I2=I2+1 IF(I2.GT.N)GOTO1390 GOTO1300 1390 CONTINUE C ID=MOD(IABS(INT(D)),100) K1=1+ID/10 K2=1+ID-10*(K1-1) IF(ICOL.LE.IWIDTH+1)GOTO1490 IOUT(IWIDTH-2)='+' IOUT(IWIDTH-1)=IA(1+(ICOL-IWIDTH+2)/10) IOUT(IWIDTH)=IA(ICOL-IWIDTH+3-10*((ICOL-IWIDTH+2)/10)) 1490 CONTINUE C C ********************************************** C ** STEP XX-- ** C ** WRITE OUT THE OUTPUT LINE FOR THIS ROW ** C ********************************************** C K=IWIDTH IF(ICOL.LT.IWIDTH)K=ICOL WRITE(ICOUT,1510)M(I),IA(K1),IA(K2),M(2),M(3),M(2), 1(IOUT(ICOL),ICOL=1,K) 1510 FORMAT(132A1) CALL DPWRST('XXX','BUG ') C C ***************************************************** C ** STEP XX-- ** C ** JUMP BACK TO THE BEGINNING OF THE LOOP ** C ** TO WORK ON THE NEXT LINE (ROW) OF THE DIAGRAM ** C ***************************************************** C IF(I2.GT.N)GOTO9000 D=D+MU/10.0 GOTO1000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGG3 9012 FORMAT('IBUGG3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)N 9014 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)I,Y(I),YS(I) 9016 FORMAT('I,Y(I),YS(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPSTEM(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A STEM AND LEAF DIAGRAM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83/7 C ORIGINAL VERSION--JULY 1983. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION TEMP(MAXOBV) C DIMENSION W(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),W(1)) EQUIVALENCE (GARBAG(IGARB2),TEMP(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPSU' ISUBN2='MM ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IFOUND='NO' IERROR='NO' C MAXV2=1 MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ************************************ C ** TREAT THE STEM AND LEAF CASE ** C ************************************ C IF(IBUGA2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPSTEM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C *************************** C ** STEP 2-- ** C ** EXTRACT THE COMMAND ** C *************************** C IF(NUMARG.GE.1.AND. 1IHARG(1).EQ.'PLOT')GOTO111 IF(NUMARG.GE.1.AND. 1IHARG(1).EQ.'DIAG'.AND.IHARG2(1).EQ.'RAM')GOTO111 C IF(NUMARG.GE.2.AND. 1IHARG(1).EQ.'AND'.AND. 1IHARG(2).EQ.'PLOT')GOTO112 IF(NUMARG.GE.2.AND. 1IHARG(2).EQ.'AND'.AND. 1IHARG(2).EQ.'DIAG'.AND.IHARG2(2).EQ.'RAM')GOTO112 C IF(NUMARG.GE.2.AND. 1IHARG(1).EQ.'LEAF'.AND. 1IHARG(2).EQ.'PLOT')GOTO112 IF(NUMARG.GE.2.AND. 1IHARG(2).EQ.'LEAF'.AND. 1IHARG(2).EQ.'DIAG'.AND.IHARG2(2).EQ.'RAM')GOTO112 C IF(NUMARG.GE.3.AND. 1IHARG(1).EQ.'AND'.AND. 1IHARG(2).EQ.'LEAF'.AND. 1IHARG(3).EQ.'PLOT')GOTO113 IF(NUMARG.GE.3.AND. 1IHARG(1).EQ.'AND'.AND. 1IHARG(2).EQ.'LEAF'.AND. 1IHARG(3).EQ.'DIAG'.AND.IHARG2(3).EQ.'RAM')GOTO113 IF(NUMARG.GE.3.AND. 1IHARG(1).EQ.'AND'.AND. 1IHARG(2).EQ.'LEAF')GOTO112 C IFOUND='YES' GOTO190 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 113 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLEFT,IHLEF2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR MORE. ** C *********************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPSTEM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A STEM AND LEAF DIAGRAM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317) 317 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ********************************************* C ** STEP 5-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE RESPONSE VARIABLE. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************* C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO510 IF(ICASEQ.EQ.'SUBS')GOTO520 IF(ICASEQ.EQ.'FOR')GOTO530 C 510 CONTINUE DO515I=1,NLEFT ISUB(I)=1 515 CONTINUE NQ=NLEFT GOTO550 C 520 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO550 C 550 CONTINUE IF(NQ.GE.MINN2)GOTO560 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPSTEM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553)IHLEFT,IHLEF2 553 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' (FOR WHICH A STEM AND LEAF DIAGRAM ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' IS TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556)MINN2 556 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 560 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO570I=1,IMAX IF(ISUB(I).EQ.0)GOTO570 J=J+1 C IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I) IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I) C 570 CONTINUE NS=J C C **************************************************************** C ** STEP 8-- C ** PREPARE FOR ENTRANCE INTO DPSTE2-- C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. C **************************************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,NS W(I)=1.0 1110 CONTINUE C C ********************************* C ** STEP 9-- ** C ** FORM THE STEM AND LEAF DIAGRAM. ** C ********************************* C ISTEPN='9' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** FROM DPSTEM, AS WE ARE ABOUT TO CALL DPSTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212)NLEFT,MAXN,NS 1212 FORMAT('NLEFT,MAXN,NS = ',3I8) CALL DPWRST('XXX','BUG ') DO1215I=1,NS WRITE(ICOUT,1216)I,Y(I),W(I) 1216 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 1215 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,1231)IBUGA3 1231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 1290 CONTINUE C CALL DPSTE2(Y,W,NS,TEMP,MAXN,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPSTEM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGQ 9013 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NLEFT,NS 9014 FORMAT('NLEFT,NS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ICASEQ 9015 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END