SUBROUTINE DPDDS(XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT A DDS (DATA-DEPENDENT SYSTEM) ANALYSIS C (1-SAMPLE) C EXAMPLE--DDS Y 6 5 DELT C DDS Y 6 5 (== DDS Y 6 5 1) C DDS Y (== DDS Y 6 5 1) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--94/4 C ORIGINAL VERSION--MARCH 1994. C UPDATED --APRIL 1996. DDS CODE MODIFIED (ALAN): C A) SOME DIMENSIONS TO DPDDS, USE C EQUIVALENCE C B) I/O CONSISTENT WITH DATAPLOT C C) USE IERROR RATHER THAN STOP C D) INCLUDE FILE FOR DDS COMMON C BLOCKS AND PARAMETER STATEMENTS C THESE CHANGES PROPOGATE TO LOWER C LEVEL DDS ROUTINES 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 C CHARACTER*4 IH11 CHARACTER*4 IH12 CHARACTER*4 IH21 CHARACTER*4 IH22 CHARACTER*4 IH31 CHARACTER*4 IH32 CHARACTER*4 IH41 CHARACTER*4 IH42 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 CCCCC MAY 1995. ADD FOLLOWING LINES CHARACTER*4 IUSE3 CHARACTER*4 IUSE4 CHARACTER*4 IREPU CHARACTER*4 IRESU C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION PRED2(MAXOBV) DIMENSION RES2(MAXOBV) CCCCC APRIL 1996. USE EQUIVALENCE, MOVE DIMENSIONS TO DPDDS INCLUDE 'DPCODD.INC' INCLUDE 'DPCOZZ.INC' DIMENSION XDDS(MAXOBV,MXSER) DIMENSION YDDS(MAXOBV,MXSER) DIMENSION Y2(100) DIMENSION AT(MXNOB1,MXSER) EQUIVALENCE (GARBAG(IGARB1),PRED2(1)) EQUIVALENCE (GARBAG(IGARB2),RES2(1)) EQUIVALENCE (GARBAG(IGARB3),XDDS(1,1)) EQUIVALENCE (GARBAG(IGARB3+3*MAXOBV),YDDS(1,1)) EQUIVALENCE (GARBAG(IGARB3+6*MAXOBV),AT(1,1)) EQUIVALENCE (GARBAG(IGARB3+6*MAXOBV+3*MXNOB1),Y2(1)) 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='DPDD' ISUBN2='S ' 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 N1=(-999) N2=(-999) C IUSE1='-999' IUSE2='-999' C NUMVAR=(-999) ILOCV=(-999) C VALUE1=(-999.0) VALUE2=(-999.0) C ICOL1=(-999) ICOL2=(-999) C MINN2=2 C IFOUND='YES' C NLEFT=0 C ICASEQ='UNKN' C C ******************************** C ** TREAT THE DDS 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 DPDDS--') 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 ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 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=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS SHOULD BE A VARIABLE) ** C **************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH11=IHARG(1) IH12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH11,IH12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) NUMVAR=1 C C ******************************************************** C ** STEP 12-- ** C ** IF ARGUMENT 1 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N1) ** C ** FOR ARGUMENT 1 IS 2 OR MORE. ** C ******************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.NE.'V')GOTO1290 IF(N1.GE.MINN2)GOTO1290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPDDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' (FOR WHICH A DDS ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215)MINN2 1215 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)IH11,IH12 1217 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1218)N1 1218 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1219) 1219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1220)(IANS(I),I=1,IWIDTH) 1220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 CONTINUE C C **************************************** C ** STEP 22-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS SHOULD BE A ** C ** A PARAMETER, OR A NUMBER). ** C **************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.1)IORDAR=2 IF(NUMARG.GE.2)THEN IH21=IHARG(2) IH22=IHARG2(2) IF(IARGT(2).EQ.'NUMB')THEN VALUE2=ARG(2) IORDAR=IARG(2) IUSE2='P' ENDIF ENDIF C C **************************************** C ** STEP 23-- ** C ** CHECK THE VALIDITY OF ARGUMENT 3 ** C ** (THIS SHOULD BE A ** C ** A PARAMETER, OR A NUMBER). ** C **************************************** C ISTEPN='23' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)IORDMA=1 IF(NUMARG.GE.3)THEN IH31=IHARG(3) IH32=IHARG2(3) IF(IARGT(3).EQ.'NUMB')THEN VALUE3=ARG(3) IORDMA=IARG(3) IUSE3='P' ENDIF ENDIF C C **************************************** C ** STEP 24-- ** C ** CHECK THE VALIDITY OF ARGUMENT 4 ** C ** (THIS SHOULD BE A ** C ** A PARAMETER, OR A NUMBER). ** C **************************************** C ISTEPN='24' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.3)DELTAT=1.0 IF(NUMARG.GE.4)THEN IH41=IHARG(4) IH42=IHARG2(4) IF(IARGT(4).EQ.'NUMB')THEN VALUE4=ARG(4) DELTAT=VALUE4 IUSE4='P' ENDIF ENDIF C C **************************************************************** C ** STEP 31-- ** C ** FOR A DDS ANALYSIS, ** C ** THE FIRST ARGUMENT ** C ** MUST BE A VARIABLE. ** C ** CHECK FOR THIS. ** C ** IF ONLY 1 ARGUMENT IS A VARIABLE, ** C ** THIS IMPLIES A 1-SAMPLE DDS ANALYSIS. ** C ** (IF SO, COPY THE OTHER ARGUMENT AS THE TARGET MU VALUE). ** C **************************************************************** C ISTEPN='31' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE1.NE.'V')GOTO3140 GOTO3190 C 3140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3141) 3141 FORMAT('***** ERROR IN DPDDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3142) 3142 FORMAT(' FOR A DDS ANALYSIS,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3143) 3143 FORMAT(' THE FIRST ARGUMENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3146) 3146 FORMAT(' MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3147) 3147 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3148) 3148 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3149) 3149 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3150)(IANS(I),I=1,IWIDTH) 3150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3190 CONTINUE C C ***************************************** C ** STEP 40-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='40' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO4090 DO4000J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO4010 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO4010 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO4020 4000 CONTINUE GOTO4090 4010 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO4090 4020 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO4090 4090 CONTINUE IF(IBUGA2.EQ.'OFF')GOTO4095 WRITE(ICOUT,4091)NUMARG,ILOCQ 4091 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 4095 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** TEMPORARILY FORM THE VARIABLE Y(.) ** C ** WHICH WILL HOLD THE DATA FROM SAMPLE 1. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE1.NE.'V')GOTO4190 C ISTEPN='41' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4110 IF(ICASEQ.EQ.'SUBS')GOTO4120 IF(ICASEQ.EQ.'FOR')GOTO4130 C 4110 CONTINUE DO4115I=1,N1 ISUB(I)=1 4115 CONTINUE NQ=N1 GOTO4150 C 4120 CONTINUE NIOLD=N1 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4150 C 4130 CONTINUE NIOLD=N1 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4150 C 4150 CONTINUE IF(NQ.GE.MINN2)GOTO4160 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4151) 4151 FORMAT('***** ERROR IN DPDDS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4152) 4152 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4153)IH11,IH12 4153 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4154) 4154 FORMAT(' (FOR WHICH A DDS ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4155) 4155 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4156)MINN2 4156 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4157)NQ 4157 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4158) 4158 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4159)(IANS(I),I=1,IWIDTH) 4159 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4160 CONTINUE J=0 IMAX=N1 IF(NQ.LT.N1)IMAX=NQ DO4170I=1,IMAX IF(ISUB(I).EQ.0)GOTO4170 J=J+1 C IJ=MAXN*(ICOL1-1)+I IF(ICOL1.LE.MAXCOL)Y(J)=V(IJ) IF(ICOL1.EQ.MAXCP1)Y(J)=PRED(I) IF(ICOL1.EQ.MAXCP2)Y(J)=RES(I) IF(ICOL1.EQ.MAXCP3)Y(J)=YPLOT(I) IF(ICOL1.EQ.MAXCP4)Y(J)=XPLOT(I) IF(ICOL1.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(ICOL1.EQ.MAXCP6)Y(J)=TAGPLO(I) C 4170 CONTINUE N1=J C 4190 CONTINUE C C ********************************* C ** STEP 52-- ** C ** FORM THE DDS ANALYSIS ** C ********************************* C ISTEPN='52' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5211) 5211 FORMAT('***** FROM DPDDS, AS WE ARE ABOUT TO CALL DPTTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,N1,N2,MAXN 5212 FORMAT('N1,N2,N1,N2,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,N1 WRITE(ICOUT,5216)I,Y(I) 5216 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE DO5217I=1,N1 WRITE(ICOUT,5218)I,Y(I) 5218 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5217 CONTINUE CCCCC IBUGA3='ABCD' WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CCCCC APRIL 1996. ADD XDDS, YDDS, Y2 TO ARGUMENT LIST (DIMENSIONING DONE CCCCC IN DPDDS RATHER THAN IN DPDDS2 AND DPDDS3 TO ALLOW USE OF EQUIVALENCE CCCCC WITH DATAPLOT SCRATCH ARRAYS) CALL DPDDS2(Y,N1,IORDAR,IORDMA,DELTAT,NUMVAR,ILOCV, CCCCC1XTEMP1,XTEMP2,MAXNXT,PRED2,RES2,RESSD,RESDF,IBUGA3,IERROR) 1XTEMP1,XTEMP2,XDDS,YDDS,AT,Y2,MAXNXT,PRED2,RES2,RESSD,RESDF, 1IBUGA3,IERROR) C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOLPR=MAXCP1 ICOLRE=MAXCP2 IREPU='OFF' IRESU='ON' NLEFT=N1 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 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 DPDDS--') 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