SUBROUTINE DPBABA(ADEBBA,MAXBAR,ABARBA, CCCCC OCTOBER 1993. ABOVE LINE MODIFIED (DPCOHK.INC NOW INCLUDED CCCCC IN THIS ROUTINE, SO NO NEED TO PASS). CCCCC SUBROUTINE DPBABA(IHARG,IARGT,ARG,NUMARG,ADEBBA,MAXBAR,ABARBA, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR BASES. C THESE ARE LOCATED IN THE VECTOR ABARBA(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --ADEBBA C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ABARBA (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 --OCTOBER 1993. ADD BAR BASE AUTOMATIC Y C BAR BASE AUTO DISTINCT Y C THESE USEFUL FOR STACKED BARS C UPDATED --NOVEMBER 1994. DECLARATION OF IBUGQ C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC OCTOBER 1993. COMMENT OUT FOLLOWING 2 LINES CCCCC CHARACTER*4 IHARG CCCCC 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 CCCCC OCTOBER 1993. COMMNET OUT FOLLOWING 3 LINES CCCCC DIMENSION IHARG(*) CCCCC DIMENSION IARGT(*) CCCCC DIMENSION ARG(*) DIMENSION ABARBA(*) CCCCC OCTOBER 1993. ADD FOLLOWING SECTION. CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IWRITE CCCCC NOVEMBER 1994. ADD FOLLOWING LINE. CHARACTER*4 IBUGQ C C CCCCC OCTOBER 1993. ADD FOLLOWING COMMON BLOCKS C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPBA' ISUBN2='BA ' C NUMBAR=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 DPBABA--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)ADEBBA 55 FORMAT('ADEBBA = ',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)ABARBA(1) 70 FORMAT('ABARBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ABARBA(I) 76 FORMAT('I,ABARBA(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 CCCCC OCTOBER 1993. ADD BAR BASE AUTOMATIC IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000 C 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=ADEBBA 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 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 NUMBAR=1 ABARBA(1)=ADEBBA GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEBBA IF(IHOLD1.EQ.'OFF')HOLD2=ADEBBA IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBBA IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBBA ABARBA(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,ABARBA(I) 1276 FORMAT('THE BASE OF BAR ',I6, 1' HAS JUST BEEN SET TO ',E15.7) 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 NUMBAR=MAXBAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEBBA IF(IHOLD1.EQ.'OFF')HOLD2=ADEBBA IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBBA IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBBA DO1315I=1,NUMBAR ABARBA(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)ABARBA(I) 1316 FORMAT('THE BASE OF ALL BARS', 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1319 CONTINUE IFOUND='YES' GOTO9000 C C ****************************************************** C ** STEP 30-- ** C ** TREAT THE BAR BASE AUTOMATIC CASE** C ****************************************************** C 3000 CONTINUE C C ******************************************** C ** STEP 31-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='31' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(3) IHLEF2=IHARG2(3) IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')IHLEFT=IHARG(4) IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')IHLEF2=IHARG2(4) 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 32-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='32' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO3290 DO3200J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO3210 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO3210 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO3220 3200 CONTINUE GOTO3290 3210 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO3290 3220 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO3290 3290 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO3295 WRITE(ICOUT,3291)NUMARG,ILOCQ 3291 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 3295 CONTINUE C C ********************************************* C ** STEP 33-- ** 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='33' IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO3310 IF(ICASEQ.EQ.'SUBS')GOTO3320 IF(ICASEQ.EQ.'FOR')GOTO3330 C 3310 CONTINUE DO3315I=1,NLEFT ISUB(I)=1 3315 CONTINUE NQ=NLEFT GOTO3350 C 3320 CONTINUE NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO3350 C 3330 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO3350 C 3350 CONTINUE MINN2=1 IF(NQ.GE.MINN2)GOTO3360 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3351) 3351 FORMAT('***** ERROR IN DPBABA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3352) 3352 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3353)IHLEFT,IHLEF2 3353 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3354) 3354 FORMAT(' (FOR WHICH BAR BASE DEFINITIONS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3355) 3355 FORMAT(' ARE TO BE GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3356)MINN2 3356 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3357) 3357 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3358) 3358 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH) 3359 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3360 CONTINUE MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO3370I=1,IMAX IF(ISUB(I).EQ.0)GOTO3370 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 3370 CONTINUE NS=J NY=J C C ***************************************** C ** STEP 34-- ** C ** IF HAVE THE FORM-- ** C ** BAR BASE AUTOMATIC DISTINCT X ** C ** EXTRACT THE DISTINCT VALUES ** C ** FROM THE TARGET VARIABLE Y(.) . ** C ** STORE THEM IN X(.) . ** C ** IF HAVE THE FORM-- ** C ** CHARACTERS AUTOMATIC X ** C ** DO NOTHING ** C ***************************************** C IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')GOTO3420 C 3410 CONTINUE DO3411I=1,NY X(I)=Y(I) 3411 CONTINUE NX=NY GOTO3490 C 3420 CONTINUE IWRITE='OFF' CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR) GOTO3490 C 3490 CONTINUE C C ****************************************** C ** STEP 36-- ** C ** COPY VALUES IN X(.) TO ABARBA ** C ** MAX NUMBER OF BARS = 100 ** C ****************************************** C IMAX=NX IF(IMAX.GT.MAXBAR)IMAX=MAXBAR DO3650I=1,IMAX ABARBA(I)=X(I) 3650 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO3679 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO3675I=1,IMAX WRITE(ICOUT,3676)I,ABARBA(I) 3676 FORMAT('BAR BASE ',I6,' HAS JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 3675 CONTINUE 3679 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 DPBABA--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)ADEBBA 9015 FORMAT('ADEBBA = ',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)ABARBA(1) 9030 FORMAT('ABARBA(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ABARBA(I) 9036 FORMAT('I,ABARBA(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBACL(IHARG,NUMARG,IDEFBK,IBACCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE BACKGROUND C (THE REGION WITHIN THE FRAME LINES). C THE COLOR FOR THE BACKGROUND WILL BE PLACED C IN THE HOLLERITH VARIABLE IBACCO. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFBK C OUTPUT ARGUMENTS--IBACCO 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--SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFBK CHARACTER*4 IBACCO 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(NUMARG.EQ.0)GOTO1150 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO1150 GOTO1110 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IBACCO=IDEFBK GOTO1180 C 1160 CONTINUE IBACCO=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBACCO 1181 FORMAT('THE BACKGROUND COLOR HAS JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBACO(IHARG,NUMARG,IDEFBC,MAXBAR,IBARCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR COLORS. C THESE ARE LOCATED IN THE VECTOR IBARCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFBC C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBARCO (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 IDEFBC CHARACTER*4 IBARCO 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 IBARCO(*) 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 NUMBAR=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 DPBACO--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEFBC 55 FORMAT('IDEFBC = ',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)IBARCO(1) 70 FORMAT('IBARCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBARCO(I) 76 FORMAT('I,IBARCO(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=IDEFBC 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 NUMBAR=1 IBARCO(1)=IDEFBC GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFBC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFBC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFBC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFBC IBARCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBARCO(I) 1276 FORMAT('BAR (LINE) 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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEFBC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFBC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFBC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFBC DO1315I=1,NUMBAR IBARCO(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)IBARCO(I) 1316 FORMAT('ALL BAR (LINE) 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 DPBACO--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEFBC 9015 FORMAT('IDEFBC = ',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)IBARCO(1) 9030 FORMAT('IBARCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBARCO(I) 9036 FORMAT('I,IBARCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBADI(IHARG,NUMARG,IDEBDI,MAXBAR,IBARDI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR DIRECTION-- C VERT = VERTICAL C HORI = HORIZONTAL C HOR2 = HORIZONTAL TOWARD X2-X3 PLANE (FOR 3D PLOTS) C THESE ARE LOCATED IN THE VECTOR IBARDI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBDI C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBARDI (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 IDEBDI CHARACTER*4 IBARDI 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 IBARDI(*) 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='DPBA' ISUBN2='DI ' C NUMBAR=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 DPBADI--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBDI 55 FORMAT('IDEBDI = ',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)IBARDI(1) 70 FORMAT('IBARDI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBARDI(I) 76 FORMAT('I,IBARDI(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 NUMBAR=1 IBARDI(1)='VERT' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR 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=IDEBDI CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBDI IBARDI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBARDI(I) 1276 FORMAT('BAR 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 NUMBAR=MAXBAR IHOLD2=IHOLD1 C???? IF(IHOLD1.EQ.'2')IHOLD2='2' C???? IF(IHOLD1.EQ.'3')IHOLD2='3' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBDI CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBDI DO1315I=1,NUMBAR IBARDI(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)IBARDI(I) 1316 FORMAT('ALL BAR 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 DPBADI--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBDI 9015 FORMAT('IDEBDI = ',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)IBARDI(1) 9030 FORMAT('IBARDI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBARDI(I) 9036 FORMAT('I,IBARDI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBAEF(IHARG,IARGT,ARG,NUMARG,BARHEF,BARWEF, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE BAR EXPANSION FACTORS C FOR THE HEIGHT AND WIDTH OF BARS IN BLOCK PLOTS (ONLY) C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--BARHEF = BAR HEIGHT EXPANSION FACTOR C --BARWEF = BAR WIDTH EXPANSION FACTOR C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 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 ORIGINAL VERSION--APRIL 1992. 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 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) 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='DPBA' ISUBN2='EF ' 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 DPBAEF--') 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,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)BARHEF,BARWEF 70 FORMAT('BARHEF,BARWEF = ',2E15.7) CALL DPWRST('XXX','BUG ') 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.GE.1)THEN IF(IHARG(NUMARG).EQ.'ON')GOTO1100 IF(IHARG(NUMARG).EQ.'OFF')GOTO1100 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1100 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1100 ENDIF GOTO1900 1100 CONTINUE BARHEF=1.0 BARWEF=1.0 GOTO8000 1900 CONTINUE C IF(NUMARG.EQ.1)THEN BARHEF=1.0 BARWEF=1.0 GOTO8000 ENDIF C IF(NUMARG.GE.2)THEN IF(IARGT(NUMARG-1).EQ.'NUMB'.AND.IARGT(NUMARG).EQ.'NUMB')THEN BARHEF=ARG(NUMARG-1) BARWEF=ARG(NUMARG) GOTO8000 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1041) 1041 FORMAT('***** ERROR IN DPBAEF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1042) 1042 FORMAT(' THE LAST 2 ARGUMENTS OF THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1043) 1043 FORMAT(' BAR EXPANSION FACTORS COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1044) 1044 FORMAT(' MUST BE NUMBERS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1045) 1045 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1046) 1046 FORMAT(' EXAMPLE--BAR EXPANSION FACTORS 1.1 0.8') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ENDIF C 8000 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO8090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8011) 8011 FORMAT('THE BAR EXPANSION FACTORS (HEIGHT & WIDTH)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8012) 8012 FORMAT('(FOR BLOCK PLOTS ONLY)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8013)BARHEF,BARWEF 8013 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7) CALL DPWRST('XXX','BUG ') 8090 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 DPBAEF--') 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,9020)NUMARG 9020 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9030I=1,NUMARG WRITE(ICOUT,9031)IHARG(I),IARGT(I),ARG(I) 9031 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') 9030 CONTINUE WRITE(ICOUT,9041)BARHEF,BARWEF 9041 FORMAT('BARHEF,BARWEF = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBAGP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1ISEED,MAXNPP, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--FORM A BAG PLOT C (A BIVARIATE EXTENSION OF THE BAG PLOT)2 DATA SETS). 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 REFERENCE--"The Bagplot: A Bivariate Boxplot", ROUSSEEUW, RUTS, C TUKEY, THE AMERICAN STATISTICIAN, November, 1999, C PP. 382-387. USES FORTRAN ROUTINE DOWNLOADED C FROM ROUSSEEUW WEB SITE. 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--2001/3 C ORIGINAL VERSION--MARCH 2001. 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 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IERRO4 C CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C PARAMETER (MAXOB2=MAXOBV/2) C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION Y4(MAXOBV) DIMENSION XD(MAXOBV) DIMENSION YD(MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZD.INC' INCLUDE 'DPCOZI.INC' INTEGER ITMP1(MAXOBV) INTEGER ITMP2(MAXOBV) INTEGER ITMP3(MAXOBV) INTEGER ITMP4(MAXOBV) INTEGER ITMP5(MAXOBV) INTEGER ITMP6(MAXOBV) INTEGER ITMP7(MAXOBV) INTEGER ITMP8(MAXOBV) INTEGER ITMP9(MAXOBV) INTEGER ITMP10(MAXOBV) INTEGER ITMP11(MAXOBV) INTEGER ITMP12(MAXOB2) INTEGER ITMP13(MAXOB2) INTEGER ITMP14(MAXOB2) INTEGER ITMP15(MAXOB2) INTEGER ITMP16(MAXOB2) INTEGER ITMP17(MAXOB2) INTEGER ITMP18(MAXOB2) INTEGER ITMP19(MAXOB2) INTEGER ITMP20(MAXOB2) INTEGER ITMP21(MAXOB2) C CCCCC DOUBLE PRECISION DTMP1(MAXOBV) CCCCC DOUBLE PRECISION DTMP2(MAXOBV) CCCCC DOUBLE PRECISION DTMP3(MAXOBV) CCCCC DOUBLE PRECISION DTMP4(MAXOBV) CCCCC DOUBLE PRECISION DTMP5(MAXOBV) CCCCC DOUBLE PRECISION DTMP6(MAXOBV) CCCCC DOUBLE PRECISION DTMP7(MAXOBV) CCCCC DOUBLE PRECISION DTMP8(MAXOBV) CCCCC DOUBLE PRECISION DTMP9(MAXOBV) CCCCC DOUBLE PRECISION DTMP10(MAXOBV) CCCCC DOUBLE PRECISION DTMP11(MAXOBV) CCCCC DOUBLE PRECISION DTMP12(MAXOBV) CCCCC DOUBLE PRECISION DTMP13(MAXOBV) CCCCC DOUBLE PRECISION DTMP14(MAXOBV) C CCCCC DOUBLE PRECISION DTMP15(MAXOB2) CCCCC DOUBLE PRECISION DTMP16(MAXOB2) CCCCC DOUBLE PRECISION DTMP17(MAXOB2) CCCCC DOUBLE PRECISION DTMP18(MAXOB2) CCCCC DOUBLE PRECISION DTMP19(MAXOB2) CCCCC DOUBLE PRECISION DTMP20(MAXOB2) CCCCC DOUBLE PRECISION DTMP21(MAXOB2) CCCCC DOUBLE PRECISION DTMP22(MAXOB2) CCCCC DOUBLE PRECISION DTMP23(MAXOB2) CCCCC DOUBLE PRECISION DTMP24(MAXOB2) CCCCC DOUBLE PRECISION DTMP25(MAXOB2) CCCCC DOUBLE PRECISION DTMP26(MAXOB2) CCCCC DOUBLE PRECISION DTMP27(MAXOB2) CCCCC DOUBLE PRECISION DTMP28(MAXOB2) CCCCC DOUBLE PRECISION DTMP29(MAXOB2) CCCCC DOUBLE PRECISION DTMP30(MAXOB2) CCCCC DOUBLE PRECISION DTMP31(MAXOB2) CCCCC DOUBLE PRECISION DTMP32(MAXOB2) CCCCC DOUBLE PRECISION DTMP33(MAXOB2) CCCCC DOUBLE PRECISION DTMP34(MAXOB2) CCCCC DOUBLE PRECISION DTMP35(MAXOB2) CCCCC DOUBLE PRECISION DTMP36(MAXOB2) CCCCC DOUBLE PRECISION DTMP37(MAXOB2) CCCCC DOUBLE PRECISION DTMP38(MAXOB2) CCCCC DOUBLE PRECISION DTMP39(MAXOB2) CCCCC DOUBLE PRECISION DTMP40(MAXOB2) CCCCC DOUBLE PRECISION DTMP41(MAXOB2) CCCCC DOUBLE PRECISION DTMP42(MAXOB2) CCCCC DOUBLE PRECISION DTMP43(MAXOB2) CCCCC DOUBLE PRECISION DTMP44(MAXOB2) CCCCC DOUBLE PRECISION DTMP45(MAXOB2) CCCCC EQUIVALENCE (IGARBG(IIGAR1),ITMP1(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR2),ITMP2(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR3),ITMP3(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR4),ITMP4(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR5),ITMP5(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR6),ITMP6(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR7),ITMP7(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR8),ITMP8(1)) CCCCC EQUIVALENCE (IGARBG(IIGAR9),ITMP9(1)) CCCCC EQUIVALENCE (IGARBG(IIGR10),ITMP10(1)) CCCCC EQUIVALENCE (IGARBG(IIGR11),ITMP11(1)) CCCCC EQUIVALENCE (IGARBG(IIGR12),ITMP12(1)) CCCCC EQUIVALENCE (IGARBG(IIGR12+MAXOB2+1),ITMP13(1)) CCCCC EQUIVALENCE (IGARBG(IIGR13),ITMP14(1)) CCCCC EQUIVALENCE (IGARBG(IIGR13+MAXOB2+1),ITMP15(1)) CCCCC EQUIVALENCE (IGARBG(IIGR14),ITMP16(1)) CCCCC EQUIVALENCE (IGARBG(IIGR14+MAXOB2+1),ITMP17(1)) CCCCC EQUIVALENCE (IGARBG(IIGR15),ITMP18(1)) CCCCC EQUIVALENCE (IGARBG(IIGR15+MAXOB2+1),ITMP19(1)) CCCCC EQUIVALENCE (IGARBG(IIGR16),ITMP20(1)) CCCCC EQUIVALENCE (IGARBG(IIGR16+MAXOB2+1),ITMP21(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR1),DTMP1(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR2),DTMP2(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR3),DTMP3(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR4),DTMP4(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR5),DTMP5(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR6),DTMP6(1)) CCCCC EQUIVALENCE (DGARBG(IDGAR7),DTMP7(1)) CCCCC EQUIVALENCE (GARBAG(IGARB1),DTMP8(1)) CCCCC EQUIVALENCE (GARBAG(IGARB3),DTMP9(1)) CCCCC EQUIVALENCE (GARBAG(IGARB5),DTMP10(1)) CCCCC EQUIVALENCE (GARBAG(IGARB7),DTMP11(1)) CCCCC EQUIVALENCE (GARBAG(IGARB9),DTMP12(1)) CCCCC EQUIVALENCE (GARBAG(JGAR11),DTMP13(1)) CCCCC EQUIVALENCE (GARBAG(JGAR13),DTMP14(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR11),DTMP15(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR12),DTMP16(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR13),DTMP17(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR14),DTMP18(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR15),DTMP19(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR16),DTMP20(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR17),DTMP21(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR18),DTMP22(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR19),DTMP23(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR20),DTMP24(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR21),DTMP25(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR22),DTMP26(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR23),DTMP27(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR24),DTMP28(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR25),DTMP29(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR26),DTMP30(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR27),DTMP31(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR28),DTMP32(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR29),DTMP33(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR30),DTMP34(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR31),DTMP35(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR32),DTMP36(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR33),DTMP37(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR34),DTMP38(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR35),DTMP39(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR36),DTMP40(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR37),DTMP41(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR38),DTMP42(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR39),DTMP43(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR40),DTMP44(1)) CCCCC EQUIVALENCE (G2RBAG(IGAR41),DTMP45(1)) 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 ISUBN1='DPBA' ISUBN2='GP ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=6 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BAGP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISEED,IBUGG2,IBUGG3,IBUGQ 54 FORMAT('ISEED,IBUGG2,IBUGG3,IBUGQ = ', 1I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASPL,MAXN 56 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)MAXNPP 58 FORMAT('MAXNPP = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *********************************** C ** TREAT THE BAG PLOT CASE ** C *********************************** C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BAG '.AND. 1 IHARG(2).EQ.'PLOT')GOTO1112 GOTO9000 C 1112 CONTINUE ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C 1190 CONTINUE IFOUND='YES' ICASPL='BAGP' C C ******************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BAGP')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ******************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.2)GOTO1490 GOTO1410 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,1412) 1412 FORMAT(' FOR A BAG PLOT, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,MIN(IWIDTH,80)) 1424 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C ****************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE RESPECTIVELY. * C ****************************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1563)IHRIX1,IHRIX2 1563 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1566) 1566 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,MIN(80,IWIDTH)) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1573)IHRIX1,IHRIX2 1573 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1577)IHRI11,IHRI12 1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,MIN(80,IWIDTH)) 1579 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1580 CONTINUE IF(NIRIG1.EQ.NIRIG2)GOTO1590 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582) 1582 FORMAT(' THE BAG PLOT COMMAND REQUIRES BOTH VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1583) 1583 FORMAT(' HAVE THE SAME NUMBER OF OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1584)IHRI11,IHRI12,NIRIG1 1584 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1586)IHRI21,IHRI22,NIRIG2 1586 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1588) 1588 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1589)(IANS(I),I=1,MIN(80,IWIDTH)) 1589 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1590 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 IF(NIRIG2.GT.NIRIG1)NLOCAL=NIRIG2 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3253) 3253 FORMAT(' HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3255) 3255 FORMAT(' (FOR WHICH A QUANTILE PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,MIN(80,IWIDTH)) 3260 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** CONTAINING ** C ** THE VERTICAL AXIS VARIABLE ** C ** THE HORIZONTAL AXIS VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ DO3310I=1,IMAX IF(ISUB(I).EQ.0)GOTO3310 J=J+1 IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) 3310 CONTINUE NS1=J C J=0 IMAX=NIRIG2 IF(NQ.LT.NIRIG2)IMAX=NQ DO3320I=1,IMAX IF(ISUB(I).EQ.0)GOTO3320 J=J+1 IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) 3320 CONTINUE NS2=J C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT ** C ** AFTER SUBSETTING, EACH OF ** C ** THE 2 VARIABLES HAS AT LEAST ** C ** 6 POINTS (THE MINIMUM NEEDED ** C ** TO YIELD A PLOT). ** C ********************************************* C ISTEPN='34' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NS1.LE.MINN2.OR.NS2.LE.MINN2)GOTO3450 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPBAGP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3453) 3453 FORMAT(' HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454) 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3455) 3455 FORMAT(' (FOR WHICH A BAG PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3458) 3458 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3460) 3460 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3461)(IANS(I),I=1,MIN(80,IWIDTH)) 3461 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3490 CONTINUE C C ****************************************************** C ** STEP 41-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE * C ** PLOT. FORM THE CURVE DESIGNATION VARIABLE D(.). * C ** THIS WILL BE BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C ****************************************************** C ISTEPN='41' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAGP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS=NS1 IF(NS2.GT.NS1)NS=NS2 CCCCC CALL DPBAG2(Y1,NS1,Y2,NS2,ICASPL,MAXN, CCCCC1Y,X,D,NPLOTP,NPLOTV, CCCCC1ITMP1,ITMP2,ITMP3,ITMP4,ITMP5,ITMP6,ITMP7,ITMP8, CCCCC1ITMP9,ITMP10,ITMP11,ITMP12,ITMP13,ITMP14,ITMP15,ITMP16, CCCCC1ITMP17,ITMP18,ITMP19,ITMP20,ITMP21, CCCCC1DTMP1,DTMP2,DTMP3,DTMP4,DTMP5,DTMP6,DTMP7,DTMP8, CCCCC1DTMP9,DTMP10,DTMP11,DTMP12,DTMP13,DTMP14,DTMP15,DTMP16, CCCCC1DTMP17,DTMP18,DTMP19,DTMP20,DTMP21,DTMP22,DTMP23, CCCCC1DTMP24,DTMP25,DTMP26,DTMP27,DTMP28,DTMP29,DTMP30, CCCCC1DTMP31,DTMP32,DTMP33,DTMP34,DTMP35,DTMP36,DTMP37, CCCCC1DTMP38,DTMP39,DTMP40,DTMP41,DTMP42,DTMP43,DTMP44, CCCCC1DTMP45, CCCCC1IBUGG3,ISUBRO,IERROR) C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BAGP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBAGP--') 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)ICASPL,MAXN,NUMVAR 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2 9015 FORMAT('NIRIG1,NIRIG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9029 DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9051)IHRI11,IHRI12 9051 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IHRI21,IHRI22 9052 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9053)NS1,NS2,NS 9053 FORMAT('NS1,NS2,NS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBAR2(Y,X,N,NUMV2,ICASPL,ISIZE,ICONT, 1XIDTEM,TEMP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A QUADRUPLE OF COORDINATE VECTORS C THAT WILL DEFINE AN BAR PLOT. C IF ONLY 1 Y VALUE EXISTS FOR EACH X VALUE, C THEN A HISTOGRAM WILL RESULT (THE BAR WILL C REST ON 0); C IF MORE THAN 1 Y VALUE EXISTS FOR EACH X VALUE, C THEN THE BARS WILL BE SUSPENDED BETWEEN THE C MINIMUM AND MAXIMUM AT EACH X VALUE. 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 1982. C UPDATED --JANUARY 1989. CLASS WIDTH, 0 FREQ BARS (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION XIDTEM(*) DIMENSION TEMP(*) C C--------------------------------------------------------------------- C INCLUDE 'DPCOSU.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C ISUBN1='DPBA' ISUBN2='R2 ' C K=(-999) KP1=(-999) C I2=0 AN=0.0 C AN3=0 DENOM=0.0 CLWID=0.0 XSTART=0.0 XSTOP=0.0 KP4=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 DPBAR2--') 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 DPBAR2--') 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=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPBAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') 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')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPBAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT 71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),X(I) 73 FORMAT('I, Y(I), X(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE CCCCC WRITE(ICOUT,74)BAWID CCC74 FORMAT('BAWID = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH MEANS THAT A HISTOGRAM SHOULD RESULT ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.1)GOTO110 IF(NUMV2.EQ.2)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 DO160I=1,N IF(NUMSET.EQ.0)GOTO165 DO170J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO160 170 CONTINUE 165 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 160 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C XID1=XIDTEM(1) XID2=XIDTEM(NUMSET) C 190 CONTINUE C IF(NUMSET.EQ.0)WRITE(ICOUT,191) 191 FORMAT('ERROR IN DPBAR2 SUBROUTINE--NUMSET = 0') IF(NUMSET.EQ.0)CALL DPWRST('XXX','BUG ') IF(NUMSET.EQ.0)GOTO9000 IF(NUMSET.EQ.0)IERROR='YES' C IF(NUMSET.EQ.N)GOTO1000 GOTO2000 C C ******************************** C ** STEP 4-- ** C ** TREAT THE HISTOGRAM CASE ** C ******************************** C 1000 CONTINUE ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C KP3=0 C AN3=0.0 DENOM=0.0 C C ********************************************** C ** STEP 4.1-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C CALL SORT(X,N,D2) NM1=N-1 C BUG FIX: (AUGUST, 1987) USE CLASS WIDTH PARAMETER IF SPECIFIED CLWID=CLWIDT(1) IF(CLWID.GT.0.0)GOTO1105 C END FIX CLWID=D2(2)-D2(1) DO1100I=1,NM1 IP1=I+1 DELI=D2(IP1)-D2(I) IF(DELI.LT.CLWID)CLWID=DELI 1100 CONTINUE C BUG FIX CONTINUED 1105 CONTINUE C END FIX XSTART=D2(1)-(CLWID/2.0) XSTOP=D2(N)+(CLWID/2.0) C TOTWID=XSTOP-XSTART ANUMCL=TOTWID/CLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 AJ=J CLMAXJ=XSTART+AJ*CLWID ABSDEL=ABS(CLMAXJ-XSTOP) IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 4.2-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C DO1300J=1,NUMCLA D2(J)=0.0 1300 CONTINUE C 1510 CONTINUE DO1520I=1,N DO1530J=1,NUMCLA J2=J AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO1540 1530 CONTINUE GOTO1520 1540 CONTINUE D2(J2)=D2(J2)+Y(I) 1520 CONTINUE C C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C (ALTHOUGH THIS SHOULD NOT HAPPEN) C J=NUMCLA DO1550I=1,N AJ=J CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+Y(I) 1550 CONTINUE GOTO1590 C 1590 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO1595 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1591) 1591 FORMAT('***** IN THE MIDDLE OF DPBAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA 1592 FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8) CALL DPWRST('XXX','BUG ') DO1593J=1,NUMCLA AJ=J CLMINJ=XSTART+(AJ-1.0)*CLWID CLMAXJ=XSTART+AJ*CLWID IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP FJ=D2(J) WRITE(ICOUT,1594)J,CLMINJ,CLMAXJ,FJ 1594 FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 1593 CONTINUE 1595 CONTINUE C C ********************************** C ** STEP 4.3-- ** C ** DETERMINE PLOT COORDINATES ** C ********************************** C CCCCC IF(BAWID.EQ.CPUMIN)BAWID=CLWID C 1600 CONTINUE SUM=0.0 DO1610J=1,NUMCLA FJ=D2(J) SUM=SUM+FJ 1610 CONTINUE AN3=SUM C DENOM=1.0 C BUG FIX: AUGUST, 1987 DO NOT PLOT ZERO FREQUENCY BARS K=0 C END BUG FIX C DO1620J=1,NUMCLA C CCCCC K=4*(J-1)+1 CCCCC KP1=K+1 CCCCC KP2=K+2 CCCCC KP3=K+3 C BUG FIX CONTINUED CCCCC K=J C END BUG FIX C CCCCC AJ=J CCCCC CLMIDJ=XSTART+(AJ-0.5)*CLWID CCCCC BAMINJ=CLMIDJ-BAWID/2.0 CCCCC BAMAXJ=CLMIDJ+BAWID/2.0 AJ=J CLMIDJ=XSTART+(AJ-0.5)*CLWID C FJ=D2(J) C BUG FIX CONTINUED IF(ABS(FJ).LE.CPUMIN)GOTO1620 K=K+1 C END FIX C CCCCC X2(K)=BAMINJ CCCCC X2(KP1)=BAMINJ CCCCC X2(KP2)=BAMAXJ CCCCC X2(KP3)=BAMAXJ X2(K)=CLMIDJ C CCCCC Y2(K)=0.0 CCCCC Y2(KP1)=FJ/DENOM CCCCC Y2(KP2)=FJ/DENOM CCCCC Y2(KP3)=0.0 Y2(K)=FJ/DENOM C 1620 CONTINUE C C BUG FIX CONTINUED NUMCLA=K C END FIX DO1720J=1,NUMCLA C CCCCC K=4*(J-1)+1 CCCCC KP1=K+1 CCCCC KP2=K+2 CCCCC KP3=K+3 K=J C CCCCC D2(K)=J CCCCC D2(KP1)=J CCCCC D2(KP2)=J CCCCC D2(KP3)=J D2(K)=J C 1720 CONTINUE CCCCC N2=KP3 N2=K NPLOTV=3 GOTO9000 C C ***************************************************** C ** STEP 14-- ** C ** TREAT THE SUSPENDED BAR CASE. ** C ** STEP THROUGH THE VARIOUS HORIZONTAL AXIS SETS ** C ** AND COMPUTE BAR COORDINATES FOR EACH SET. ** C ***************************************************** C 2000 CONTINUE C ISTEPN='14' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMSM1=NUMSET-1 C CONTINUE BUG FIX CLWID=CLWIDT(1) IF(CLWID.GT.0.)GOTO2060 C END FIX CLWID=XIDTEM(2)-XIDTEM(1) DO2050I=1,NUMSM1 IP1=I+1 DELI=XIDTEM(IP1)-XIDTEM(I) IF(DELI.LT.CLWID)CLWID=DELI 2050 CONTINUE C CONTINUE BUG FIX 2060 CONTINUE C END FIX CCCCC IF(BAWID.EQ.CPUMIN)BAWID=CLWID C AN=N ANUMSE=NUMSET C J=0 JD=0 DO2100ISET=1,NUMSET C K=0 DO2120I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 2120 CONTINUE NI=K ANI=NI C IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2121)ISET,XIDTEM(ISET),NI 2121 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NI.LE.0)GOTO2140 GOTO2149 C 2140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** INTERNAL ERROR IN DPBAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2143)ISET,XIDTEM(ISET),NI 2143 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2149 CONTINUE C CALL SORT(TEMP,NI,TEMP) YMIN=TEMP(1) YMAX=TEMP(NI) IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2151)YMIN,YMAX,ISET,K,TEMP(K) 2151 FORMAT('YMIN,YMAX,ISET,K,TEMP(K) = ',2E15.7,2I8,E15.7) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C J=ISET C CCCCC K=5*(J-1)+1 CCCCC KP1=K+1 CCCCC KP2=K+2 CCCCC KP3=K+3 CCCCC KP4=K+4 K=2*(J-1)+1 KP1=K+1 C CCCCC CLMIDJ=XIDTEM(ISET) CCCCC BAMINJ=CLMIDJ-BAWID/2.0 CCCCC BAMAXJ=CLMIDJ+BAWID/2.0 CLMIDJ=XIDTEM(ISET) C CCCCC X2(K)=BAMINJ CCCCC X2(KP1)=BAMINJ CCCCC X2(KP2)=BAMAXJ CCCCC X2(KP3)=BAMAXJ CCCCC X2(KP4)=BAMINJ X2(K)=CLMIDJ X2(KP1)=CLMIDJ C CCCCC Y2(K)=YMIN CCCCC Y2(KP1)=YMAX CCCCC Y2(KP2)=YMAX CCCCC Y2(KP3)=YMIN CCCCC Y2(KP4)=YMIN Y2(K)=YMIN Y2(KP1)=YMAX C CCCCC D2(K)=J CCCCC D2(KP1)=J CCCCC D2(KP2)=J CCCCC D2(KP3)=J CCCCC D2(KP4)=J D2(K)=J D2(KP1)=J C 2620 CONTINUE C 2100 CONTINUE CCCCC N2=KP4 N2=KP1 NPLOTV=3 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 DPBAR2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMV2 9013 FORMAT('NUMV2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)AN,NI 9014 FORMAT('AN,NI = ',E15.7,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9032)IERROR,N2 9032 FORMAT('IERROR,N2 = ',A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)AN3,DENOM 9033 FORMAT('AN3,DENOM = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9037)N,CLWID,XSTART,XSTOP 9037 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO9050I=1,NUMSET WRITE(ICOUT,9051)I,XIDTEM(I) 9051 FORMAT('I,XIDTEM(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9050 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBARP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A BAR PLOT = A BAR CHART = C A HISTOGRAM 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 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 IRELAT CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IDATA CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 CHARACTER*4 ICONT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C CCCCC DIMENSION BAWIDT(*) C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION XIDTEM(MAXOBV) DIMENSION TEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(1)) EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP(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='DPBA' ISUBN2='RP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 C MAXV2=2 MINN2=2 C ICOLR=0 C C ******************************* C ** TREAT THE BAR PLOT CASE ** C ******************************* C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBARP--') 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 ') CCCCC WRITE(ICOUT,54)BAWIDT(1),BAWIDT(2) CCC54 FORMAT('BAWIDT(1),BAWIDT(2) = ',2E15.7) CCCCC 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 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO110 C IFOUND='NO' GOTO9000 C 110 CONTINUE ICASPL='BARP' IRELAT='OFF' ILASTC=1 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='1' 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 C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' 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) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPBARP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A HISTOGRAM ') IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A RELATIVE HISTOGRAM ') IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,323) 323 FORMAT(' (FOR WHICH A CUMULATIVE HISTOGRAM ') IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,324) 324 FORMAT(' (FOR WHICH A RELATIVE CUMULATIVE HISTOGRAM ') IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') 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 4-- ** 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='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 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 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPBARP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 5-- ** C ** IF A SECOND ARGUMENT EXISTS (AS IT SHOULD), THEN THIS C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATA='FREQ' IF(NUMV2.EQ.2)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) 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 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPBARP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A BAR PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 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 DPBARP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A BAR PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.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,IERRO4) 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 IF(NUMV2.LE.1)GOTO651 GOTO652 C 651 CONTINUE IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I) GOTO660 C 652 CONTINUE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) 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) GOTO660 C 660 CONTINUE NLOCAL=J C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CCCCC BAWID=BAWIDT(1) C NUMV2=2 ISIZE=1 ICONT='ON' CALL DPBAR2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT, 1XIDTEM,TEMP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) 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 DPBARP--') 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 ') CCCCC WRITE(ICOUT,9014)BAWIDT(1),BAWIDT(2) C9014 FORMAT('BAWIDT(1),BAWIDT(2) = ',2E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9015)BAWID C9015 FORMAT('BAWDI = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBASW(IHARG,NUMARG,IDEBSW,MAXBAR,IBARSW, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR SWITCHES. C THESE ARE LOCATED IN THE VECTOR IBARSW(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBSW C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBARSW (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 IDEBSW CHARACTER*4 IBARSW 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 IBARSW(*) 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='DPBA' ISUBN2='SW ' C NUMBAR=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 DPBASW--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBSW 55 FORMAT('IDEBSW = ',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)IBARSW(1) 70 FORMAT('IBARSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBARSW(I) 76 FORMAT('I,IBARSW(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='ON' 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 NUMBAR=1 IBARSW(1)='ON' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBSW CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBSW IBARSW(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBARSW(I) 1276 FORMAT('BAR ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBSW CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBSW DO1315I=1,NUMBAR IBARSW(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)IBARSW(I) 1316 FORMAT('ALL BARS ', 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 DPBASW--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBSW 9015 FORMAT('IDEBSW = ',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)IBARSW(1) 9030 FORMAT('IBARSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBARSW(I) 9036 FORMAT('I,IBARSW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBATY(IHARG,NUMARG,IDEBTY,MAXBAR,IBARTY, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR DIMENSION (2 OR 3) C THESE ARE LOCATED IN THE VECTOR IBARTY(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBTY C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBARTY (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--APRIL 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEBTY CHARACTER*4 IBARTY 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 IBARTY(*) 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='DPBA' ISUBN2='TY ' C NUMBAR=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 DPBATY--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBTY 55 FORMAT('IDEBTY = ',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)IBARTY(1) 70 FORMAT('IBARTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBARTY(I) 76 FORMAT('I,IBARTY(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='2' 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 NUMBAR=1 IBARTY(1)='2' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+1 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'2')IHOLD2='2' IF(IHOLD1.EQ.'3')IHOLD2='3' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBTY CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBTY IBARTY(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBARTY(I) 1276 FORMAT('BAR DIMENSION ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'2')IHOLD2='2' IF(IHOLD1.EQ.'3')IHOLD2='3' CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBTY CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBTY DO1315I=1,NUMBAR IBARTY(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)IBARTY(I) 1316 FORMAT('ALL BAR DIMENSIONS', 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 DPBATY--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBTY 9015 FORMAT('IDEBTY = ',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)IBARTY(1) 9030 FORMAT('IBARTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBARTY(I) 9036 FORMAT('I,IBARTY(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBAUD(IHARG,IARGT,IARG,NUMARG,IDEFBA, 1IBAUD,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAUD RATE AT WHICH THE TERMINAL C IS TRANSMITTING TO THE HOST. C THE SPECIFIED BAUD RATE VALUE WILL BE PLACED C IN THE INTEGER VARIABLE IBAUD. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C --IDEFBA (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IBAUD (AN INTEGER VARIABLE) 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--NOVEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) 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 1110 CONTINUE IF(NUMARG.LE.0)GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'?')GOTO8100 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPBAUD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR BAUD RATE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' SUPPOSE THE THE TERMINAL IS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' TRANSMITTING AT 9600 BAUD, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' THEN THE ALLOWABLE FORM IS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1128) 1128 FORMAT(' BAUD RATE 9600 ') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE IHOLD=IDEFBA GOTO1180 C 1160 CONTINUE IHOLD=IARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IBAUD=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBAUD 1181 FORMAT('THE BAUD RATE HAS JUST BEEN SET TO ', 1I8) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ******************************************** C ** STEP 81-- ** C ** TREAT THE ? CASE-- ** C ** DUMP OUT CURRENT AND DEFAULT VALUES. ** C ******************************************** C 8100 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111)IBAUD 8111 FORMAT('THE CURRENT BAUD RATE IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112)IDEFBA 8112 FORMAT('THE DEFAULT BAUD RATE IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPBAWI(IHARG,IARGT,ARG,NUMARG,ADEBWI,MAXBAR,ABARWI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR WIDTHS. C THESE ARE LOCATED IN THE VECTOR ABARWI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --ADEBWI C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--ABARWI (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 ABARWI(*) 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='DPBA' ISUBN2='WI ' C NUMBAR=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 DPBAWI--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)ADEBWI 55 FORMAT('ADEBWI = ',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)ABARWI(1) 70 FORMAT('ABARWI(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,ABARWI(I) 76 FORMAT('I,ABARWI(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=ADEBWI 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 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 NUMBAR=1 ABARWI(1)=ADEBWI GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-1 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+1 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEBWI IF(IHOLD1.EQ.'OFF')HOLD2=ADEBWI IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBWI IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBWI ABARWI(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,ABARWI(I) 1276 FORMAT('THE WIDTH OF BAR ',I6, 1' HAS JUST BEEN SET TO ',E15.7) 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 NUMBAR=MAXBAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=ADEBWI IF(IHOLD1.EQ.'OFF')HOLD2=ADEBWI IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBWI IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBWI DO1315I=1,NUMBAR ABARWI(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)ABARWI(I) 1316 FORMAT('THE WIDTH OF ALL BARS', 1' HAS JUST BEEN SET TO ',E15.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 DPBAWI--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)ADEBWI 9015 FORMAT('ADEBWI = ',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)ABARWI(1) 9030 FORMAT('ABARWI(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,ABARWI(I) 9036 FORMAT('I,ABARWI(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBBCO(IHARG,NUMARG,IDEBBC,MAXBAR,IBABCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR BORDER COLORS = THE COLORS C OF THE BORDER LINE AROUND THE BARS. C THESE ARE LOCATED IN THE VECTOR IBABCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBBC C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBABCO (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 IDEBBC CHARACTER*4 IBABCO 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 IBABCO(*) 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='DPBB' ISUBN2='CO ' C NUMBAR=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 DPBBCO--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBBC 55 FORMAT('IDEBBC = ',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)IBABCO(1) 70 FORMAT('IBABCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBABCO(I) 76 FORMAT('I,IBABCO(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBABCO(1)=IDEBBC GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBBC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBBC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBC IBABCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBABCO(I) 1276 FORMAT('THE COLOR OF BAR BORDER ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBBC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBBC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBC DO1315I=1,NUMBAR IBABCO(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)IBABCO(I) 1316 FORMAT('THE COLOR OF ALL BAR BORDERS', 1' HAS 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 DPBBCO--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBBC 9015 FORMAT('IDEBBC = ',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)IBABCO(1) 9030 FORMAT('IBABCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBABCO(I) 9036 FORMAT('I,IBABCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBBLI(IHARG,IHARG2,NUMARG,IDEBBL,MAXBAR,IBABLI, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPBBLI(IHARG,NUMARG,IDEBBL,MAXBAR,IBABLI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BORDER LINES = THE LINES TYPES C OF THE BORDER AROUND THE BARS. C THESE ARE LOCATED IN THE VECTOR IBABLI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBBL C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBABLI (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 IDEBBL CHARACTER*4 IBABLI 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 IBABLI(*) 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='DPBB' ISUBN2='LI ' C NUMBAR=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 DPBBLI--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBBL 55 FORMAT('IDEBBL = ',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)IBABLI(1) 70 FORMAT('IBABLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBABLI(I) 76 FORMAT('I,IBABLI(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.2)GOTO9000 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 IF(NUMARG.EQ.5)GOTO1150 GOTO1160 C 1130 CONTINUE GOTO1200 C 1140 CONTINUE IF(IHARG(5).EQ.'ALL')IHOLD1=' ' IF(IHARG(5).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 BELOW IF(IHARG(5).EQ.'ALL')THEN IHOLD1=IHARG(6) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF IF(IHARG(6).EQ.'ALL')THEN IHOLD1=IHARG(5) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF GOTO1200 C 1160 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.3)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBABLI(1)=' ' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-3 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+3 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=IDEBBL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBL IBABLI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBABLI(I) 1276 FORMAT('THE LINE TYPE FOR BAR BORDER ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBL DO1315I=1,NUMBAR IBABLI(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)IBABLI(I) 1316 FORMAT('THE LINE TYPE FOR ALL BAR BORDERS', 1' HAS 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 DPBBLI--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBBL 9015 FORMAT('IDEBBL = ',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)IBABLI(1) 9030 FORMAT('IBABLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBABLI(I) 9036 FORMAT('I,IBABLI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBBTH(IHARG,IARGT,ARG,NUMARG,PDEBBT,MAXBAR,PBABTH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR (BORDER) LINE THICKNESSES = THE THICKNESSES C OF THE BORDER LINE AROUND THE BARS. C THESE ARE LOCATED IN THE VECTOR PBABTH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEBBT C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PBABTH (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 PBABTH(*) 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='DPBB' ISUBN2='TH ' C NUMBAR=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 DPBBTH--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)PDEBBT 55 FORMAT('PDEBBT = ',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)PBABTH(1) 70 FORMAT('PBABTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PBABTH(I) 76 FORMAT('I,PBABTH(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')HOLD1=PDEBBT IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 PBABTH(1)=PDEBBT GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBBT IF(IHOLD1.EQ.'OFF')HOLD2=PDEBBT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBBT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBBT PBABTH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,PBABTH(I) 1276 FORMAT('THE THICKNESS OF BAR BORDER ',I6, 1' HAS JUST BEEN SET TO ',E15.7) 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 NUMBAR=MAXBAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBBT IF(IHOLD1.EQ.'OFF')HOLD2=PDEBBT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBBT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBBT DO1315I=1,NUMBAR PBABTH(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)PBABTH(I) 1316 FORMAT('THE THICKNESS OF ALL BAR BORDERS', 1' HAS JUST BEEN SET TO ',E15.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 DPBBTH--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)PDEBBT 9015 FORMAT('PDEBBT = ',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)PBABTH(1) 9030 FORMAT('PBABTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PBABTH(I) 9036 FORMAT('I,PBABTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBCCP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--FORM A BOX-COX CORRELATION PLOT C (USEFUL FOR DETERMINING THAT TRANSFORMATION C IN X WHICH MAXIMIZES THE CORRELATION BETWEEN C Y AND TRANSFORMED X). 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/6 C ORIGINAL VERSION--MAY 1987. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --MAY 1994. AUTO-COMPUTE MAXCC & BEST LAMBDA C UPDATED --JULY 1995. CHARACTER*4 IWRITE C UPDATED --JULY 1995. COMMON IHOST1 FOR IHOST1 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 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CCCCC CHARACTER*4 IHRI31 CCCCC CHARACTER*4 IHRI32 CCCCC CHARACTER*4 IHRI41 CCCCC CHARACTER*4 IHRI42 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IERRO2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C CCCCC SEPTEMBER 1995. ADD FOLLOWING LINE. CHARACTER*4 IWRITE CHARACTER*4 ISUBN0 CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 C C--------------------------------------------------------------------- C CCCCC SEPTEMBER 1995. ADD FOLLOWING LINE. INCLUDE 'DPCOPA.INC' DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION Y4(MAXOBV) DIMENSION XD(MAXOBV) DIMENSION YD(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),Y3(1)) EQUIVALENCE (GARBAG(IGARB4),Y4(1)) EQUIVALENCE (GARBAG(IGARB5),XD(1)) EQUIVALENCE (GARBAG(IGARB6),YD(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 ISUBN1='DPBC' ISUBN2='CP ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BCCP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG2,IBUGG3,IBUGQ 54 FORMAT('IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASPL,MAXN 56 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************** C ** TREAT THE BOX-COX CORRELATION PLOT CASE ** C ********************************************** C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO1110 GOTO9000 C 1110 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C 1190 CONTINUE IFOUND='YES' ICASPL='BCCP' C C ******************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BCCP')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ******************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.2)GOTO1490 GOTO1410 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,1412) 1412 FORMAT(' FOR A BOX-COX CORRELATION PLOT, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,IWIDTH) 1424 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C **************************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C **************************************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1563)IHRIX1,IHRIX2 1563 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1566) 1566 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,IWIDTH) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1573)IHRIX1,IHRIX2 1573 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1577)IHRI11,IHRI12 1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,IWIDTH) 1579 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1590 CONTINUE C C ****************************************************** C ** STEP 22-- ** C ** CHECK THAT VARIABLES 1 AND 2 HAVE ** C ** THE SAME NUMBER OF ELEMENTS. ** C ****************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NIRIG1.EQ.NIRIG2)GOTO2190 C 2110 CONTINUE WRITE(ICOUT,2111) 2111 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2113) 2113 FORMAT(' THE NUMBER OF OBSERVATIONS IN VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2114) 2114 FORMAT(' 1 AND 2 MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115) 2115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2116)IHRI11,IHRI12,NIRIG1 2116 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117)IHRI21,IHRI22,NIRIG2 2117 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2120) 2120 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2121)(IANS(I),I=1,IWIDTH) 2121 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2190 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3253) 3253 FORMAT(' HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3255) 3255 FORMAT(' (FOR WHICH AN BOX-COX CORRELATION PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH) 3260 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** CONTAINING ** C ** THE RESPONSE VARIABLE ** C ** THE INDEPENDENT VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ DO3300I=1,IMAX IF(ISUB(I).EQ.0)GOTO3300 J=J+1 C IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 3300 CONTINUE NS=J C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT ** C ** AFTER SUBSETTING, EACH OF ** C ** THE 2 VARIABLES HAS AT LEAST ** C ** 2 POINTS (THE MINIMUM NEEDED ** C ** TO YIELD A PLOT). ** C ********************************************* C ISTEPN='34' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOUN1=0 ICOUN2=0 IF(NS.LE.2)ICOUN1=NS IF(NS.LE.2)ICOUN2=NS IF(NS.LE.2)GOTO3410 DO3400I=1,NS IF(Y1(I).LE.-0.0001.OR.Y1(I).GE.0.0001)ICOUN1=ICOUN1+1 IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUN2=ICOUN2+1 3400 CONTINUE 3410 CONTINUE IF(ICOUN1.LE.MINN2)GOTO3450 IF(ICOUN2.LE.MINN2)GOTO3450 GOTO3490 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPBCCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3453) 3453 FORMAT(' HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454) 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3455) 3455 FORMAT(' (FOR WHICH A BOX-COX CORRELATION PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3458) 3458 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3459)ICOUN1,ICOUN2 3459 FORMAT('(ICOUN1, ICOUN2 = ',2I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3460) 3460 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3461)(IANS(I),I=1,IWIDTH) 3461 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3490 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED LIMITS ** C ** FOR THE LAMBDA PARAMETER VALUES ** C ** (THIS WILL DICTATE WHAT WILL APPEAR ** C ** ON THE HORIZONTAL AXIS OF THE ** C ** OF THE BOX-COX CORRELATION PLOT) ** C ISTEPN='41' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHP='LAMB' IHP2='DA1 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB1=-2.0 IF(IERRO2.EQ.'NO')ALAMB1=VALUE(ILOCP) C IHP='LAMB' IHP2='DA2 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB2=2.0 IF(IERRO2.EQ.'NO')ALAMB2=VALUE(ILOCP) C C **************************************************************** C ** STEP 51-- * 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 BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='51' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCCP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPBCC2(Y1,Y2,NS,ICASPL,MAXN, 1ALAMB1,ALAMB2, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C CCCCC THE FOLLOWING ENTIRE SECTION WAS ADDED MAY 1994 CCCCC TO PROVIDE MAX-CC AND THE CORRESPONDING BEST LAMBDA MAY 1994 C ****************************************** C ** STEP 61-- ** C ** COMMPUTE CORR. CO & BEST LAMBDA ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C ****************************************** C ISTEPN='61' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' CALL MAXIM(Y,NPLOTP,IWRITE,YMAX,IBUGG3,IERROR) DO6000I=1,NPLOTP I2=I IF(Y(I).EQ.YMAX)GOTO6009 6000 CONTINUE 6009 CONTINUE XBEST=X(I2) C ISUBN0='BCCP' C IH='MAXL' IH2='PCC ' VALUE0=YMAX CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C IH='LPLA' IH2='MBDA' VALUE0=XBEST CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BCCP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBCCP--') 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)ICASPL,MAXN,NUMVAR 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2 9015 FORMAT('NIRIG1,NIRIG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)YMAX,XBEST 9017 FORMAT('YMAX,XBEST = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9029 DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)ICOUN1,ICOUN2 9031 FORMAT('ICOUN1,ICOUN2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)ALAMB1,ALAMB2 9032 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IHRI11,IHRI12 9051 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IHRI21,IHRI22 9052 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBCC2(Y1,X1,N1,ICASPL,MAXN, 1ALAMB1,ALAMB2, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C THE BOX-COX CORRELATION PLOT TRACE C WHICH IS A PLOT OF THE CORRELATION COEFFICIENT C OF THE CORRELATION COEFFICIENT (Y,T(X)) C VERSUS THE BOX-COX PARAMATER LAMBDA. 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/6 C ORIGINAL VERSION--MAY 1987. C UPDATED --DECEMBER 1993. CHARACTER*4 ICASPL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION X1(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION DISPAR(100) DIMENSION CORR(100) 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='DPBC' ISUBN2='C2 ' C IERROR='NO' C AN1=0.0 C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BCC2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO 52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,MAXN,N1,NPLOTV 53 FORMAT('ICASPL,MAXN,N1,NPLOTV = ',A4,2X,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ALAMB1,ALAMB2 54 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO62 DO60I=1,N1 WRITE(ICOUT,61)I,Y1(I),X1(I) 61 FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 60 CONTINUE 62 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N1.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPBCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114)N1 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N1.GE.2)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPBCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C HOLD=X1(1) DO1130I=1,N1 IF(X1(I).NE.HOLD)GOTO1139 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPBCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)HOLD 1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C C ******************************************************* C ** STEP 21-- ** C ** DETERMINE THE SET OF PARAMETER VALUES ** C ** TO BE USED FOR THE TRANSFORMATIONS ** C ******************************************************* C NUMDIS=41 ANUMDI=NUMDIS DO2100IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 2100 CONTINUE C C **************************************** C ** STEP 22-- ** C ** DETERMINE PLOT COORDINATES ** C **************************************** C DO2210I=1,N1 Y2(I)=Y1(I) 2210 CONTINUE C XMIN=X1(1) DO2220I=1,N1 IF(X1(I).LT.XMIN)XMIN=X1(I) 2220 CONTINUE C DO2230I=1,N1 D2(I)=X1(I) 2230 CONTINUE C IF(XMIN.GT.0.0)GOTO2249 DO2240I=1,N1 D2(I)=D2(I)-XMIN+1.0 2240 CONTINUE 2249 CONTINUE C DO2300IDIS=1,NUMDIS C ALAMBA=DISPAR(IDIS) IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)GOTO2310 GOTO2320 2310 CONTINUE DO2315I=1,N1 X2(I)=ALOG(D2(I)) 2315 CONTINUE GOTO2329 2320 CONTINUE DO2325I=1,N1 X2(I)=((D2(I)**ALAMBA)-1.0)/ALAMBA 2325 CONTINUE GOTO2329 2329 CONTINUE C AN1=N1 SUMX=0.0 SUMY=0.0 DO2410I=1,N1 SUMX=SUMX+X2(I) SUMY=SUMY+Y2(I) 2410 CONTINUE XBAR=SUMX/AN1 YBAR=SUMY/AN1 C SUMX=0.0 SUMY=0.0 SUMXY=0.0 DO2420I=1,N1 SUMX=SUMX+(X2(I)-XBAR)*(X2(I)-XBAR) SUMY=SUMY+(Y2(I)-YBAR)*(Y2(I)-YBAR) SUMXY=SUMXY+(X2(I)-XBAR)*(Y2(I)-YBAR) 2420 CONTINUE ARG=SUMX*SUMY CC=0.0 IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG) CORR(IDIS)=CC C IF(IBUGG3.EQ.'OFF')GOTO2439 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO2431I=1,N1 WRITE(ICOUT,2433)I,Y1(I),X1(I),Y2(I),X2(I),D2(I),CORR(I) 2433 FORMAT('I,Y1(I),X1(I),Y2(I),X2(I),D2(I),CORR(I) = ',I8,6E12.5) CALL DPWRST('XXX','BUG ') 2431 CONTINUE WRITE(ICOUT,2434)ICASPL,XBAR,YBAR,SUMX,SUMY,SUMXY 2434 FORMAT('ICASPL,XBAR,YBAR,SUMX,SUMY,SUMXY = ', 1A4,2X,5E15.7) CALL DPWRST('XXX','BUG ') 2439 CONTINUE C 2300 CONTINUE C 2500 CONTINUE DO2510IDIS=1,NUMDIS Y2(IDIS)=CORR(IDIS) X2(IDIS)=DISPAR(IDIS) D2(IDIS)=1.0 2510 CONTINUE N2=NUMDIS NPLOTV=2 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 DPBCC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR 9012 FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBCHP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--FORM A BOX-COX HOMOSCEDASTICITY PLOT C (USEFUL FOR DETERMINING THAT TRANSFORMATION C IN X WHICH "MAXIMIZES THE HOMOSCEDASTICITY" BETWEEN C TRANSFORMED Y AND X). C NOTE--THE CRITERION FOR HOMOSCEDASTICITY IS THAT THE C CORR(WITHIN-SET SD, SET ID) BE 0 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/6 C ORIGINAL VERSION--MAY 1987. 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 ICASEQ C CHARACTER*4 IHRI11 CHARACTER*4 IHRI12 CHARACTER*4 IHRI21 CHARACTER*4 IHRI22 CCCCC CHARACTER*4 IHRI31 CCCCC CHARACTER*4 IHRI32 CCCCC CHARACTER*4 IHRI41 CCCCC CHARACTER*4 IHRI42 CHARACTER*4 IHRIX1 CHARACTER*4 IHRIX2 C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IERRO2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 ICTAR1 CHARACTER*4 ICTAR2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) DIMENSION Y4(MAXOBV) DIMENSION XD(MAXOBV) DIMENSION YD(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(1)) EQUIVALENCE (GARBAG(IGARB3),Y3(1)) EQUIVALENCE (GARBAG(IGARB4),Y4(1)) EQUIVALENCE (GARBAG(IGARB5),XD(1)) EQUIVALENCE (GARBAG(IGARB6),YD(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 ISUBN1='DPBC' ISUBN2='HP ' C IFOUND='NO' IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MINN2=2 C IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BCHP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPLOTV,NPLOTP,NS 52 FORMAT('NPLOTV,NPLOTP,NS = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,IAND1,IAND2 53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGG2,IBUGG3,IBUGQ 54 FORMAT('IBUGG2,IBUGG3,IBUGQ = ', 1A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)ICASPL,MAXN 56 FORMAT('ICASPL,MAXN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFOUND,IERROR 57 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************** C ** TREAT THE BOX-COX HOMOSCEDASTICITY PLOT CASE ** C ********************************************** C C *************************** C ** STEP 11-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='11' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.3.AND.IHARG(3).EQ.'PLOT')GOTO1110 GOTO9000 C 1110 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO1190 C 1190 CONTINUE IFOUND='YES' ICASPL='BCHP' C C ******************************************************** C ** STEP 12-- ** C ** CARRY OUT A GENERAL CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='12' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************** C ** STEP 13-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='13' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO1390 DO1300J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO1310 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO1310 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO1320 1300 CONTINUE GOTO1390 1310 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO1390 1320 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO1390 1390 CONTINUE IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'BCHP')GOTO1395 WRITE(ICOUT,1391)ICASEQ,NUMARG,ILOCQ 1391 FORMAT('ICASEQ,NUMARG,ILOCQ = ',A4,2X,2I8) CALL DPWRST('XXX','BUG ') 1395 CONTINUE C C ******************************************************** C ** STEP 14-- ** C ** CARRY OUT A SPECIFIC CHECK FOR THE ** C ** PROPER NUMBER OF INPUT ARGUMENTS ** C ** (IT SHOULD BE EXACTLY 2). ** C ******************************************************** C ISTEPN='14' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.EQ.2)GOTO1490 GOTO1410 C 1410 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MECC')WRITE(ICOUT,1412) 1412 FORMAT(' FOR A BOX-COX HOMOSCEDASTICITY PLOT, ') IF(ICASPL.EQ.'MECC')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1418) 1418 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1419) 1419 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1420) 1420 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1421) 1421 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1422)NUMVAR 1422 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1423) 1423 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1424)(IANS(I),I=1,IWIDTH) 1424 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1490 CONTINUE C C **************************************************************** C ** STEP 15-- * C ** EXAMINE THE VARIABLES-- * C ** HAS EACH VARIABLE * C ** ALREADY BEEN DEFINED? * C ** NOTE THAT ILISR1, ILISR2, * C ** IS THE LINE IN THE TABLE * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C ** NOTE THAT ICOLR1, ICOLR2, * C ** IS THE DATA COLUMN (1 TO 10+6) * C ** OF THE FIRST, SECOND VARIABLE * C ** RESPECTIVELY. * C **************************************************************** C ISTEPN='15' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICTAR1='FIRS' ICTAR2='T ' ILOCR1=1 IHRI11=IHARG(ILOCR1) IHRI12=IHARG2(ILOCR1) IHRIX1=IHRI11 IHRIX2=IHRI12 DO1510I=1,NUMNAM I2=I IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1519 IF(IHRI11.EQ.IHNAME(I).AND.IHRI12.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1510 CONTINUE GOTO1570 1519 CONTINUE ILISR1=I2 ICOLR1=IVALUE(ILISR1) NIRIG1=IN(ILISR1) C ICTAR1='SECO' ICTAR2='ND ' ILOCR2=2 IHRI21=IHARG(ILOCR2) IHRI22=IHARG2(ILOCR2) IHRIX1=IHRI21 IHRIX2=IHRI22 DO1520I=1,NUMNAM I2=I IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO1529 IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO1560 1520 CONTINUE GOTO1570 1529 CONTINUE ILISR2=I2 ICOLR2=IVALUE(ILISR2) NIRIG2=IN(ILISR2) GOTO1590 C 1560 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1561) 1561 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1562)ICTAR1,ICTAR2 1562 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1563)IHRIX1,IHRIX2 1563 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1565) 1565 FORMAT(' WAS FOUND IN THE INTERNAL NAME LIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1566) 1566 FORMAT(' BUT AS A PARAMETER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1567) 1567 FORMAT(' AND NOT AS A VARIABLE AS IT SHOULD BE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1568) 1568 FORMAT(' THE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1569)(IANS(I),I=1,IWIDTH) 1569 FORMAT(80A1) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1571) 1571 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1572)ICTAR1,ICTAR2 1572 FORMAT(' THE SPECIFIED ',A4,A4,' ARGUMENT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1573)IHRIX1,IHRIX2 1573 FORMAT(' (',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1575) 1575 FORMAT(' WAS NOT FOUND IN THE INTERNAL NAME LIST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1576) 1576 FORMAT(' OF AVAILABLE VARIABLE NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1577)IHRI11,IHRI12 1577 FORMAT(' THE VARIABLE IN QUESTION WAS ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1578) 1578 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1579)(IANS(I),I=1,IWIDTH) 1579 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1590 CONTINUE C C ****************************************************** C ** STEP 22-- ** C ** CHECK THAT VARIABLES 1 AND 2 HAVE ** C ** THE SAME NUMBER OF ELEMENTS. ** C ****************************************************** C 2100 CONTINUE ISTEPN='21' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NIRIG1.EQ.NIRIG2)GOTO2190 C 2110 CONTINUE WRITE(ICOUT,2111) 2111 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2113) 2113 FORMAT(' THE NUMBER OF OBSERVATIONS IN VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2114) 2114 FORMAT(' 1 AND 2 MUST BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115) 2115 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2116)IHRI11,IHRI12,NIRIG1 2116 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117)IHRI21,IHRI22,NIRIG2 2117 FORMAT(' VARIABLE ',A4,A4,' HAS ',I8, 1' OBSERVATIONS;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2120) 2120 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2121)(IANS(I),I=1,IWIDTH) 2121 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2190 CONTINUE C C ********************************************* C ** STEP 32-- ** C ** FORM THE VECTOR ISUB(.) ** C ** DEPENDING ON THE TYPE OF CASE ** C ** FOR THE QUALIFIER. ** C ** BRANCH TO THE PROPER CASE. ** C ********************************************* C ISTEPN='32' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLOCAL=NIRIG1 C IF(ICASEQ.EQ.'FULL')GOTO3210 IF(ICASEQ.EQ.'SUBS')GOTO3220 IF(ICASEQ.EQ.'FOR')GOTO3230 C 3210 CONTINUE DO3215I=1,NLOCAL ISUB(I)=1 3215 CONTINUE NQ=NLOCAL GOTO3250 C 3220 CONTINUE NIOLD=NLOCAL CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO3250 C 3230 CONTINUE NIOLD=NLOCAL CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERRO4) NQ=NFOR GOTO3250 C 3250 CONTINUE IF(NQ.GE.MINN2)GOTO3290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3251) 3251 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3252) 3252 FORMAT(' AFTER THE APPROPRIATE SUBSET ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3253) 3253 FORMAT(' HAS BEEN EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3254)IHRI11,IHRI12 3254 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3255) 3255 FORMAT(' (FOR WHICH AN BOX-COX HOMOSCEDASTICITY PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3256) 3256 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3257)MINN2 3257 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3258)NQ 3258 FORMAT(' SUCH WAS NOT THE CASE HERE (NQ = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3259) 3259 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3260)(IANS(I),I=1,IWIDTH) 3260 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3290 CONTINUE C C ********************************************** C ** STEP 33-- ** C ** FORM THE SUBSETTED VARIABLES ** C ** Y1(.) ** C ** Y2(.) ** C ** CONTAINING ** C ** THE RESPONSE VARIABLE ** C ** THE INDEPENDENT VARIABLE ** C ** RESPECTIVELY. ** C ********************************************** C ISTEPN='33' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C J=0 IMAX=NIRIG1 IF(NQ.LT.NIRIG1)IMAX=NQ DO3300I=1,IMAX IF(ISUB(I).EQ.0)GOTO3300 J=J+1 C IJ=MAXN*(ICOLR1-1)+I IF(ICOLR1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLR1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLR1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLR1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLR1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLR1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLR1.EQ.MAXCP6)Y1(J)=TAGPLO(I) C IJ=MAXN*(ICOLR2-1)+I IF(ICOLR2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 3300 CONTINUE NS=J C C ********************************************* C ** STEP 34-- ** C ** CHECK TO MAKE SURE THAT ** C ** AFTER SUBSETTING, EACH OF ** C ** THE 2 VARIABLES HAS AT LEAST ** C ** 2 POINTS (THE MINIMUM NEEDED ** C ** TO YIELD A PLOT). ** C ********************************************* C ISTEPN='34' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICOUN1=0 ICOUN2=0 IF(NS.LE.2)ICOUN1=NS IF(NS.LE.2)ICOUN2=NS IF(NS.LE.2)GOTO3410 DO3400I=1,NS IF(Y1(I).LE.-0.0001.OR.Y1(I).GE.0.0001)ICOUN1=ICOUN1+1 IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUN2=ICOUN2+1 3400 CONTINUE 3410 CONTINUE IF(ICOUN1.LE.MINN2)GOTO3450 IF(ICOUN2.LE.MINN2)GOTO3450 GOTO3490 C 3450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3451) 3451 FORMAT('***** ERROR IN DPBCHP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3452) 3452 FORMAT(' AFTER THE SPECIFIED SUBSETTING ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3453) 3453 FORMAT(' HAS BEEN DONE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3454) 3454 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3455) 3455 FORMAT(' (FOR WHICH A BOX-COX HOMOSCEDASTICITY PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3456) 3456 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3457)MINN2 3457 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3458) 3458 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3459)ICOUN1,ICOUN2 3459 FORMAT('(ICOUN1, ICOUN2 = ',2I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3460) 3460 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3461)(IANS(I),I=1,IWIDTH) 3461 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3490 CONTINUE C C *********************************************** C ** STEP 41-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED LIMITS ** C ** FOR THE LAMBDA PARAMETER VALUES ** C ** (THIS WILL DICTATE WHAT WILL APPEAR ** C ** ON THE HORIZONTAL AXIS OF THE ** C ** OF THE BOX-COX HOMOSCEDASTICITY PLOT) ** C ISTEPN='41' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHP='LAMB' IHP2='DA1 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB1=-2.0 IF(IERRO2.EQ.'NO')ALAMB1=VALUE(ILOCP) C IHP='LAMB' IHP2='DA2 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB2=2.0 IF(IERRO2.EQ.'NO')ALAMB2=VALUE(ILOCP) C C **************************************************************** C ** STEP 51-- * 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 BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='51' IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCHP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPBCH2(Y1,Y2,NS,ICASPL,MAXN, 1ALAMB1,ALAMB2, 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.'BCHP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBCHP--') 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)ICASPL,MAXN,NUMVAR 9014 FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NIRIG1,NIRIG2 9015 FORMAT('NIRIG1,NIRIG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NLOCAL,NQ,MINN2 9016 FORMAT('NLOCAL,NQ,MINN2 = ',3I8) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO9029 DO9020I=1,NPLOTP WRITE(ICOUT,9021)I,Y(I),X(I),D(I) 9021 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)ICOUN1,ICOUN2 9031 FORMAT('ICOUN1,ICOUN2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)ALAMB1,ALAMB2 9032 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)IHRI11,IHRI12 9051 FORMAT('IHRI11,IHRI12 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IHRI21,IHRI22 9052 FORMAT('IHRI21,IHRI22 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBCH2(Y1,X1,N1,ICASPL,MAXN, 1ALAMB1,ALAMB2, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C THE BOX-COX HOMOSCEDASTICITY PLOT TRACE C WHICH IS A PLOT C OF THE RATIO MIN(SD(T(Y)) / MAX(SD(T(Y)) C VERSUS THE BOX-COX PARAMATER LAMBDA. C NOTE--THE RATIO MUST BE BETWEEN 0 AND 1. C THE CLOSER TO 1, THE MORE CONSTANT THE VARIANCE. 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/6 C ORIGINAL VERSION--MAY 1987. C UPDATED --DECEMBER 1993. CHARACTER*4 ICASPL C UPDATED --FEBRUARY 1994. CHANGE STAT TO RATIO C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 1993 CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION X1(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION DISPAR(100) DIMENSION RATIO(100) C CCCCC THE FOLLOWING DIMENSIONS ARE TEMPORARY DIMENSION DISTX(100) DIMENSION DISTX3(100) DIMENSION Y3(100) DIMENSION SDY3(100) 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='DPBC' ISUBN2='H2 ' C IERROR='NO' C AN1=0.0 C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BCH2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGG3,ISUBRO 52 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,MAXN,N1,NPLOTV 53 FORMAT('ICASPL,MAXN,N1,NPLOTV = ',A4,2X,I8,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ALAMB1,ALAMB2 54 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO62 DO60I=1,N1 WRITE(ICOUT,61)I,Y1(I),X1(I) 61 FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 60 CONTINUE 62 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N1.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' MUST BE AT LEAST 1;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114)N1 1114 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N1.GE.2)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' WAS EXACTLY EQUAL TO 1.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C HOLD=X1(1) DO1130I=1,N1 IF(X1(I).NE.HOLD)GOTO1139 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)HOLD 1133 FORMAT(' ARE IDENTICALLY EQUAL TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1139 CONTINUE C C ******************************************************* C ** STEP 21-- ** C ** DETERMINE THE SET OF PARAMETER VALUES ** C ** TO BE USED FOR THE TRANSFORMATIONS ** C ******************************************************* C NUMDIS=41 ANUMDI=NUMDIS DO2100IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 2100 CONTINUE C C ******************************************************** C ** STEP 22-- ** C ** DETERMINE THE NUMBER OF DISTINCT SUBSETS ** C ** FOR VARIABLE 1; ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR THIS COMMAND ** C ******************************************************** C ISTEPN='22' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C NUMSET=0 DO2200I=1,N1 IF(NUMSET.GE.1)THEN DO2300J=1,NUMSET IF(X1(I).EQ.DISTX(J))GOTO2200 2300 CONTINUE ENDIF NUMSET=NUMSET+1 DISTX(NUMSET)=X1(I) 2200 CONTINUE C IF(NUMSET.EQ.0.OR.NUMSET.EQ.N1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT('*****ERROR IN DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' FOR A BOX-COX HOMOSCEDASTICITY PLOT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207) 2207 FORMAT(' THERE MUST BE REPLICATION--BUT NO REPLICATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2208) 2208 FORMAT(' WAS FOUND--ALL VALUES OF X WERE DISTINCT.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2209)NUMSET 2209 FORMAT(' NUMSET = ',I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 2219 CONTINUE C C **************************************** C ** STEP 32-- ** C ** DETERMINE PLOT COORDINATES ** C **************************************** C DO3210I=1,N1 X2(I)=X1(I) 3210 CONTINUE C YMIN=Y1(1) DO3220I=1,N1 IF(Y1(I).LT.YMIN)YMIN=Y1(I) 3220 CONTINUE C DO3230I=1,N1 D2(I)=Y1(I) 3230 CONTINUE C IF(YMIN.LE.0.0)THEN DO3240I=1,N1 D2(I)=D2(I)-YMIN+1.0 3240 CONTINUE ENDIF C DO3300IDIS=1,NUMDIS C ALAMBA=DISPAR(IDIS) IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN DO3315I=1,N1 Y2(I)=ALOG(D2(I)) 3315 CONTINUE ELSE DO3325I=1,N1 Y2(I)=((D2(I)**ALAMBA)-1.0)/ALAMBA 3325 CONTINUE ENDIF C ISET3=0 DO3410ISET=1,NUMSET I3=0 DO3420I=1,N1 IF(X2(I).EQ.DISTX(ISET))THEN I3=I3+1 Y3(I3)=Y2(I) ENDIF 3420 CONTINUE IF(I3.GE.2)THEN ISET3=ISET3+1 DISTX3(ISET3)=DISTX(ISET) CALL SD(Y3,I3,IWRITE,SDY3(ISET3),IBUGG3,IERROR) ENDIF 3410 CONTINUE C CALL MINIM(SDY3,ISET3,IWRITE,AMINSD,IBUGG3,IERROR) CALL MAXIM(SDY3,ISET3,IWRITE,AMAXSD,IBUGG3,IERROR) RATIO(IDIS)=0.0 IF(AMAXSD.GT.0.0)RATIO(IDIS)=AMINSD/AMAXSD C IF(IBUGG3.EQ.'OFF')GOTO3439 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3434)AMINSD,AMAXSD,RATIO(IDIS) 3434 FORMAT('AMINSD,AMAXSD,RATIO(IDIS) = ',3E15.7) CALL DPWRST('XXX','BUG ') 3439 CONTINUE C 3300 CONTINUE C 3500 CONTINUE DO3510IDIS=1,NUMDIS Y2(IDIS)=RATIO(IDIS) X2(IDIS)=DISPAR(IDIS) D2(IDIS)=1.0 3510 CONTINUE N2=NUMDIS NPLOTV=2 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 DPBCH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR 9012 FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBCNP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE A BOX-COX NORMALITY 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--AUGUST 1981. C UPDATED --MARCH 1982. 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 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IDATSW CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IERRO2 CHARACTER*4 IERRO4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),X1(1)) EQUIVALENCE (GARBAG(IGARB2),Y1(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='DPBC' ISUBN2='NP ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=2 MINN2=3 C ICOLR=0 C C ********************************************* C ** TREAT THE BOX-COX NORMALITY PLOT 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 DPBCNP--') 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 113 CONTINUE ILASTC=3 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASPL='BCNP' 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')RETURN 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')RETURN ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT 211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 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 DPBCNP--') 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 BOX-COX NORMALITY PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') 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' RETURN C 390 CONTINUE C C ***************************************** C ** STEP 5-- ** 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='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 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 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPBOX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ****************************************************** C ** STEP 6-- ** C ** IF A SECOND ARGUMENT EXISTS, THEN THIS ** C ** INDICATES THAT THE VALUES IN THE ** C ** FIRST VARIABLE ARE NOT DATA POINTS ** C ** BUT ALREADY-COMPUTED FREQUENCIES, ** C ** AND THE VALUES IN THE SECOND VARIABLE ** C ** ARE THE CORRESPONDING X VALUES FOR EACH ** C ** FREQUENCY. IF WE HAVE THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY OF THE SECOND (X) VARIABLE. ** C ****************************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IDATSW='RAW' IF(NUMV2.EQ.1)IDATSW='RAW' IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)IDATSW='FREQ' IF(NUMV2.EQ.2)GOTO509 GOTO550 C 509 CONTINUE IHRIGH=IHARG(2) IHRIG2=IHARG2(2) 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 ICOLR=IVALUE(ILOCV) NRIGHT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT 511 FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NRIGHT.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPBCNP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A BOX-COX NORMALITY PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) 559 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,560) 560 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,561) 561 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)NUMV2 562 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563) 563 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH) 564 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 DPBCNP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A BOX-COX NORMALITY PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARIABLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (FREQUENCIES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT 584 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT 586 FORMAT(' ',A4,A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ***************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='7' IF(IBUGG2.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,IERRO4) 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 IF(NUMV2.LE.1)GOTO651 GOTO652 C 651 CONTINUE IJ=MAXN*(ICOLL-1)+I IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLL.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLL.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLL.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLL.EQ.MAXCP6)X1(J)=TAGPLO(I) GOTO660 C 652 CONTINUE IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I) IF(ICOLR.EQ.MAXCP3)X1(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)X1(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)X1(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)X1(J)=TAGPLO(I) 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) GOTO660 C 660 CONTINUE NLOCAL=J C C *********************************************** C ** STEP 8-- ** C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED LIMITS ** C ** FOR THE LAMBDA PARAMETER VALUES ** C ** (THIS WILL DICTATE WHAT WILL APPEAR ** C ** ON THE HORIZONTAL AXIS OF THE BOX-COX NORMALITY PLOT) ** C *********************************************** C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHP='LAMB' IHP2='DA1 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB1=-2.0 IF(IERRO2.EQ.'NO')ALAMB1=VALUE(ILOCP) C IHP='LAMB' IHP2='DA2 ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) ALAMB2=2.0 IF(IERRO2.EQ.'NO')ALAMB2=VALUE(ILOCP) C C ***************************************************** C ** STEP 9-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** 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 IF(IBUGG2.EQ.'OFF')GOTO5190 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5111) 5111 FORMAT('***** FROM THE MIDDLE OF DPBCNP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5112)ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV 5112 FORMAT('ICASPL,NUMV2,IDATSW,NPLOTP,NPLOTV = ',A4,I8,2X,A4,2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5113)ALAMB1,ALAMB2 5113 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5121)NLOCAL 5121 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO5129 DO5122I=1,NLOCAL WRITE(ICOUT,5123)I,Y1(I),X1(I) 5123 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) CALL DPWRST('XXX','BUG ') 5122 CONTINUE 5129 CONTINUE IF(NPLOTP.LE.0)GOTO5190 DO5135I=1,NPLOTP WRITE(ICOUT,5136)I,Y(I),X(I),D(I) 5136 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 5135 CONTINUE 5190 CONTINUE C CALL DPBCN2(Y1,X1,NLOCAL,ICASPL,IDATSW, 1ALAMB1,ALAMB2, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) 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 DPBCNP--') 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)ALAMB1,ALAMB2 9014 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)NLOCAL 9021 FORMAT('NLOCAL = ',I8) CALL DPWRST('XXX','BUG ') IF(NLOCAL.LE.0)GOTO9029 DO9022I=1,NLOCAL WRITE(ICOUT,9023)I,Y1(I),X1(I) 9023 FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9029 CONTINUE IF(NPLOTP.LE.0)GOTO9090 DO9032I=1,NPLOTP WRITE(ICOUT,9033)I,Y(I),X(I),D(I) 9033 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBCN2(Y1,X1,N1,ICASPL,IDATSW, 1ALAMB1,ALAMB2, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C THE BOX-COX NORMALITY PLOT TRACE C WHICH IS A PLOT OF THE NORMAL PROBABILITY PLOT C CORRELATION COEFFICIENT VERSUS THE BOX-COX PARAMATER LAMBDA. 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--AUGUST 1981. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --APRIL 1992. AN=N1 TO AN1=N1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IDATSW CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION X1(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION DISPAR(100) DIMENSION CORR(100) 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='DPBC' ISUBN2='N2 ' C IERROR='NO' C AN1=0.0 C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71) 71 FORMAT('***** AT THE BEGINNING OF DPBCN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)ICASPL,IDATSW,N1,NPLOTV 72 FORMAT('ICASPL,IDATSW,N1,NPLOTV = ',A4,2X,A4,2X,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)ALAMB1,ALAMB2 73 FORMAT('ALAMB1,ALAMB2 = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO80 DO85I=1,N1 WRITE(ICOUT,86)I,Y1(I),X1(I) 86 FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5) CALL DPWRST('XXX','BUG ') 85 CONTINUE 80 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N1.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPBCN2--') 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)N1 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(N1.GE.2)GOTO49 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46) 46 FORMAT('***** ERROR IN DPBCN2--') 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=X1(1) DO60I=1,N1 IF(X1(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPBCN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT RESPONSE VARIABLE ELEMENTS') 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 C ******************************************************* C ** STEP 2-- ** C ** DETERMINE THE SET OF PARAMETER VALUES ** C ** TO BE USED FOR THE TRANSFORMATIONS ** C ******************************************************* C 500 CONTINUE C 510 CONTINUE NUMDIS=41 ANUMDI=NUMDIS DO511IDIS=1,NUMDIS AIDIS=IDIS DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1) 511 CONTINUE GOTO599 C 599 CONTINUE C C ************************************** C ** STEP 4-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C IF(IDATSW.EQ.'RAW')GOTO1100 IF(IDATSW.EQ.'FREQ')GOTO2100 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPBCN2 ', 1'AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' IDATSW SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' RAW OR FREQ, BUT IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)IDATSW 1014 FORMAT(' IDATSW = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C **************************************** C ** STEP 4.1-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 1-VARIABLE CASE ** C ** (THAT IS, FOR THE RAW DATA CASE) ** C **************************************** C 1100 CONTINUE C CALL UNIMED(N1,X2) DO1110I=1,N1 CALL NORPPF(X2(I),X2OUT) X2(I)=X2OUT 1110 CONTINUE C CALL SORT(X1,N1,D2) XMIN=D2(1) IF(XMIN.GT.0.0)GOTO1119 DO1115I=1,N1 D2(I)=D2(I)-XMIN+1.0 1115 CONTINUE 1119 CONTINUE C DO1120IDIS=1,NUMDIS ALAMBA=DISPAR(IDIS) IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)GOTO1130 GOTO1140 1130 CONTINUE DO1135I=1,N1 Y2(I)=ALOG(D2(I)) 1135 CONTINUE GOTO1149 1140 CONTINUE DO1145I=1,N1 Y2(I)=((D2(I)**ALAMBA)-1.0)/ALAMBA 1145 CONTINUE GOTO1149 1149 CONTINUE C AN1=N1 SUMY=0.0 DO1810I=1,N1 SUMY=SUMY+Y2(I) 1810 CONTINUE XBAR=0.0 YBAR=SUMY/AN1 C SUMX=0.0 SUMY=0.0 SUMXY=0.0 DO1820I=1,N1 SUMX=SUMX+(X2(I)-XBAR)*(X2(I)-XBAR) SUMY=SUMY+(Y2(I)-YBAR)*(Y2(I)-YBAR) SUMXY=SUMXY+(X2(I)-XBAR)*(Y2(I)-YBAR) 1820 CONTINUE ARG=SUMX*SUMY CC=0.0 IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG) CORR(IDIS)=CC C IF(IBUGG3.EQ.'OFF')GOTO1839 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1831I=1,N1 WRITE(ICOUT,1833)I,Y1(I),X1(I),Y2(I),X2(I),D2(I),CORR(I) 1833 FORMAT('I,Y1(I),X1(I),Y2(I),X2(I),D2(I),CORR(I) = ',I8,6E12.5) CALL DPWRST('XXX','BUG ') 1831 CONTINUE WRITE(ICOUT,1834)ICASPL,IDATSW,XBAR,YBAR,SUMX,SUMY,SUMXY 1834 FORMAT('ICASPL,IDATSW,XBAR,YBAR,SUMX,SUMY,SUMXY = ', 1A4,2X,A4,2X,5E15.7) CALL DPWRST('XXX','BUG ') 1839 CONTINUE C 1120 CONTINUE C 1900 CONTINUE DO1910IDIS=1,NUMDIS Y2(IDIS)=CORR(IDIS) X2(IDIS)=DISPAR(IDIS) D2(IDIS)=1.0 1910 CONTINUE N2=NUMDIS NPLOTV=2 GOTO9000 C C ******************************************** C ** STEP 4.2-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR THE 2-VARIABLE CASE ** C ** (THAT IS, FOR THE GROUPED DATA CASE) ** C ******************************************** C 2100 CONTINUE CALL SORTC(X1,Y1,N1,D2,Y2) XMIN=D2(1) IF(XMIN.GT.0.0)GOTO2109 DO2105I=1,N1 D2(I)=D2(I)-XMIN+1.0 2105 CONTINUE 2109 CONTINUE C I2=0 DO2111I=1,N1 NI=Y2(I) ANI=NI I1=I2+1 I2=I1+NI-1 SUM=0.0 DO2112K=I1,I2 CALL UNIME2(NTOT,K,UNIOSM) CALL NORPPF(UNIOSM,DISOSM) SUM=SUM+DISOSM 2112 CONTINUE X2(I)=SUM/ANI 2111 CONTINUE C SUM=0.0 DO2115I=1,N1 SUM=SUM+Y1(I) 2115 CONTINUE NTOT=SUM+0.5 C DO2120IDIS=1,NUMDIS ALAMBA=DISPAR(IDIS) IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)GOTO2130 GOTO2140 2130 CONTINUE DO2135I=1,N1 Y2(I)=ALOG(D2(I)) 2135 CONTINUE GOTO2149 2140 CONTINUE DO2145I=1,N1 Y2(I)=((D2(I)**ALAMBA)-1.0)/ALAMBA 2145 CONTINUE GOTO2149 2149 CONTINUE C CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1992 (ALAN) CCCCC AN=N1 AN1=N1 SUMY=0.0 DO2810I=1,N1 SUMY=SUMY+Y2(I) 2810 CONTINUE XBAR=0.0 YBAR=SUMY/AN1 C SUMX=0.0 SUMY=0.0 SUMXY=0.0 DO2820I=1,N1 SUMX=SUMX+(X2(I)-XBAR)*(X2(I)-XBAR) SUMY=SUMY+(Y2(I)-YBAR)*(Y2(I)-YBAR) SUMXY=SUMXY+(X2(I)-XBAR)*(Y2(I)-YBAR) 2820 CONTINUE ARG=SUMX*SUMY CC=0.0 IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG) CORR(IDIS)=CC C 2120 CONTINUE C 2900 CONTINUE DO2910IDIS=1,NUMDIS Y2(IDIS)=CORR(IDIS) X2(IDIS)=DISPAR(IDIS) D2(IDIS)=1.0 2910 CONTINUE N2=NUMDIS NPLOTV=2 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 DPBCN2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IDATSW,N2,IERROR 9012 FORMAT('ICASPL,IDATSW,N2,IERROR = ',A4,2X,A4,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NTOT 9014 FORMAT('NTOT = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I) 9016 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBCP(NPTS,NLAB, 1AMEAN,ASD,N,AMNX,AMXX, 1XBCP,XBCPSE,XBCPK1,XBCPK2, 1DLOWBC,DHIGBC, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT BAYESIAN CONSENSUS PROCEDURE (A C MODIFICATION OF THE BOUNDS ON BIAS (BOB) PROCEDURE). C PROCEDURE DESCRIBED IN THE GUTHRIE/HAGWOOD PAPER. C REFERENCE--CHARLES HAGWOOD AND WILLIAM GUTHRIE (2006), C "COMBINING DATA IN SMALL MULTIPLE-METHODS C STUDIES", TECHNOMETRICS, VOL. 48, NO. 2. C PRINTING--YES C SUBROUTINES NEEDED--NONE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*1 IBASLC C CHARACTER*20 IMETH C REAL APPF REAL XBCP REAL XBCPSE REAL XBCPK1 REAL XBCPK2 REAL AMNX REAL AMXX REAL AMEAN(*) REAL ASD(*) REAL CV REAL DELTA C INTEGER N(*) C C---------------------------------------------------------------- C INCLUDE 'DPCOST.INC' C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDI2(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN CHARACTER*45 IVALUE(MAXHED) INTEGER NCHAR(MAXHED) REAL AVALUE(MAXHED) C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*132 ITTEMP CHARACTER*132 IHEAD C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C REAL CPUMIN REAL CPUMAX 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='DPVR' ISUBN2='ML ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOB')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB,SW,STXMU,ST2SB 52 FORMAT('NPTS,NLAB,SW,STXMU,ST2SB = ',2I8,3G15.7) CALL DPWRST('XXX','BUG ') DO55I=1,NLAB WRITE(ICOUT,56)I,AMEAN(I) 56 FORMAT('I,AMEAN(I) = ',2I8,G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C CALL MEAN(AMEAN,NLAB,IWRITE,XBCP,IBUGA3,IERROR) DSB=DBLE(AMXX - AMNX)**2/12.0D0 C DSUM=0.0D0 DO100I=1,NLAB DSUM=DSUM + DBLE(ASD(I)/REAL(N(I)))**2 100 CONTINUE C DKU=DSUM/(DBLE(NLAB)**2) + DSB XBCPSE=REAL(DSQRT(DKU)) XBCPK1=XBCPSE XBCPK2=2.0*XBCPSE DFNUM=DKU**2 DSUM=0.0D0 DO200I=1,NLAB DSUM=DSUM + DBLE(ASD(I)/REAL(N(I)))**4/DBLE(N(I)-1) 200 CONTINUE W=DBLE(AMXX - AMNX) IF(NLAB.EQ.2)THEN DNU=1.0D0 ELSEIF(NLAB.EQ.3)THEN DNU=1.9846D0 ELSEIF(NLAB.EQ.4)THEN DNU=2.9291D0 ELSEIF(NLAB.EQ.5)THEN DNU=3.8267D0 ELSEIF(NLAB.EQ.6)THEN DNU=4.6772D0 ELSE DNU=4.6772D0 ENDIF DFDEN=(DSUM/DBLE(NLAB)**4) + W**4/(144.0D0*DNU) DF=DFNUM/DFDEN IDF=INT(DF+0.5D0) IF(IDF.LT.1)IDF=1 DELTA=0.0 CV=0.975 CALL NCTPPF(CV,REAL(DF),DELTA,APPF) DLOWBC=DBLE(XBCP - APPF*XBCPSE) DHIGBC=DBLE(XBCP + APPF*XBCPSE) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C WRITE(ICOUT,5107) 5107 FORMAT('') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5170) 5170 FORMAT(' 12. Method: BCP (Bayesian Consensus ', 1 'Procedure):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5171) 5171 FORMAT('      ', 1 'Estimate of Consensus Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XBCP CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5172) 5172 FORMAT('      ', 1 'Standard Deviation of Consensus Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XBCPSE CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5178) 5178 FORMAT('      ', 1 'Standard Uncertainty (k = 1):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XBCPK1/2.0 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5179) 5179 FORMAT('      ', 1 'Expanded Uncertainty (k = 2):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XBCPK2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5180) 5180 FORMAT('      ', 1 'Degrees of Freedom:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)DF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5189) 5189 FORMAT('      ', 1 't Percent Point Value:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)APPF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5181) 5181 FORMAT('      ', 1 'Lower 95% (t) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWBC) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5182) 5182 FORMAT('      ', 1 'Upper 95% (t) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGBC) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5183) 5183 FORMAT('      ', 1 'Note: BCP Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5184) 5184 FORMAT('      ', 1 '         ', 1 '6 or Fewer Labs') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C CALL DPCONA(92,IBASLC) C 8002 FORMAT(A1,'begin{table}') 8005 FORMAT(A1,'begin{center}') 8006 FORMAT(5X,A1,'begin{tabular} {lr}') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8002)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006)IBASLC CALL DPWRST('XXX','WRIT') C 8011 FORMAT(5X,'{',A1,'bf 12. Method: BCP ', 1 '(Bayesian Consensus Procedure):} & ',2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XBCP,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8016 FORMAT(5X,'Consensus Mean Standard Deviation: & ', 1 F15.7,2X,A1,A1) 8020 FORMAT(5X,'Standard Uncertainty (k = 1): & ', 1 F15.7,2X,A1,A1) 8021 FORMAT(5X,'Expanded Uncertainty (k = 2): & ', 1 F15.7,2X,A1,A1) WRITE(ICOUT,8016)XBCPSE,IBASLC,IBASLC CALL DPWRST('XXX','RIT') WRITE(ICOUT,8020)XBCPK1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)XBCPK2,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8024 FORMAT(5X,'Degrees of Freedom: & ', 1 F15.7,2X,A1,A1) 8025 FORMAT(5X,'t Percent Point Value: & ', 1 F15.7,2X,A1,A1) 8026 FORMAT(5X,'Lower 95',A1,'% (t) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (t) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: BCP Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' 6 or Fewer Labs & ', 1 2X,A1,A1) WRITE(ICOUT,8024)DF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8025)APPF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)IBASLC,REAL(DLOWBC),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGBC),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8029)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8030 FORMAT(A1,'end{tabular}') 8031 FORMAT(A1,'end{center}') 8032 FORMAT(A1,'end{table}') WRITE(ICOUT,8030)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8031)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8032)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN C CALL DPCONA(92,IBASLC) C 6191 FORMAT(A1,'f',I1) IF(IRTFFF.EQ.'Courier New')THEN ITEMP=1 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN ITEMP=8 ELSE ITEMP=1 ENDIF WRITE(ICOUT,6191)IBASLC,ITEMP CALL DPWRST(ICOUT,'WRIT') C NCOL=4 IDEFPS=20 IFRST=IRTFPS*5500/IDEFPS IINC1=IRTFPS*1540/IDEFPS C DO6105ISET1=1,NCOL VALIGN(ISET1)='b' ALIGN(ISET1)='r' IF(NUMDI2(ISET1).LT.0.OR.NUMDI2(ISET1).GT.9)NUMDI2(ISET1)=7 6105 CONTINUE ALIGN(1)='l' NUMDI2(1)=0 NUMDI2(2)=7 C IWIDTH(1)=IFRST IWIDTH(2)=IWIDTH(1) + IINC1 C ITTEMP=' ' NCTEMP=0 NHEAD=0 C CALL DPRTF1(ITTEMP,NCTEMP,IHEAD,NHEAD) C NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. C IVALUE(1)=' b 12. Method: BCP (Bayesian Consensus Procedure)' IVALUE(1)(1:1)=IBASLC NCHAR(1)=49 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IFLAG1=.FALSE. NHEAD=1 C NCHAR(1)=30 IVALUE(1)=' Estimate of Consensus Mean:' AVALUE(2)=XBCP CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=37 IVALUE(1)=' Consensus Mean Standard Deviation:' AVALUE(2)=XBCPSE CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=XBCPK1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=XBCPK2 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=22 IVALUE(1)=' Degrees of Freedom:' AVALUE(2)=DF CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=25 IVALUE(1)=' t Percent Point Value:' AVALUE(2)=APPF CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=34 IVALUE(1)=' Lower 95% (t) Confidence Limit:' AVALUE(2)=REAL(DLOWBC) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=34 IVALUE(1)=' Upper 95% (t) Confidence Limit:' AVALUE(2)=REAL(DHIGBC) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: BCP Best Usage:' NCHAR(1)=24 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' 6 or Fewer Labs:' NCHAR(1)=25 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C CALL DPRTF6(NHEAD) IFLAG1=.TRUE. IFLAG2=.FALSE. C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'WOML')THEN ELSE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4001) 4001 FORMAT('12. Method: BCP (Bayesian Consensus Procedure)') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XBCP 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4006)XBCPSE 4006 FORMAT(' Consensus Mean Standard Deviation: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4012)XBCPK1 4012 FORMAT(' Standard Uncertainty (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4013)XBCPK2 4013 FORMAT(' Expanded Uncertainty (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4021)DF 4021 FORMAT(' Degrees of Freedom: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4022)APPF 4022 FORMAT(' t Percent Point Value: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4026)REAL(DLOWBC) 4026 FORMAT(' Lower 95% (t) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4027)REAL(DHIGBC) 4027 FORMAT(' Upper 95% (t) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: BCP Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' 6 or Fewer Labs') CALL DPWRST('XXX','WRIT') C ENDIF ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PBCP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBCP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPTS,NLAB 9013 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWBC,DHIGBC 9015 FORMAT('DLOWBC,DHIGBC = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPBECP(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) C C PURPOSE--FIND THE (10) BEST CANDIDATE MODELS FOR A LINEAR FIT C BASED ON MALLOW'S CP CRITERION. CODE EXTRACTED C FROM OMNITAB, WHICH USES THE FURNIVAL AND WILSON C LEAP AND BOUND 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 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--2002/6 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CCCCC SUPPORT MAXIMUM OF 38 INDPENDENT VARIABLES, CORRELATION CCCCC MATRIX ALSO NEEDS TO INCLUDE CONSTANT TERM AND DEPENDENT CCCCC VARIABLE. PARAMETER (MAXV=38) PARAMETER (MAXC=MAXV+2) C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASFI CHARACTER*4 ICASEQ CHARACTER*4 IKEY CCCCC CHARACTER*4 IHWUSE CCCCC CHARACTER*4 MESSAG CHARACTER*4 IHRESP(MAXC) CHARACTER*4 IHRES2(MAXC) CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHO.INC' C DOUBLE PRECISION SQRTCT(MAXOBV) INTEGER ILOCRV(MAXC) INTEGER ICOLRV(MAXC) REAL RXY(MAXC,MAXC) REAL XYMAT(MAXOBV*MAXC) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOST.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' C CHARACTER*8 IVLIST COMMON/BESTC1/IOUNI1,IOUNI2 COMMON/BESTC2/IVLIST(MAXV) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZD.INC' EQUIVALENCE (GARBAG(IGARB1),RXY(1,1)) EQUIVALENCE (G2RBAG(IGAR11),XYMAT(1)) EQUIVALENCE (DGARBG(IDGAR1),SQRTCT(1)) C CHARACTER*4 IBUGAZ 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='DPBE' ISUBN2='CP ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=MAXC MINV2=4 MINN2=2 NQ=1 C NUMPV=(-999) IP=(-999) IV=(-999) C IWIDMO=(-999) C NUMIND=(-999) C C ****************************** C ** TREAT THE BEST CP CASE ** C ****************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BECP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBECP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICOM.EQ.'BEST'.AND.IHARG(1).EQ.'CP ')GOTO111 IF(ICOM.EQ.'BEST'.AND.ICOM2.EQ.'CP ')GOTO180 C IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASFI='BECP' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ****************************************************** C ** STEP 3-- ** C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION ** C ** DETERMINE IF WE HAVE A VALID FUNCTIONAL ** C ** EXPRESSION--IN PARTICULAR, CHECK THAT THE NUMBER** C ** OF ARGUMENTS IS AT LEAST 1, AND ALSO CHECK ** C ** THAT THERE IS EXACTLY 1 EQUAL SIGN AND THAT ** C ** THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT. ** C ****************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LT.MINV2)THEN WRITE(ICOUT,2001) 2001 FORMAT('***** ERROR IN DPBECP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002) 2002 FORMAT(' NUMBER OF ARGUMENTS DETECTED IN BEST CP COMMAND', 1 ' < 4.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2003)NUMARG 2003 FORMAT(' NEED DEPENDENT VARIABLE AND AT LEAST 3 ', 1 'INDEPENDENT VARIABLES. NUMARG = ',I3) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH)) 2008 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO2110 2100 CONTINUE ILOCQ=NUMARG+1 GOTO2120 2110 CONTINUE ILOCQ=J1 GOTO2120 2120 CONTINUE C NQ=ILOCQ-1 C IF(NQ.GT.MAXV+1)THEN WRITE(ICOUT,2145)MAXV+1 2145 FORMAT('**** ERROR FROM BEST CP: MAXIMIUM NUMBER OF VARIABLES,', 1 I5,', EXCEEDED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE 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 ** C ** FACT, A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ** NOTE: FOR IMPLICIT MODEL, NO RESPONSE ** C ** VARIABLE. ** C **************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2310J=1,NQ ILOCF1=J IF(J.EQ.1)THEN IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) ENDIF IHRESP(J)=IHARG(ILOCF1) IHRES2(J)=IHARG2(ILOCF1) C CCCCC INDEPENDENT VARIABLE LIST FOR OMNITAB BEST CP CODE. C IF(J.GT.1)THEN JM1=J-1 IVLIST(JM1)(1:4)=IHRESP(J) IVLIST(JM1)(5:8)=IHRES2(J) ENDIF C DO2350I=1,NUMNAM I2=I IF(IHRESP(J).EQ.IHNAME(I2).AND.IHRES2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPBECP (BEST CP)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME AFTER THE WORD BEST CP') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE THE DEPENDENT VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST OR IS A PARAMETER ', 1 '(AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT LIST OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' AVAILABLE VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHRESP(J),IHRES2(J) 2369 FORMAT(' NAME AFTER THE WORD BEST CP = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2378 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2379 CONTINUE IF(J.EQ.1)THEN ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) ELSE ILOCRV(J)=I2 ICOLRV(J)=IVALUE(ILOCRV(J)) NTEMP=IN(ILOCRV(J)) IF(NTEMP.NE.NLEFT)THEN WRITE(ICOUT,2381) 2381 FORMAT('***** ERROR IN DPBECP (BEST CP)--ALL INDEPENDENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2383) 2383 FORMAT(' VARIABLES MUST HAVE THE SAME NUMBER OF ', 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2385)IHRESP(J),IHRES2(J),NTEMP 2385 FORMAT(' INDEPENDENT VARIABLE ',A4,A4,' HAS ',I8, 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2387)NLEFT 2387 FORMAT(' NUMBER OF OBSEVATIONS EXPECTED: ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 2310 CONTINUE C 2390 CONTINUE C C **************************************************** C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE COMMAND, CHECK THAT ** C ** THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER AND ** C ** LESS THAN MAXOB2. ** C **************************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NJUNK=MAX(MINN2,NQ-1) IF(NLEFT.GE.MINN2.AND.NLEFT.LE.MAXOBV)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPBECP (BEST CP)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS (FOR WHICH A ', 1'(IN VARIABLE ',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' BEST CP ANALYSIS WAS TO HAVE BEEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' PERFORMED MUST BE AT LEAST ',I8,' AND NO MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' THAN ',I8,'; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,319)(IANS(I),I=1,MIN(100,IWIDTH)) 319 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 390 CONTINUE C C ********************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BECP')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ***************************************************** C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN ** C ** COPY OVER THE DEPENDENT VARIABLE AND THE ** C ** THE INDPENENDENT VARIABLES INTO THE MATRIX ** C ** XYMAT. ALSO, CREATE A COLUMN OF "1"'s IN THE ** C ** MODEL INCLUDES AN ADDITIVE CONSTANT. ** C ***************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,601)N,ILOCQ-1 601 FORMAT('N,ILOCQ-1 = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C NTEMP=NLEFT C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NTEMP ISUB(I)=1 615 CONTINUE NQZ=NTEMP GOTO650 C 620 CONTINUE NIOLD=NTEMP CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQZ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NTEMP CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQZ=NFOR GOTO650 C 650 CONTINUE IFACT=1 IF(IFITAC.EQ.'OFF')IFACT=0 C J=0 DO4450I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4450 J=J+1 4450 CONTINUE NS=J C J=0 NFRST=2 NLAST=ILOCQ-1 ISTRT=NS*(NLAST-NFRST+1) DO4500I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4500 K=ICOLL J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XYMAT(ISTRT+J)=V(IJ) IF(K.EQ.MAXCP1)XYMAT(ISTRT+J)=PRED(I) IF(K.EQ.MAXCP2)XYMAT(ISTRT+J)=RES(I) IF(K.EQ.MAXCP3)XYMAT(ISTRT+J)=YPLOT(I) IF(K.EQ.MAXCP4)XYMAT(ISTRT+J)=XPLOT(I) IF(K.EQ.MAXCP5)XYMAT(ISTRT+J)=X2PLOT(I) IF(K.EQ.MAXCP6)XYMAT(ISTRT+J)=TAGPLO(I) 4500 CONTINUE C CCCCC NOTE: CONSTANT COLUMN IS NOT INCLUDED IN THE CCCCC DESIGN MATRIX. C CCCCC IF(IFITAC.EQ.'ON')THEN CCCCC DO4510I=1,NS CCCCC XYMAT(I)=1.0 C4510 CONTINUE CCCCC ISTRT=2*NS CCCCC ENDIF C J=0 C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4501) 4501 FORMAT('***** FROM DPBECP, FORMING XYMAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4503)NS,NFRST,NLAST,IFACT 4503 FORMAT('NS,NFRST,NLAST,IFACT = ',4(I8,2X)) CALL DPWRST('XXX','BUG ') DO4505I=1,ILOCQ WRITE(ICOUT,4507)I,ICOLRV(I),ILOCRV(I) 4507 FORMAT('I,ICOLRV(I),ILOCRV(I) = ',3(I8,2X)) CALL DPWRST('XXX','BUG ') 4505 CONTINUE ENDIF C DO4520I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4520 J=J+1 DO4600L=NFRST,NLAST K=ICOLRV(L) IJ=MAXN*(K-1)+I ISTRT=NS*(L-NFRST) IF(K.LE.MAXCOL)XYMAT(J+ISTRT)=V(IJ) IF(K.EQ.MAXCP1)XYMAT(J+ISTRT)=PRED(I) IF(K.EQ.MAXCP2)XYMAT(J+ISTRT)=RES(I) IF(K.EQ.MAXCP3)XYMAT(J+ISTRT)=YPLOT(I) IF(K.EQ.MAXCP4)XYMAT(J+ISTRT)=XPLOT(I) IF(K.EQ.MAXCP5)XYMAT(J+ISTRT)=X2PLOT(I) IF(K.EQ.MAXCP6)XYMAT(J+ISTRT)=TAGPLO(I) 4600 CONTINUE C 4520 CONTINUE NVARS=NLAST-NFRST+2 C C ****************************************************** C ** STEP 14-- ** C ** CARRY OUT THE ACTUAL FIT ** C ** VIA CALLING ** C ** DPBECP2 (FOR GENERAL MODELS), OR ** C ****************************************************** C ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IBUGAZ=IBUGA3 C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BECP')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPBECP, AS ABOUT TO CALL DPBEC2--') CALL DPWRST('XXX','BUG ') DO6083I=1,NS*NVARS WRITE(ICOUT,6084)I,XYMAT(I) 6084 FORMAT('I,(XYMAT(I) = ',I6,2X,G15.7) CALL DPWRST('XXX','BUG ') 6083 CONTINUE WRITE(ICOUT,6082)NLEFT,MAXN,NS,NVARS 6082 FORMAT('NLEFT,MAXN,NS,NVARS = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV 6091 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C 6520 CONTINUE C INTCPT=IFACT MBEST=INUMCP IF(NVARS-1.LE.3 .AND. MBEST.GT.7)MBEST=7 CALL DPBEC2(XYMAT,N,NVARS,SQRTCT,RXY, 1MAXC,MAXV, 1MBEST,INTCPT, 1IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO6590 C 6590 CONTINUE C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BECP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBECP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3,NS 9012 FORMAT('IBUGA2,IBUGA3,NS = ',A4,2X,A4,1X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMNAM 9016 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9017I=1,NUMNAM WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 9018 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9017 CONTINUE 9042 CONTINUE 9049 CONTINUE WRITE(ICOUT,9051)NLEFT,NS,V(1),PRED(1),RES(1) 9051 FORMAT('NLEFT,NS,V(1),PRED(1),RES(1) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH)) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBEC2(XYMAT,N,NVARS,SQRTCT,RXY, 1MAXC,MAXV, 1MBEST,INTCPT, 1IBUGA3,ISUBRO,IERROR) C C BEST CP: COMPUTE MBEST (DEFAULT=10) BEST CANDIDATE MODELS BASED C ON MALLOW'S CP CRITIERION. CODE EXTRACTED FROM OMNITAB, WHICH C IMPLEMENTS THE FURNIVAL AND WILSON LEAP AND BOUND ALGORITHM. C C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2002/6 C ORIGINAL VERSION--JUNE 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C INTEGER N, NVARS C DOUBLE PRECISION SQRTCT(*) REAL RXY(MAXC,MAXC) REAL XYMAT(*) C PARAMETER (MAXV2=38) CHARACTER*8 IVLIST COMMON/BESTC1/IOUNI1,IOUNI2 COMMON/BESTC2/IVLIST(MAXV2) C INCLUDE 'DPCOF2.INC' 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='DPBE' ISUBN2='C2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'BEC2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NVARS,MBEST,INTCPT 52 FORMAT('N,NVARS,MBEST,INTCPT = ',4I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 0.5-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C ISTEPN='0.5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='BEC2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='BEC2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C C ***************************************************** C ** STEP 2-- ** C ** CALL OMNITAB ROUTINES CRSPRD AND SCREEN. ** C ***************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL CRSPRD(XYMAT,N,NVARS,INTCPT,SQRTCT,RXY,MAXC) C NDF=N-1 NPARAM=NVARS-1 ITYPE=3 NSPAC=MAXC*20000 C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')THEN WRITE(ICOUT,7112)N,NVARS 7112 FORMAT(6X,'AFTER CALL TO CRSPRD, N, NVARS = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7113)NDF,NPARAM 7113 FORMAT(6X,'NDF,NPARAM = ',2I8) CALL DPWRST('XXX','BUG ') DO7115I=1,NVARS WRITE(ICOUT,7117)I,(RXY(I,J),J=1,MIN(NVARS,7)) 7117 FORMAT('ROW ',I5,' = ',7(G15.7)) CALL DPWRST('XXX','BUG ') 7115 CONTINUE ENDIF C CALL SCREEN(RXY,NPARAM,MAXC,NDF,ITYPE,MBEST,INTCPT,XYMAT,NSPAC) C C **************************************************** C ** STEP 3-- ** C ** WRITE INFO OUT TO FILES-- ** C ** 1) DPST1F.DAT--XXXXX ** C **************************************************** C 8100 CONTINUE C ISTEPN='81' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO8119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112) 8112 FORMAT(6X,'NUMBER OF VARIABLES, CP VALUE, VARIABLE LIST WRITTEN ', 1 'TO FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT(6X,'CODED VARIABLE LIST WRITTEN TO TO FILE DPST2F.DAT') CALL DPWRST('XXX','BUG ') 8119 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO8129 8129 CONTINUE C C ************************************** C ** STEP 82-- ** C ** CLOSE THE STORAGE FILES. ** C ************************************** C 8200 CONTINUE C ISTEPN='82' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'BEC2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBEC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBELL(IHARG,NUMARG,IBELSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE BELL SWITCH IBELSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IBELSW ('ON' OR 'OFF') 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--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IBELSW 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(NUMARG.EQ.0)GOTO1150 IF(NUMARG.GE.1)GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 GOTO1199 C 1150 CONTINUE IBELSW='ON' GOTO1180 C 1160 CONTINUE IBELSW='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBELSW 1181 FORMAT('THE BELL SWITCH HAS JUST BEEN TURNED ', 1A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBFCO(IHARG,NUMARG,IDEBFC,MAXBAR,IBAFCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR FILL COLORS = THE COLORS C OF THE (BACKGROUND) FILL WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR IBAFCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBFC C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBAFCO (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 IDEBFC CHARACTER*4 IBAFCO 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 IBAFCO(*) 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='DPBF' ISUBN2='CO ' C NUMBAR=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 DPBFCO--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBFC 55 FORMAT('IDEBFC = ',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)IBAFCO(1) 70 FORMAT('IBAFCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBAFCO(I) 76 FORMAT('I,IBAFCO(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBAFCO(1)=IDEBFC GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBFC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBFC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFC IBAFCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBAFCO(I) 1276 FORMAT('THE FILL COLOR OF BAR ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBFC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBFC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFC DO1315I=1,NUMBAR IBAFCO(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)IBAFCO(I) 1316 FORMAT('THE FILL COLOR OF ALL BARS', 1' HAS 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 DPBFCO--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBFC 9015 FORMAT('IDEBFC = ',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)IBAFCO(1) 9030 FORMAT('IBAFCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBAFCO(I) 9036 FORMAT('I,IBAFCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBFSW(IHARG,NUMARG,IDEBFS,MAXBAR,IBAFSW, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR FILL SWITCHES = THE ON/OFF SWITCHES C OF THE (BACKGROUND) FILL WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR IBAFSW(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBFS C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBAFSW (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 IDEBFS CHARACTER*4 IBAFSW 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 IBAFSW(*) 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='DPBF' ISUBN2='SW ' C NUMBAR=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 DPBFSW--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBFS 55 FORMAT('IDEBFS = ',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)IBAFSW(1) 70 FORMAT('IBAFSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBAFSW(I) 76 FORMAT('I,IBAFSW(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1='ON' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBAFSW(1)='ON' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFS IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFS IBAFSW(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBAFSW(I) 1276 FORMAT('THE FILL SWITCH FOR BAR ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='ON' IF(IHOLD1.EQ.'OFF')IHOLD2='OFF' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFS IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFS DO1315I=1,NUMBAR IBAFSW(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)IBAFSW(I) 1316 FORMAT('THE FILL SWITCH FOR ALL BARS', 1' HAS 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 DPBFSW--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBFS 9015 FORMAT('IDEBFS = ',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)IBAFSW(1) 9030 FORMAT('IBAFSW(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBAFSW(I) 9036 FORMAT('I,IBAFSW(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBIHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1CLLIMI,CLWIDT, 1Y1,Y2,C1,C2, CCCCC MARCH 1996. ADD FOLLOWING LINE. 1IRHSTG, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 2 PLOTS-- C 1) BIHISTOGRAM; C 2) RELATIVE BIHISTOGRAM; 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C UPDATED --MARCH 1996. IRHSTG SWITCH 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 IRELAT CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CCCCC CHARACTER*4 IDATSW CHARACTER*4 IHLE11 CHARACTER*4 IHLE12 CHARACTER*4 IHLE21 CHARACTER*4 IHLE22 CCCCC CHARACTER*4 IHRIGH CCCCC CHARACTER*4 IHRIG2 CHARACTER*4 IERRO4 CCCCC MARCH 1996. ADD FOLLOWING LINE. CHARACTER*4 IRHSTG C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION CLLIMI(*) DIMENSION CLWIDT(*) CCCCC DIMENSION BAWIDT(*) DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION C1(*) DIMENSION C2(*) 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='DPBI' ISUBN2='HI ' 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 ICOLL2=0 C NUMV2=2 C C ******************************************* C ** TREAT THE BIHISTOGRAM AND RELATED ** C ** STATISTICAL DISTRIBUTION PLOTS CASE ** C ******************************************* C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBIHI--') 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 IF(ICOM.EQ.'BIHI')GOTO110 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'BIHI')GOTO120 C IFOUND='NO' GOTO9000 C 110 CONTINUE ICASPL='BIHI' IRELAT='OFF' GOTO180 C 120 CONTINUE ICASPL='BIHI' IRELAT='ON' ILASTC=1 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='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=2 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ************************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE FIRST RESPONSE VARIABLE) ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS WILL BE THE SECOND RESPONSE VARIABLE) ** C ************************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLE11=IHARG(1) IHLE12=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLE11,IHLE12,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL1=IVALUE(ILOCV) NLEFT1=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLE11,IHLE12,ICOLL1,NLEFT1 211 FORMAT('IHLE11,IHLE12,ICOLL1,NLEFT1 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IHLE21=IHARG(2) IHLE22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHLE21,IHLE22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLL2=IVALUE(ILOCV) NLEFT2=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,221)IHLE21,IHLE22,ICOLL2,NLEFT2 221 FORMAT('IHLE21,IHLE22,ICOLL2,NLEFT2 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT1) ** C ** FOR THE FIRST RESPONSE VARIABLE IS POSITIVE. ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT2) ** C ** FOR THE SECOND RESPONSE VARIABLE IS POSITIVE. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT1.GE.MINN2.AND.NLEFT2.GE.MINN2)GOTO390 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPBIHI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'BIHI'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A BIHISTOGRAM ') IF(ICASPL.EQ.'BIHI'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'BIHI'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A RELATIVE BIHISTOGRAM ') IF(ICASPL.EQ.'BIHI'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') 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 4-- ** 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='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 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 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPBIHI') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ***************************************** C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ** AND CARRY OUT THE PLOTS. ** C ***************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NLEFMX=NLEFT1 IF(NLEFT2.GT.NLEFT1)NLEFMX=NLEFT2 C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFMX ISUB(I)=1 615 CONTINUE NQ=NLEFMX GOTO650 C 620 CONTINUE NIOLD=NLEFMX CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFMX CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE J=0 IMAX=NLEFT1 IF(NQ.LT.NLEFT1)IMAX=NQ DO651I=1,IMAX IF(ISUB(I).EQ.0)GOTO651 J=J+1 IJ=MAXN*(ICOLL1-1)+I IF(ICOLL1.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLL1.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLL1.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLL1.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLL1.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLL1.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLL1.EQ.MAXCP6)Y1(J)=TAGPLO(I) 651 CONTINUE N1=J C J=0 IMAX=NLEFT2 IF(NQ.LT.NLEFT2)IMAX=NQ DO652I=1,IMAX IF(ISUB(I).EQ.0)GOTO652 J=J+1 IJ=MAXN*(ICOLL2-1)+I IF(ICOLL2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLL2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLL2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLL2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLL2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLL2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLL2.EQ.MAXCP6)Y2(J)=TAGPLO(I) 652 CONTINUE N2=J C C **************************************************************** C ** STEP 7-- C ** DETERMINE IF THE ANALYST C ** HAS SPECIFIED 1) THE CLASS WIDTH, C ** 2) THE MIN POINT OF THE FIRST CELL, C ** 3) THE MAX POINT OF THE LAST CELL, C ** FOR THE DISTRIBUTIONAL ANALYSIS. C ** IF NON-DEFAULT, USE THE SPECIFIED VALUES. C ** IF DEFAULT, USE THE DEFAULT VALUES-- C ** 1) CLASS WIDTH = .3 OF A SAMPLE STANDARD DEVIATION; C ** 2) START = SAMPLE MEAN - 6*(SAMPLE STANDARD DEVIATION); C ** 3) STOP = SAMPLE MEAN + 6*(SAMPLE STANDARD DEVIATION); C ** NOTE THAT THE DEFAULT SETTINGS ARE IN FACT C **************************************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CLWID=CLWIDT(1) CCCCC BAWID=BAWIDT(1) XSTART=CLLIMI(1) XSTOP=CLLIMI(2) C C ***************************************************** C ** STEP 8-- ** C ** FORM THE VERTICAL AND HORIZONTAL AXIS ** C ** VALUES Y(.) AND X(.) FOR THE PLOT. ** C ** RESET THE VECTOR D(.) TO ALL ONES. ** C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ***************************************************** C CALL DPBIH2(Y1,N1,Y2,N2,ICASPL,IRELAT,MAXN, 1CLWID,XSTART,XSTOP, 1C1,C2, CCCCC MARCH 1996. ADD FOLLOWING LINE. 1IRHSTG, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) 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 DPBIHI--') 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)IRELAT,CLWID,XSTART,XSTOP 9014 FORMAT('IRELAT,CLWID,XSTART,XSTOP = ',A4,2X,3E15.7) 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 DPBIH2(Y1,N1,Y2,N2,ICASPL,IRELAT,MAXN, 1CLWID,XSTART,XSTOP, 1C1,C2, CCCCC MARCH 1996. ADD FOLLOWING LINE. 1IRHSTG, 1Y9,X9,D9,N9,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) A BIHISTOGRAM, C 2) A RELATIVE BIHISTOGRAM C (THAT IS, WITH AREA = 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-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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C UPDATED --JANUARY 1989. DOUBLE PRECISION (MANY PLACES) C UPDATED --JUNE 1995. FIX RELATIVE BIHIST PROBLEM C UPDATED --MARCH 1996. FIX RELATIVE BIHIST PROBLEM C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IRELAT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 C CCCCC MARCH 1996. ADD FOLLOWING LINE. CHARACTER*4 IRHSTG C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN9 C C--------------------------------------------------------------------- DOUBLE PRECISION DCLWID DOUBLE PRECISION DXSTAR DOUBLE PRECISION DXSTOP DOUBLE PRECISION DCLMNJ DOUBLE PRECISION DCLMDJ DOUBLE PRECISION DCLMXJ DOUBLE PRECISION DJ DOUBLE PRECISION DY1I DOUBLE PRECISION DY2I DOUBLE PRECISION DABSDE DOUBLE PRECISION DTOTWI C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION C1(*) DIMENSION C2(*) DIMENSION Y9(*) DIMENSION X9(*) DIMENSION D9(*) 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='DPBI' ISUBN9='H2 ' C IERROR='NO' C AN1=N1 AN2=N2 C DCLWID=CLWID DXSTAR=XSTART DXSTOP=XSTOP C K=(-999) DCLMDJ=(-999.0D0) C SUM1=0.0 SUM2=0.0 DENOM1=0.0 DENOM2=0.0 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N1.GE.1)GOTO39 IF(N1.GE.1.AND.N2.GE.1)GOTO39 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPBIH2--') 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)N1,N2 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 39 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPBIH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N1,N2,CLWID,XSTART,XSTOP 72 FORMAT('N1,N2,CLWID,XSTART,XSTOP = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N1 WRITE(ICOUT,74)I,Y1(I) 74 FORMAT('I, Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE DO75I=1,N2 WRITE(ICOUT,76)I,Y2(I) 76 FORMAT('I, Y2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 80 CONTINUE C C ********************************************** C ** STEP 11-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C IF(CLWID.NE.CPUMIN.AND.DXSTAR.NE.CPUMIN.AND. 1DXSTOP.NE.CPUMAX)GOTO1119 C IWRIT2='OFF' CALL MEAN(Y1,N1,IWRIT2,YMEAN1,IBUGG3,IERROR) CALL MEAN(Y2,N2,IWRIT2,YMEAN2,IBUGG3,IERROR) YMEAN=(AN1*YMEAN1+AN2*YMEAN2)/(AN1+AN2) SUM=0.0 DO1121I=1,N1 SUM=SUM+(Y1(I)-YMEAN)**2 1121 CONTINUE DO1122I=1,N2 SUM=SUM+(Y2(I)-YMEAN)**2 1122 CONTINUE YVAR=SUM/(AN1+AN2-1.0) YSD=SQRT(YVAR) C IF(CLWID.EQ.CPUMIN)DCLWID=0.3*YSD IF(DXSTAR.EQ.CPUMIN)DXSTAR=YMEAN-6.0*YSD IF(DXSTOP.EQ.CPUMAX)DXSTOP=YMEAN+6.0*YSD C 1119 CONTINUE DTOTWI=DXSTOP-DXSTAR ANUMCL=DTOTWI/DCLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 DJ=J DCLMXJ=DXSTAR+DJ*DCLWID DABSDE=DABS(DCLMXJ-DXSTOP) IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1 C C ********************************************************** C ** STEP 21-- ** C ** DETERMINE THE CLASS COUNTS FOR RESPONSE VARIABLE 1 ** C ********************************************************** C DO2110J=1,NUMCLA C1(J)=0.0 2110 CONTINUE C DO2120I=1,N1 DY1I=Y1(I) DO2130J=1,NUMCLA J2=J DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DCLMNJ.LE.DY1I.AND.DY1I.LT.DCLMXJ)GOTO2135 2130 CONTINUE GOTO2120 2135 CONTINUE C1(J2)=C1(J2)+1.0 2120 CONTINUE C J=NUMCLA DO2150I=1,N1 DY1I=Y1(I) DJ=J DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DY1I.EQ.DCLMXJ)C1(J)=C1(J)+1.0 2150 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2165 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2161) 2161 FORMAT('***** IN THE MIDDLE OF DPBIH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2162)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA 2162 FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ', 14D11.4,E11.4,I8) CALL DPWRST('XXX','BUG ') DO2163J=1,NUMCLA DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP FJ=C1(J) WRITE(ICOUT,2164)J,DCLMNJ,DCLMXJ,FJ 2164 FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7) CALL DPWRST('XXX','BUG ') 2163 CONTINUE 2165 CONTINUE C C ********************************************************** C ** STEP 22-- ** C ** DETERMINE THE CLASS COUNTS FOR RESPONSE VARIABLE 2 ** C ********************************************************** C DO2210J=1,NUMCLA C2(J)=0.0 2210 CONTINUE C DO2220I=1,N2 DY2I=Y2(I) DO2230J=1,NUMCLA J2=J DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DCLMNJ.LE.DY2I.AND.DY2I.LT.DCLMXJ)GOTO2235 2230 CONTINUE GOTO2220 2235 CONTINUE C2(J2)=C2(J2)+1.0 2220 CONTINUE C J=NUMCLA DO2250I=1,N2 DY2I=Y2(I) DJ=J DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DY2I.EQ.DCLMXJ)C2(J)=C2(J)+1.0 2250 CONTINUE C IF(IBUGG3.EQ.'OFF')GOTO2265 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2261) 2261 FORMAT('***** IN THE MIDDLE OF DPBIH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2262)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA 2262 FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ', 14D11.4,E11.4,I8) CALL DPWRST('XXX','BUG ') DO2263J=1,NUMCLA DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP FJ=C2(J) WRITE(ICOUT,2264)J,DCLMNJ,DCLMXJ,FJ 2264 FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7) CALL DPWRST('XXX','BUG ') 2263 CONTINUE 2265 CONTINUE C C ********************************** C ** STEP 31-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR RESPONSE VARIABLE 1 ** C ********************************** C SUM1=0.0 DO3110J=1,NUMCLA FJ=C1(J) SUM1=SUM1+FJ 3110 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1995 AN3=SUM1 C DENOM1=1.0 CCCCC THE FOLLOWING LINE WAS FIXED JUNE 1995 CCCCC IF(IRELAT.EQ.'ON')DENOM1=SUM1 CCCCC IF(IRELAT.EQ.'ON')DENOM1=AN3*DCLWID CCCCC MARCH 1996. ABOVE LINE COMMENTED OUT. NOTE THAT THERE ARE 2 CCCCC WAYS TO DEFINE HEIGHT FOR RELATIVE HISTOGRAM. ONE WAY DEFINES CCCCC THE AREA SO THAT THE AREA SUMS TO 1 (I.E., THE INTEGRAL) AS IN CCCCC A PROBABILITY DENSITY FUNCTION. THE OTHER WAY IS SO THAT THE CCCCC THE HEIGHTS SUM TO 1, I.E., THE HEIGHT IS THE PERCENT OF THE CCCCC TOTAL. THE IRHSTG SWITCH NOW DETERMINES WHICH METHOD IS USED. C IF(IRELAT.EQ.'ON')THEN IF(IRHSTG.EQ.'PERC')THEN DENOM1=AN3 ELSE DENOM1=AN3*DCLWID ENDIF ENDIF C K=0 DO3120J=1,NUMCLA K=K+1 DJ=J DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID FJ=C1(J) X9(K)=DCLMDJ Y9(K)=FJ/DENOM1 D9(K)=1.0 3120 CONTINUE C C ********************************** C ** STEP 32-- ** C ** DETERMINE PLOT COORDINATES ** C ** FOR RESPONSE VARIABLE 2 ** C ********************************** C SUM2=0.0 DO3210J=1,NUMCLA FJ=C2(J) SUM2=SUM2+FJ 3210 CONTINUE CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1995 AN4=SUM2 C DENOM2=1.0 CCCCC THE FOLLOWING LINE WAS FIXED JUNE 1995 CCCCC IF(IRELAT.EQ.'ON')DENOM2=SUM2 CCCCC IF(IRELAT.EQ.'ON')DENOM2=AN4*DCLWID CCCCC MARCH 1996. ABOVE LINE COMMENTED OUT. NOTE THAT THERE ARE 2 CCCCC WAYS TO DEFINE HEIGHT FOR RELATIVE HISTOGRAM. ONE WAY DEFINES CCCCC THE AREA SO THAT THE AREA SUMS TO 1 (I.E., THE INTEGRAL) AS IN CCCCC A PROBABILITY DENSITY FUNCTION. THE OTHER WAY IS SO THAT THE CCCCC THE HEIGHTS SUM TO 1, I.E., THE HEIGHT IS THE PERCENT OF THE CCCCC TOTAL. THE IRHSTG SWITCH NOW DETERMINES WHICH METHOD IS USED. C IF(IRELAT.EQ.'ON')THEN IF(IRHSTG.EQ.'PERC')THEN DENOM2=AN4 ELSE DENOM2=AN4*DCLWID ENDIF ENDIF C C DO3220J=1,NUMCLA K=K+1 DJ=J DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID FJ=C2(J) X9(K)=DCLMDJ Y9(K)=(-FJ/DENOM2) D9(K)=2.0 3220 CONTINUE C N9=K NPLOTV=3 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 DPBIH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR 9012 FORMAT('ICASPL,IRELAT,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)N1,N2 9021 FORMAT('N1,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9023I=1,N1 WRITE(ICOUT,9024)I,Y1(I) 9024 FORMAT('I, Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9023 CONTINUE DO9025I=1,N2 WRITE(ICOUT,9026)I,Y2(I) 9026 FORMAT('I, Y2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE WRITE(ICOUT,9033)SUM1,DENOM1,SUM2,DENOM2 9033 FORMAT('SUM1,DENOM1,SUM2,DENOM2 = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)N9 9031 FORMAT('N9 = ',I8) CALL DPWRST('XXX','BUG ') DO9035I=1,N9 WRITE(ICOUT,9036)I,Y9(I),X9(I),D9(I) 9036 FORMAT('I,Y9(I),X9(I),D9(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE WRITE(ICOUT,9037)DCLWID,DXSTAR,DXSTOP 9037 FORMAT('DCLWID,DXSTAR,DXSTOP = ',3D15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBIN(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, CCCCC MARCH 2006: ADD FOLLOWING LINE TO ALLOW DIFFERENT CCCCC ALTERNATIVES TO BINNING 1TEMP1,MAXNXT,IHSTCW, 1Y2,X2,N2,IBUGG3,IERROR) C C PURPOSE--BIN A VARIABLE Y INTO X2 Y2. C THAT IS CONVERT RAW DATA TO FREQUENCY DATA. C BINNING CAN BE EITHER TO COUNTS OR TO RELATIVE C FREQUENCY. 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--98/11 C ORIGINAL VERSION--NOVEMBER 1998. C UPDATED --MARCH 2006. SUPPORT FOR DIFFERENT C CLASS WIDTH ALGORITHMS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IRELAT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 CHARACTER*4 IRHSTG CHARACTER*4 IHSTCW C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- DOUBLE PRECISION DCLWID DOUBLE PRECISION DXSTAR DOUBLE PRECISION DXSTOP DOUBLE PRECISION DCLMNJ DOUBLE PRECISION DCLMDJ DOUBLE PRECISION DCLMXJ DOUBLE PRECISION DJ DOUBLE PRECISION DXI DOUBLE PRECISION DABSDE DOUBLE PRECISION DTOTWI C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION TEMP1(*) 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='DPBI' ISUBN2='N ' C IERROR='NO' C K=(-999) DCLMDJ=(-999.0D0) C KP3=0 C AN3=0.0 DENOM=0.0 C DCLWID=CLWID DXSTAR=XSTART DXSTOP=XSTOP C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LE.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN BINNING DATA (DPBIN)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)HOLD 62 FORMAT(' ALL INPUT DATA ELEMENTS ARE IDENTICALLY EQUAL ', 1 'TO ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPBIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IRELAT,IRHSTG,IHSTCW 71 FORMAT('IRELAT,IRHSTG,IHSTCW = ',3(A4,1X)) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP 72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I) 74 FORMAT('I, Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE ENDIF C C ********************************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C 110 CONTINUE CCCCC IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND. CCCCC1XSTOP.NE.CPUMAX)GOTO119 CCCCC IWRIT2='OFF' CCCCC CALL MEAN(Y,N,IWRIT2,YMEAN,IBUGG3,IERROR) CCCCC CALL SD(Y,N,IWRIT2,YSD,IBUGG3,IERROR) CCCCC IF(CLWID.EQ.CPUMIN)DCLWID=0.3*YSD CCCCC IF(XSTART.EQ.CPUMIN)DXSTAR=YMEAN-6.0*YSD CCCCC IF(XSTOP.EQ.CPUMAX)DXSTOP=YMEAN+6.0*YSD CC119 CONTINUE C C MARCH 2006: ALLOW DIFFERENT DEFAULT BINNING ALGORITHMS (AS C SPECIFIED BY IHSTCW). C IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR. 1 XSTOP.EQ.CPUMAX)THEN IWRIT2='OFF' CALL MEAN(Y,N,IWRIT2,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRIT2,XSD,IBUGG3,IERROR) C IF(IHSTCW.EQ.'DEFA')THEN IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD ELSEIF(IHSTCW.EQ.'NORM')THEN IF(CLWID.EQ.CPUMIN)DCLWID=3.5*XSD/(REAL(N)**(1./3.)) ELSEIF(IHSTCW.EQ.'NCOR')THEN IF(CLWID.EQ.CPUMIN)THEN CALL STMOM3(Y,N,IWRIT2,XSKEW,IBUGG3,IERROR) CALL STMOM4(Y,N,IWRIT2,XKURT,IBUGG3,IERROR) TERM1=3.5*XSD/(REAL(N)**(1./3.)) IF(XSKEW.GT.0.0 .AND. XSKEW.LT.3.0)THEN TERM2=1.0/(1.0 - 0.0060*XSKEW + 0.27*XSKEW**2 - 1 0.0069*XSKEW**3) ELSE TERM2=1.0 ENDIF XKURT=XKURT - 3.0 IF(XKURT.GT.0.0 .AND. XKURT.LT.6.0)THEN TERM3=1.0 - 0.2*(1.0 - EXP(-0.7*XKURT)) ELSE TERM3=1.0 ENDIF DCLWID=DBLE(TERM1*TERM2*TERM3) ENDIF ELSEIF(IHSTCW.EQ.'IQ ')THEN IF(CLWID.EQ.CPUMIN)THEN CALL LOWQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XLOWQ, 1 IBUGG3,IERROR) CALL UPPQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XUPPQ, 1 IBUGG3,IERROR) XIQ=XUPPQ - XLOWQ DCLWID=2.603*XIQ/(REAL(N)**(1./3.)) ENDIF ELSE IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD ENDIF C IF(XSTART.EQ.CPUMIN)DXSTAR=XMEAN-6.0*XSD IF(XSTOP.EQ.CPUMAX)DXSTOP=XMEAN+6.0*XSD ENDIF C 180 CONTINUE DO181I=1,N X2(I)=0.0 Y2(I)=0.0 181 CONTINUE DTOTWI=DXSTOP-DXSTAR ANUMCL=DTOTWI/DCLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 DJ=J DCLMXJ=DXSTAR+DJ*DCLWID DABSDE=DABS(DCLMXJ-DXSTOP) IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C 410 CONTINUE DO420I=1,N DXI=Y(I) DO430J=1,NUMCLA J2=J DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440 430 CONTINUE GOTO420 440 CONTINUE Y2(J2)=Y2(J2)+1.0 420 CONTINUE C C FOR THIS RAW DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C J=NUMCLA DO450I=1,N DJ=J DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP DXI=Y(I) IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0 450 CONTINUE C 590 CONTINUE IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** IN THE MIDDLE OF DPBIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA 592 FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ', 1 4D11.4,F10.0,I8) CALL DPWRST('XXX','BUG ') DO593J=1,NUMCLA DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP FJ=Y2(J) WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ 594 FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7) CALL DPWRST('XXX','BUG ') 593 CONTINUE ENDIF C 1100 CONTINUE SUM=0.0 DO1110J=1,NUMCLA FJ=Y2(J) SUM=SUM+FJ 1110 CONTINUE AN3=SUM C DENOM=1.0 C IF(IRELAT.EQ.'ON')THEN IF(IRHSTG.EQ.'PERC')THEN DENOM=AN3 ELSE DENOM=AN3*DCLWID ENDIF ENDIF C DO1120J=1,NUMCLA K=J DJ=J DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID FJ=Y2(J) X2(K)=DCLMDJ Y2(K)=FJ/DENOM 1120 CONTINUE N2=K C DO1130J=NUMCLA,1,-1 IF(Y2(J).GT.0.0)THEN N2=J GOTO1139 ENDIF 1130 CONTINUE N2=1 1139 CONTINUE C DO1140J=1,N2 IF(Y2(J).GT.0.0)THEN IFRST=J GOTO1149 ENDIF 1140 CONTINUE IFRST=1 1149 CONTINUE K=0 DO1150J=IFRST,N2 K=K+1 X2(K)=X2(J) Y2(K)=Y2(J) 1150 CONTINUE C IF(N2.LT.NUMCLA)THEN DO1160I=N2+1,NUMCLA Y2(I)=0.0 X2(I)=0.0 1160 CONTINUE ENDIF N2=K GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IRELAT,IERROR,N2 9012 FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)AN3,DENOM 9013 FORMAT('AN3,DENOM = ',E15.8,E15.8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,X2(I),Y2(I) 9016 FORMAT('I,X2(I),Y2(I) = ',I8,E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP 9017 FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPBINA(Y,N,CLWID,XSTART,XSTOP,M, 1XTEMP1,MAXOBV, 1IRELAT,IASHWT,IHSTCW, 1Y2,X2,N2,IBUGG3,IERROR) C C PURPOSE--COMPUTE HISTOGRAM BINS USING THE "AVERAGE SHIFTED C HISTOGRAM" (ASH) ALGORITHM DOCUMENTED BY DAVID SCOTT, C 1992, "MULTIVARIATE DENSITY ESTIMATION: THEORY, C PRACTICE, AND VISUALIZATION", WILEY, CHAPTER 5. C WE IMPLEMENT THE ALGORITHMS BIN1 AND ASH1 GIVEN ON C PAGES 117-118. THE BINNED DATA IS RETURNED IN C Y2 AND X2. C C NOTE THAT SINCE THE ASH BINNING IS INTENDED TO BE A C SIMPLE DENSITY ESTIMATOR, THIS ALGORITHM IS C IMPLEMENTED FOR THE "RELATIVE FREQUENCY" CASE, NOT C RAW COUNTS. C C THE BASIC IDEA IS: C C 1) GIVEN A CLASS WIDTH OF H C 2) CHOOSE M WHERE WE CONSTRUCT A COLLECTION OF M C HISTOGRAMS, EACH WITH A CLASS WIDTH OF H, BUT C WITH START POINTS C t0 = 0, h/m, 2*h/m, ... , (m-1)*h/m C 3) THIS RESULTS IN A SMOOTHED HISTOGRAM WITH C A BIN WIDTH OF DELTA=H/M. HIGHER VALUES OF M C RESULT IN A SMOOTHER ESTIMATE. VALUES OF M ARE C TYPICALLY IN THE RANGE 4 TO 32. IN THIS C SUBROUTINE, VALUES OF M < 1 ARE SET TO 1 AND C VALUES OF M > 64 ARE SET TO 64. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C PARAMETER(MAXM=64) C CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 CHARACTER*4 IRELAT CHARACTER*4 IASHWT CHARACTER*4 IHSTCW C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- DOUBLE PRECISION DCLWID DOUBLE PRECISION DXSTAR DOUBLE PRECISION DXSTOP DOUBLE PRECISION DH DOUBLE PRECISION DELTA DOUBLE PRECISION DX DOUBLE PRECISION DNBIN DOUBLE PRECISION DN C C----------------------------------------------------------------- C DIMENSION Y(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION XTEMP1(*) C DIMENSION WTM(2*MAXM) 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='DPBI' ISUBN2='N ' C IERROR='NO' C DCLWID=CLWID DXSTAR=XSTART DXSTOP=XSTOP C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.LE.5)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN AVERAGE SHIFTED HISTOGRAM BINNING--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5;') 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 ENDIF C IF(M.LT.1 .OR. M.GT.MAXM)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,42) 42 FORMAT(' THE VALUE OF THE M PARAMETER MUST BE AT ', 1 'LEAST 1 AND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,44)MAXM 44 FORMAT(' LESS THAN OR EQUAL TO ',I5,' (RECOMMENDED ', 1 'VALUES ARE 4, 8, 16, OR 32).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)M 46 FORMAT(' THE ENTERED VALUE OF M HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C HOLD=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)HOLD 62 FORMAT(' ALL INPUT OBSERVATIONS ARE IDENTICALLY EQUAL ', 1 'TO ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 69 CONTINUE C IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPBINA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,M,CLWID,XSTART,XSTOP 71 FORMAT('N,M,CLWID,XSTART,XSTOP = ',2I6,3G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IASHWT 72 FORMAT('IASHWT = ',A4) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I) 74 FORMAT('I, Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE ENDIF C C *********************************** C ** STEP 2-- ** C ** IF NECESSARY, DETERMINE: ** C ** 1) CLASS WIDTH ** C ** 2) START VALUE ** C ** 3) STOP VALUE ** C ** 4) NUMBER OF BINS ** C *********************************** C IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR. 1XSTOP.EQ.CPUMAX)THEN IWRIT2='OFF' CALL MEAN(Y,N,IWRIT2,XMEAN,IBUGG3,IERROR) CALL SD(Y,N,IWRIT2,XSD,IBUGG3,IERROR) CALL MINIM(Y,N,IWRIT2,XMIN,IBUGG3,IERROR) CALL MAXIM(Y,N,IWRIT2,XMAX,IBUGG3,IERROR) IF(IHSTCW.EQ.'DEFA')THEN IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD ELSEIF(IHSTCW.EQ.'NORM')THEN IF(CLWID.EQ.CPUMIN)DCLWID=3.5*XSD/(REAL(N)**(1./3.)) ELSEIF(IHSTCW.EQ.'NCOR')THEN IF(CLWID.EQ.CPUMIN)THEN CALL STMOM3(Y,N,IWRIT2,XSKEW,IBUGG3,IERROR) CALL STMOM4(Y,N,IWRIT2,XKURT,IBUGG3,IERROR) TERM1=3.5*XSD/(REAL(N)**(1./3.)) IF(XSKEW.GT.0.0 .AND. XSKEW.LT.3.0)THEN TERM2=1.0/(1.0 - 0.0060*XSKEW + 0.27*XSKEW**2 - 1 0.0069*XSKEW**3) ELSE TERM2=1.0 ENDIF XKURT=XKURT - 3.0 IF(XKURT.GT.0.0 .AND. XKURT.LT.6.0)THEN TERM3=1.0 - 0.2*(1.0 - EXP(-0.7*XKURT)) ELSE TERM3=1.0 ENDIF DCLWID=DBLE(TERM1*TERM2*TERM3) ENDIF ELSEIF(IHSTCW.EQ.'IQ ')THEN CALL LOWQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XLOWQ,IBUGG3,IERROR) CALL UPPQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XUPPQ,IBUGG3,IERROR) XIQ=XUPPQ - XLOWQ IF(CLWID.EQ.CPUMIN)DCLWID=2.603*XIQ/(REAL(N)**(1./3.)) ELSE IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD ENDIF C IF(XSTART.EQ.CPUMIN)THEN CCCCC DXSTAR=XMEAN-6.0*XSD ABIN=ABS((XMEAN-XMIN)/REAL(DCLWID)) IBINL=INT(ABIN+1.0) DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID ELSE ABIN=ABS((XMEAN-XSTART)/REAL(DCLWID)) IBINL=INT(ABIN+1.0) DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID ENDIF IF(XSTOP.EQ.CPUMAX)THEN CCCCCC DXSTOP=XMEAN+6.0*XSD ABIN=ABS((XMAX-XMEAN)/REAL(DCLWID)) IBINU=INT(ABIN+1.0) DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID ELSE ABIN=ABS((XSTOP-XMEAN)/REAL(DCLWID)) IBINU=INT(ABIN+1.0) DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID ENDIF NBIN=IBINL + IBINU ELSE ABIN=(XMEAN-XSTART)/REAL(DCLWID) IBINL=INT(ABIN+1.0) DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID C ABIN=(XSTOP-XMEAN)/REAL(DCLWID) IBINU=INT(ABIN+1.0) DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID C NBIN=IBINL + IBINU ENDIF C IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,170) 170 FORMAT('***** MIDDLE OF DPBINA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,171)XMEAN,XSD,XMIN,XMAX 171 FORMAT('XMEAN,XSD,XMIN,XMAX = ',4G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,172)DCLWID,DXSTAR,DXSTOP 172 FORMAT('DCLWID,DXSTAR,DXSTOP = ',3G15.7) CALL DPWRST('XXX','BUG ') ENDIF C C *********************************************** C ** STEP 3-- ** C ** IMPLEMENT BIN1 ALGORITHM FROM PAGE 117. ** C *********************************************** C DELTA=DCLWID/DBLE(M) NBIN=INT((DXSTOP-DXSTAR)/DELTA + 0.5D0) DNBIN=DBLE(NBIN) DO410I=1,NBIN Y2(I)=0.0 410 CONTINUE C DO420I=1,N DX=DBLE(Y(I)) DK=((DX - DXSTAR)/DELTA) + 1.0D0 IK=INT(DK) IF(IK.GE.1 .AND. IK.LE.NBIN)Y2(IK)=Y2(IK)+1.0 420 CONTINUE C IF(IRELAT.EQ.'OFF')THEN DO430I=1,NBIN X2(I)=REAL(DXSTAR + (DBLE(I)-0.5D0)*DELTA) 430 CONTINUE N2=NBIN GOTO9000 ENDIF C C *********************************************** C ** STEP 4-- ** C ** IMPLEMENT ASH1 ALGORITHM FROM PAGE 118. ** C *********************************************** C IF(IASHWT.EQ.'BIWE')THEN ISTRT=1-M ISTOP=M-1 ASUM=0.0 DO510I=ISTRT,ISTOP T=REAL(I)/REAL(M) IF(-1.0.LE.T .AND. T.LE.1.0)THEN ASUM=ASUM + (15./16.)*(1.0-T**2)**2 ENDIF 510 CONTINUE C DO520I=ISTRT,ISTOP T=REAL(I)/REAL(M) IF(-1.0.LE.T .AND. T.LE.1.0)THEN TERM1=(15./16.)*(1.0-T**2)**2 ELSE TERM1=0.0 ENDIF WTM(I+M+1)=REAL(M)*TERM1/ASUM 520 CONTINUE ELSE ISTRT=1-M ISTOP=M-1 DO560I=ISTRT,ISTOP WTM(I+M)=1.0 - ABS(REAL(I))/REAL(M) 560 CONTINUE ENDIF C DH=DBLE(M)*DELTA DO610I=1,NBIN XTEMP1(I)=0.0 610 CONTINUE C DO620K=1,NBIN IF(Y2(K).GT.0.0)THEN IFRST=MAX(1,K-M+1) ILAST=MIN(NBIN,K+M-1) IF(ILAST.GE.IFRST)THEN DO630I=IFRST,ILAST XTEMP1(I)= XTEMP1(I) + Y2(K)*WTM(I-K+M) 630 CONTINUE ENDIF ENDIF 620 CONTINUE C DN=DBLE(N) DO680I=1,NBIN Y2(I)=XTEMP1(I)/(REAL(DH*DN)) X2(I)=REAL(DXSTAR + (DBLE(I)-0.5D0)*DELTA) 680 CONTINUE N2=NBIN C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBINA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IRELAT,IERROR,N2 9012 FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,X2(I),Y2(I) 9016 FORMAT('I,X2(I),Y2(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9025I=1,M WRITE(ICOUT,9026)I,WTM(I) 9026 FORMAT('I,WTM(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 9025 CONTINUE ENDIF C RETURN END SUBROUTINE DPBINI(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG, 1Y2,X2,N2,IBUGG3,IERROR) C C PURPOSE--BIN A VARIABLE Y INTO X2 Y2. C THAT IS CONVERT RAW DATA TO FREQUENCY DATA. C BINNING IS TO COUNTS (AND NOT TO RELATIVE) C FREQUENCY. C THIS IS A SPECIFAL FORM OF BINNING WHERE THE C BINS ARE THE INTEGERS FROM THE MINIMUM TO THE MAXIMUM C VALUE. THIS ROUTINE IS USED TO BIN FOR GOODNESS OF C FIT TESTS FOR DISCRETE DISTRIBUTIONS. 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--98/11 C ORIGINAL VERSION--NOVEMBER 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IRELAT CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 IWRIT2 CHARACTER*4 IRHSTG C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- DOUBLE PRECISION DCLWID DOUBLE PRECISION DXSTAR DOUBLE PRECISION DXSTOP DOUBLE PRECISION DCLMNJ DOUBLE PRECISION DCLMDJ DOUBLE PRECISION DCLMXJ DOUBLE PRECISION DJ DOUBLE PRECISION DXI DOUBLE PRECISION DABSDE DOUBLE PRECISION DTOTWI C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION Y2(*) DIMENSION X2(*) 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='DPBI' ISUBN2='NI ' C IERROR='NO' C K=(-999) DCLMDJ=(-999.0D0) C KP3=0 C AN3=0.0 DENOM=0.0 C DCLWID=CLWID DXSTAR=XSTART DXSTOP=XSTOP 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 DPBINI--') 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 DPBINI--') 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=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPBINI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL INPUT AXIS ELEMENTS') 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 DPBINI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP 72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y(I) 74 FORMAT('I, Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ********************************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** DETERMINE CLASS WIDTH, ** C ** START VALUE, STOP VALUE, ** C ** AND NUMBER OF CLASSES. ** C ********************************************** C 110 CONTINUE IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND. 1XSTOP.NE.CPUMAX)GOTO119 IWRIT2='OFF' CALL MINIM(Y,N,IWRIT2,YMIN,IBUGG3,IERROR) CALL MAXIM(Y,N,IWRIT2,YMAX,IBUGG3,IERROR) IF(CLWID.EQ.CPUMIN)DCLWID=1.0 IF(XSTART.EQ.CPUMIN)DXSTAR=REAL(INT(YMIN+0.5))-0.5 IF(XSTOP.EQ.CPUMAX)DXSTOP=REAL(INT(YMAX+0.5))+0.5 119 CONTINUE C 180 CONTINUE DO181I=1,N X2(I)=0.0 Y2(I)=0.0 181 CONTINUE DTOTWI=DXSTOP-DXSTAR ANUMCL=DTOTWI/DCLWID NUMCLA=ANUMCL+1.0 C J=NUMCLA-1 DJ=J DCLMXJ=DXSTAR+DJ*DCLWID DABSDE=DABS(DCLMXJ-DXSTOP) IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1 C C ******************************************************* C ** STEP 3-- ** C ** DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS ** C ******************************************************* C 410 CONTINUE DO420I=1,N DXI=Y(I) DO430J=1,NUMCLA J2=J DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440 430 CONTINUE GOTO420 440 CONTINUE Y2(J2)=Y2(J2)+1.0 420 CONTINUE C C FOR THIS RAW DATA CASE, C TREAT THE SPECIAL CASE OF EQUALITY C WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS C J=NUMCLA DO450I=1,N DJ=J DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP DXI=Y(I) IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0 450 CONTINUE C 590 CONTINUE IF(IBUGG3.EQ.'OFF')GOTO595 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,591) 591 FORMAT('***** IN THE MIDDLE OF DPBINI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA 592 FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ', 14D11.4,F10.0,I8) CALL DPWRST('XXX','BUG ') DO593J=1,NUMCLA DJ=J DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID DCLMXJ=DXSTAR+DJ*DCLWID IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP FJ=Y2(J) WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ 594 FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7) CALL DPWRST('XXX','BUG ') 593 CONTINUE 595 CONTINUE C 1100 CONTINUE SUM=0.0 DO1110J=1,NUMCLA FJ=Y2(J) SUM=SUM+FJ 1110 CONTINUE AN3=SUM C DENOM=1.0 C IF(IRELAT.EQ.'ON')THEN IF(IRHSTG.EQ.'PERC')THEN DENOM=AN3 ELSE DENOM=AN3*DCLWID ENDIF ENDIF C DO1120J=1,NUMCLA K=J DJ=J DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID X2(K)=REAL(DCLMDJ) FJ=Y2(K) Y2(K)=FJ/DENOM 1120 CONTINUE N2=K C DO1130J=NUMCLA,1,-1 IF(Y2(J).GT.0.0)THEN N2=J GOTO1139 ENDIF 1130 CONTINUE N2=1 1139 CONTINUE C DO1140J=1,N2 IF(Y2(J).GT.0.0)THEN IFRST=J GOTO1149 ENDIF 1140 CONTINUE IFRST=1 1149 CONTINUE K=0 DO1150J=IFRST,N2 K=K+1 X2(K)=X2(J) Y2(K)=Y2(J) 1150 CONTINUE C IF(N2.LT.NUMCLA)THEN DO1160I=N2+1,NUMCLA Y2(I)=0.0 X2(I)=0.0 1160 CONTINUE ENDIF N2=K 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 DPBINI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IRELAT,IERROR,N2 9012 FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)AN3,DENOM 9013 FORMAT('AN3,DENOM = ',E15.8,E15.8) CALL DPWRST('XXX','BUG ') DO9015I=1,N2 WRITE(ICOUT,9016)I,X2(I),Y2(I) 9016 FORMAT('I,X2(I),Y2(I) = ',I8,E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP 9017 FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBKCL(IHARG,NUMARG,IDBKCO,IBKPCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D BACKPLANE. C THE COLOR FOR THE BACKPLANE WILL BE PLACED C IN THE CHARACTER VARIABLE IBKPCO. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBKCO C OUTPUT ARGUMENTS--IBKPCO C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBKCO CHARACTER*4 IBKPCO 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IBKPCO=IDBKCO GOTO1180 C 1160 CONTINUE IBKPCO=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBKPCO 1181 FORMAT('THE (3-D) BACKPLANE COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBKGC(IHARG,NUMARG,IDBKGC,IBKPGC,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D BACKPLANE GRID. C THE COLOR FOR THE BACKPLANE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IBKPGC. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBKGC C OUTPUT ARGUMENTS--IBKPGC C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBKGC CHARACTER*4 IBKPGC 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(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IBKPGC=IDBKGC GOTO1180 C 1160 CONTINUE IBKPGC=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBKPGC 1181 FORMAT('THE (3-D) BACKPLANE GRID COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBKGP(IHARG,NUMARG,IDBKGP,IBKPGP,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR THE 3-D BACKPLANE GRID. C THE PATTERN FOR THE BACKPLANE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IBKPGP. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBKGP C OUTPUT ARGUMENTS--IBKPGP C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBKGP CHARACTER*4 IBKPGP 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(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1160 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1175 C 1150 CONTINUE IBKPGP='SOLI' GOTO1180 C 1160 CONTINUE IBKPGP='BLAN' GOTO1180 C 1170 CONTINUE IBKPGP=IDBKGP GOTO1180 C 1175 CONTINUE IBKPGP=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBKPGP 1181 FORMAT('THE (3-D) BACKPLANE GRID PATTERN ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBKGR(IHARG,NUMARG,IDBKGR,IBKPGR,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D BACKPLANE GRID SWITCH IBKPGR. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDBKGR C OUTPUT ARGUMENTS--IBKPGR ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBKGR CHARACTER*4 IBKPGR 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1199 C 1150 CONTINUE IBKPGR='ON' GOTO1180 C 1160 CONTINUE IBKPGR='OFF' GOTO1180 C 1170 CONTINUE IBKPGR=IDBKGR GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBKPGR 1181 FORMAT('THE (3-D) BACKPLANE GRID SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBKP(IHARG,NUMARG,IBKPSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D BACKPLANE SWITCH IBKPSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IBKPSW ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IBKPSW 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(NUMARG.EQ.0)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 GOTO1199 C 1150 CONTINUE IBKPSW='ON' GOTO1180 C 1160 CONTINUE IBKPSW='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBKPSW 1181 FORMAT('THE (3-D) BACKPLANE SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST CCCCC1BARHEF,BARWEF, 1BARHEF,BARWEF,MAXNXT, 1ISEED, 1ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE A BLOCK PLOT C C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 C PHONE--301-975-2855 C ORIGINAL VERSION--MAY 1992. C UPDATED --MARCH 1995. MAD AND AAD PLOTS C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C SYNTAX FOR COMMAND (MUST HAVE 3 OR MORE ARGUMENTS)-- C BLOCK PLOT Y CHAR-VAR. C EXAMPLES-- C BLOCK PLOT Y BOY MAT C BLOCK PLOT Y X1 X2 MAD AND AAD PLOTS C BLOCK PLOT Y CONC QUENCH OVEN C BLOCK PLOT Y X2 X3 X1 C BLOCK PLOT Y X2 X3 X4 X5 X6 X7 X1 C NOTE--MAX NUMBER OF NUISANCE FACTORS = 20 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 1992. C UPDATED --MARCH 2002. ADD ROBUSTNESS PLOT AS C SYNONYM FOR BLOCK PLOT C UPDATED --AUGUST 2002. USE "CMPSTA" TO COMPUTE C STATISTICS, EXPAND LIST OF C SUPPORTED STATISTICS C UPDATED --APRIL 2003. ADD SN AND QN (ROBUST SCALE C STATISTICS) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHVERT CHARACTER*4 IHVER2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHSUB CHARACTER*4 IHSUB2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) DIMENSION TAG(MAXOBV) DIMENSION TEMP(MAXOBV) C DIMENSION DIST(1000) DIMENSION ITABLE(21) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),X1(1)) EQUIVALENCE (GARBAG(IGARB3),TAG(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP(1)) 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='DPBL' ISUBN2='OC ' 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 BLOCK PLOT 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 DPBLOC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICASPL,IAND1,IAND2,ISUBRO 52 FORMAT('ICASPL,IAND1,IAND2,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)BARHEF,BARWEF 54 FORMAT('BARHEF,BARWEF = ',2E15.7) 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 CCCCC MORE WORK (FOR OTHER STAT) NEEDS TO BE DONE HERE... C ICASPL='RAW ' IFOUND='YES' IF(ICOM.EQ.'BLOC'.OR.ICOM.EQ.'ROBU')THEN ICASPL='RAW ' CALL ADJUST(1,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'NUMB'.OR.ICOM.EQ.'SIZE'.OR.ICOM.EQ.'COUN')THEN ICASPL='NUMB' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'AAD ')THEN ICASPL='AAD ' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')THEN ICASPL='AAD ' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MEAN' .OR. ICOM.EQ.'AVER')THEN ICASPL='MEAN' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MAD ')THEN ICASPL='MAD ' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MEDI'.AND.IHARG(1).EQ.'ABSO'.AND. 1IHARG(2).EQ.'DEVI')THEN ICASPL='MAD ' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MEDI')THEN ICASPL='MEDI' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MIDR')THEN ICASPL='MIDR' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MIDM')THEN ICASPL='MIDM' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1 IHARG(2).EQ.'OF'.AND.IHARG(3).EQ.'THE'.AND. 1 IHARG(4).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(6,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1 IHARG(2).EQ.'OF'.AND.IHARG(3).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI'.AND. 1 IHARG(2).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SD'.AND.IHARG(1).EQ.'OF'.AND. 1 IHARG(2).EQ.'THE'.AND.IHARG(3).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SD'.AND.IHARG(1).EQ.'OF'.AND. 1 IHARG(2).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SD'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='SDME' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'DEVI')THEN ICASPL='SD ' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SD ')THEN ICASPL='SD ' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF'.AND. 1 IHARG(2).EQ.'THE'.AND.IHARG(3).EQ.'MEAN')THEN ICASPL='VAME' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'OF'.AND. 1 IHARG(2).EQ.'MEAN')THEN ICASPL='VAME' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'VARI'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='VAME' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'VARI')THEN ICASPL='VARI' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'SD')THEN ICASPL='RESD' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'STAN'.AND. 1 IHARG(2).EQ.'DEVI')THEN ICASPL='RESD' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'VARI')THEN ICASPL='REVA' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'OF'.AND. 1 IHARG(2).EQ.'VARI')THEN ICASPL='CVAR' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'COEF'.AND.IHARG(1).EQ.'VARI')THEN ICASPL='CVAR' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'RANG')THEN ICASPL='RANG' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MINI')THEN ICASPL='MINI' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'MAXI')THEN ICASPL='MAXI' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'EXTR')THEN ICASPL='EXTR' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'QUAR')THEN ICASPL='LOWQ' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'QUAR')THEN ICASPL='UPPQ' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'LOWE'.AND.IHARG(1).EQ.'HING')THEN ICASPL='LOWH' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'UPPE'.AND.IHARG(1).EQ.'HING')THEN ICASPL='UPPH' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'FIRS'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='1DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SECO'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='2DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'THIR'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='3DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'FOUR'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='4DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'FIFT'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='5DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SIXT'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='6DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SEVE'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='7DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'EIGH'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='8DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'NINT'.AND.IHARG(1).EQ.'DECI')THEN ICASPL='9DEC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SKEW')THEN ICASPL='SKEW' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'THIR'.AND. 1 IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')THEN ICASPL='SKEW' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'KURT')THEN ICASPL='KURT' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'STAN'.AND.IHARG(1).EQ.'FOUR'.AND. 1 IHARG(2).EQ.'CENT'.AND.IHARG(3).EQ.'MOME')THEN ICASPL='KURT' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'CORR')THEN ICASPL='AUCR' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'AUTO'.AND.ICOM2.EQ.'COVA')THEN ICASPL='AUCV' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SN '.AND.IHARG(1).EQ.'SCAL')THEN ICASPL='SNSC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'QN '.AND.IHARG(1).EQ.'SCAL')THEN ICASPL='QNSC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SN0')THEN ICASPL='SN0' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SN+')THEN ICASPL='SN+' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SN-')THEN ICASPL='SN-' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'SN00')THEN ICASPL='SN00' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF((ICOM.EQ.'SIN'.OR.ICOM.EQ.'SINE').AND. 1 IHARG(1).EQ.'FREQ')THEN ICASPL='SIFR' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF((ICOM.EQ.'SIN'.OR.ICOM.EQ.'SINE').AND. 1 IHARG(1).EQ.'AMPL')THEN ICASPL='SIAM' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CP')THEN ICASPL='CP' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CPK')THEN ICASPL='CPK' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CNPK')THEN ICASPL='CNPK' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CPM')THEN ICASPL='CPM' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CPL')THEN ICASPL='CPL' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CPU')THEN ICASPL='CPU' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'CC')THEN ICASPL='CC' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'DEFE')THEN ICASPL='PEDE' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'EXPE'.AND.IHARG(1).EQ.'LOSS')THEN ICASPL='EXLO' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'NORM'.AND.IHARG(1).EQ.'PPCC')THEN ICASPL='NOPP' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'PERC'.AND.IHARG(1).EQ.'BEND'.AND. 1 IHARG(2).EQ.'MIDV')THEN ICASPL='PBMV' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'PERC')THEN ICASPL='PERC' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'QUAN'.AND.IHARG(1).EQ.'STAN'.AND. 1 IHARG(2).EQ.'ERRO')THEN ICASPL='QUSE' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'QUAN')THEN ICASPL='QUAN' CALL ADJUST(2,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN'.AND. 1 IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')THEN ICASPL='TMSE' CALL ADJUST(5,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='TRIM' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='WINM' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'VARI')THEN ICASPL='WIVA' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'SD')THEN ICASPL='WISD' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'WINS'.AND.IHARG(1).EQ.'STAN'.AND. 1 IHARG(2).EQ.'DEVI')THEN ICASPL='WISD' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'GEOM'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='GEME' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'GEOM'.AND.IHARG(1).EQ.'SD')THEN ICASPL='GESD' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'GEOM'.AND.IHARG(1).EQ.'STAN'.AND. 1 IHARG(2).EQ.'DEVI')THEN ICASPL='GESD' CALL ADJUST(4,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'HARM'.AND.IHARG(1).EQ.'MEAN')THEN ICASPL='HAME' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'INTE'.AND.IHARG(1).EQ.'RANG')THEN ICASPL='IQRA' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'LOCA')THEN ICASPL='BILO' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'SCAL')THEN ICASPL='BISC' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'BIWE'.AND.IHARG(1).EQ.'MIDV')THEN ICASPL='BIMV' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IF(ICOM.EQ.'HODG'.AND.IHARG(1).EQ.'LEHM')THEN ICASPL='HLEH' CALL ADJUST(3,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) ELSE IFOUND='NO' GOTO9000 ENDIF C C *********************************************************** C ** STEP 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=22 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE VERT. AXIS VARIABLE)** C ******************************************** C ISTEPN='2' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHVERT=IHARG(1) IHVER2=IHARG2(1) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVERT,IHVER2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLV=IVALUE(ILOCV) NVERT=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHVERT,ICOLV,NVERT 211 FORMAT('IHVERT,ICOLV,NVERT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NVERT) ** C ** FOR THE VERT. AXIS VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='3' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NVERT.GE.MINN2)GOTO390 IBRANCH=310 CALL MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH, 1NUMARG,NUMV2,IHVERT,NVERT,IHHOR,NHOR) IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 4-- ** 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='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LT.1)THEN IBRANCH=400 CALL MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH, 1 NUMARG,NUMV2,IHVERT,NVERT,IHHOR,NHOR) IERROR='YES' GOTO9000 ENDIF C DO400J=1,NUMARG IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')THEN ICASEQ='SUBS' ILOCQ=J GOTO490 ENDIF IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')THEN ICASEQ='EXCE' ILOCQ=J GOTO490 ENDIF IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')THEN ICASEQ='FOR' ILOCQ=J GOTO490 ENDIF 400 CONTINUE ICASEQ='FULL' ILOCQ=NUMARG+1 GOTO490 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C **************************************************** C ** STEP 5-- ** C ** THE TOTAL NUMBER OF VARIABLES (INCLUDING Y) ** C ** MUST BE AT LEAST 3, ** C ** AND MAY BE OPTIONALLY MORE. ** C ** THESE OTHER VALUES ** C ** NEED NOT HAVE BEEN PREVIOUSLY ** C ** SORTED OR HAVE COMMON VALUES ADJACENT. ** C ** CHECK THE VALIDITY OF ALL REMAINING VARIABLES ** C ** (NUISANCE + PRIMARY) ** C **************************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.LE.2)THEN IBRANCH=510 CALL MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH, 1 NUMARG,NUMV2,IHVERT,NVERT,IHHOR,NHOR) IERROR='YES' GOTO9000 ENDIF C DO540K=2,NUMV2 IHHOR=IHARG(K) IHHOR2=IHARG2(K) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHHOR,IHHOR2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCH,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLH=IVALUE(ILOCH) ITABLE(K)=ICOLH NHOR=IN(ILOCH) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,541)K,IHHOR,ICOLH,NHOR 541 FORMAT('K,IHHOR,ICOLH,NHOR = ',I8,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NHOR.NE.NVERT)THEN IBRANCH=540 CALL MEBLOC(ISUBN1,ISUBN2,IBRANCH,MINN2,IANS,IWIDTH, 1 NUMARG,NUMV2,IHVERT,NVERT,IHHOR,NHOR) IERROR='YES' GOTO9000 ENDIF 540 CONTINUE C IHSUB=IHARG(NUMV2) IHSUB2=IHARG2(NUMV2) ICOLT=IVALUE(ILOCH) C C ************************************************* C ** STEP 6-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** (BASED ON THE QUALIFIER) ** C ** THEN FORM THE VERT. AXIS VARIABLE ** C ** AND THE TAG VARIABLE ** C ************************************************* C ISTEPN='6' IF(IBUGG2.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,NVERT ISUB(I)=1 615 CONTINUE NQ=NVERT GOTO650 C 620 CONTINUE NIOLD=NVERT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NVERT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C C *****EXTRACT THE VERTICAL AXIS VARIABLE***** C 650 CONTINUE IMAX=NVERT IF(NQ.LT.NVERT)IMAX=NQ J=0 DO660I=1,IMAX IF(ISUB(I).EQ.1)THEN J=J+1 IJ=MAXN*(ICOLV-1)+I IF(ICOLV.LE.MAXCOL)Y1(J)=V(IJ) IF(ICOLV.EQ.MAXCP1)Y1(J)=PRED(I) IF(ICOLV.EQ.MAXCP2)Y1(J)=RES(I) IF(ICOLV.EQ.MAXCP3)Y1(J)=YPLOT(I) IF(ICOLV.EQ.MAXCP4)Y1(J)=XPLOT(I) IF(ICOLV.EQ.MAXCP5)Y1(J)=X2PLOT(I) IF(ICOLV.EQ.MAXCP6)Y1(J)=TAGPLO(I) ENDIF 660 CONTINUE NLOCAL=J C C *****EXTRACT THE TAG VARIABLE***** C J=0 DO670I=1,IMAX IF(ISUB(I).EQ.1)THEN J=J+1 IJ=MAXN*(ICOLT-1)+I IF(ICOLT.LE.MAXCOL)TAG(J)=V(IJ) IF(ICOLT.EQ.MAXCP1)TAG(J)=PRED(I) IF(ICOLT.EQ.MAXCP2)TAG(J)=RES(I) IF(ICOLT.EQ.MAXCP3)TAG(J)=YPLOT(I) IF(ICOLT.EQ.MAXCP4)TAG(J)=XPLOT(I) IF(ICOLT.EQ.MAXCP5)TAG(J)=X2PLOT(I) IF(ICOLT.EQ.MAXCP6)TAG(J)=TAGPLO(I) ENDIF 670 CONTINUE C C *****FORM THE HORIZONTAL AXIS VARIABLE***** C *****BY COMBINING ALL NUISANCE AXIS VARIABLES***** C SHRINK=0.20 NUMV2M=NUMV2-1 DO680K=2,NUMV2M C IF(K.GE.3)THEN CALL DISTIN(X1,NLOCAL,'OFF ',DIST,NDIST,IBUGG3,IERROR) CALL SORT(DIST,NDIST,DIST) DELMIN=CPUMAX NDISTM=NDIST-1 DO682I=1,NDISTM IP1=I+1 DEL=DIST(IP1)-DIST(I) IF(DEL.LT.DELMIN)DELMIN=DEL 682 CONTINUE ENDIF C ICOLH=ITABLE(K) J=0 DO684I=1,IMAX IF(ISUB(I).EQ.1)THEN J=J+1 IJ=MAXN*(ICOLH-1)+I IF(ICOLH.LE.MAXCOL)TEMP(J)=V(IJ) IF(ICOLH.EQ.MAXCP1)TEMP(J)=PRED(I) IF(ICOLH.EQ.MAXCP2)TEMP(J)=RES(I) IF(ICOLH.EQ.MAXCP3)TEMP(J)=YPLOT(I) IF(ICOLH.EQ.MAXCP4)TEMP(J)=XPLOT(I) IF(ICOLH.EQ.MAXCP5)TEMP(J)=X2PLOT(I) IF(ICOLH.EQ.MAXCP6)TEMP(J)=TAGPLO(I) ENDIF 684 CONTINUE C IF(K.EQ.2)THEN DO686I=1,NLOCAL X1(I)=TEMP(I) 686 CONTINUE ENDIF C IF(K.GE.3)THEN CALL MINIM(TEMP,NLOCAL,'OFF ',XMIN,IBUGG3,IERROR) CALL MAXIM(TEMP,NLOCAL,'OFF ',XMAX,IBUGG3,IERROR) DENOM=XMAX-XMIN IF(IBUGG2.EQ.'ON')WRITE(ICOUT,687)K,DENOM,DELMIN,SHRINK 687 FORMAT('K,DENOM,DELMIN,SHRINK = ',I8,3E15.7) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') DO688I=1,NLOCAL TEMP(I)=2.0*((TEMP(I)-XMIN)/DENOM)-1.0 TEMP(I)=TEMP(I)*DELMIN TEMP(I)=TEMP(I)*SHRINK X1(I)=X1(I)+TEMP(I) 688 CONTINUE ENDIF 680 CONTINUE C C ************************************************************* C ** STEP 8-- ** C ** COMPUTE THE APPROPRIATE BLOCK PLOT 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 ** FORM THE PLOTTED VALUE AND THE SURROUNDING BAR. C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). ** C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). ** C ************************************************************* C ISTEPN='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPBLO2(Y1,X1,TAG,NLOCAL,ICASPL, 1TEMP, CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST. CCCCC1BARHEF,BARWEF, 1BARHEF,BARWEF,MAXNXT, 1ISEED, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR) C C ************************************************** C ** STEP 9-- ** C ** REDEFINE ICASPL FOR USE ** C ** IN THE PLOTGE SUBROUTINE ** C ************************************************** C ICASPL='BLPL' 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 DPBLOC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,ISUBRO,IERROR 9012 FORMAT('IFOUND,ISUBRO,IERROR = ',A4,2X,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)BARHEF,BARWEF 9014 FORMAT('BARHEF,BARWEF = ',2E15.7) 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 DPBLO2(Y,X,TAG,N,ICASPL, 1DIST, CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST 1BARHEF,BARWEF,MAXNXT, 1ISEED, 1Y3,X3,D3,N3,NPLOTV,IBUGG3,ISUBRO,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A BLOCK PLOT C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 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 ORIGINAL VERSION--MAY 1992. C UPDATED --MARCH 1995. MAXNXT TO ARGUMENT LIST C UPDATED --JUNE 1995. FIX VERTICES JUNK 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 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION TAG(*) C DIMENSION Y3(*) DIMENSION X3(*) DIMENSION D3(*) C DIMENSION DIST(*) C DIMENSION Y2(1000) DIMENSION X2(1000) DIMENSION TAG2(1000) C DIMENSION DTAG(1000) DIMENSION DTAG2(1000) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C CHARACTER*4 IFOUNN C EXTERNAL RANGE 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='DPBL' ISUBN2='O2 ' C XWIDTH=0.0 XWIDT2=0.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 DPBLO2--') 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 DPBLO2--') 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 IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BLO2')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPBLO2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ISUBRO 53 FORMAT('ICASPL,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)BARHEF,BARWEF 54 FORMAT('BARHEF,BARWEF = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N 71 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO75I=1,N WRITE(ICOUT,76)I,Y(I),X(I),TAG(I) 76 FORMAT('I, Y(I), X(I),TAG(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 11-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (THE HOR. AXIS VARIABLE). ** C ******************************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DISTIN(X,N,'OFF ',DIST,NDIST,IBUGG3,IERROR) CALL SORT(DIST,NDIST,DIST) C C ************************************************** C ** STEP 12-- ** C ** IF NO STATISTIC IS CALLED FOR, ** C ** CARRY OVER THE RAW DATA INTO Y2,X2,TAG2,N2. ** C ** IF A STATISTIC IS CALLED FOR, ** C ** COMPUTE THE STATISTICS AND COPY IT INTO Y2,X**2,TAG2,N2. C ************************************************** C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPBLO3(Y,X,TAG,N,ICASPL,DIST,NDIST, CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST. 1MAXNXT, 1ISEED, 1Y2,X2,TAG2,N2,IBUGG3,ISUBRO,IERROR) C C *************************************** C ** STEP 13-- ** C ** COMPUTE 'COIN' PROBABILITY ** C ** FOR OBSERVED PATTERN. ** C ** UPDATE INTERNAL DATAPLOT ARRAYS ** C *************************************** C CALL DISTIN(TAG2,N2,'OFF ',DTAG2,NDTAG2,IBUGG3,IERROR) FACES=NDTAG2 PROB=1.0/FACES C CALL HEADS(Y2,X2,TAG2,N2, 1DIST,DTAG, 1HEADS2,NTRIAL,AVEDEL,SDAVED,IBUGG3,ISUBRO,IERROR) HEADS3=HEADS2-1.0 TRIALS=NTRIAL C CALL BINCDF(HEADS3,PROB,NTRIAL,CDF) TAILPR=1.0-CDF C CALL UPDATP('HEAD','S ',HEADS2,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CALL UPDATP('TRIA','LS ',TRIALS,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CALL UPDATP('FACE','S ',FACES,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CALL UPDATP('TAIL','PROB',TAILPR,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CALL UPDATP('AVED','EL ',AVEDEL,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C CALL UPDATP('SDAV','EDEL',SDAVED,'CHAD','NO ', 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ***************************************************** C ** STEP 20--FORM PLOT COORDINATES ** C ** BASED ON THE TAG VARIABLE (VAR.3). ** C ** THIS WILL BE A STRAIGHT COPY. ** C ** THIS WILL YIELD THE CHARACTERS PORTION** C ** OF THE FINAL PLOT. ** C ***************************************************** C DO1100I=1,N2 Y3(I)=Y2(I) X3(I)=X2(I) D3(I)=TAG2(I) 1100 CONTINUE J=N2 C TAGMAX=CPUMIN DO1200I=1,N2 IF(TAG2(I).GT.TAGMAX)TAGMAX=TAG2(I) 1200 CONTINUE CCCCC THE FOLLOWING LINE WAS CORRECTED JUNE 1995 CCCCC DUE TO EXTRANEOUS CHARACTERS ON THE VERTICES JUNE 1995 CCCCC OF CHARLES HAGWOOD BLOCK PLOTS JUNE 1995 CCCCC JD=TAGMAX+0.5 JD=100 C C ***************************************************** C ** STEP 21--FORM PLOT COORDINATES ** C ** BASED ON THE HOR. AXIS VAR. (VAR. 2) ** C ** THIS WILL YIELD THE BOXES PORTION ** C ** OF THE FINAL PLOT. ** C ***************************************************** C C *********************************** C ** STEP 23-- ** C ** COMPUTE MINIMUM CLASS WIDTH ** C *********************************** C ISTEPN='23' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NDIST.EQ.1)THEN XWIDTH=0.10*DIST(1) ENDIF C IF(NDIST.GE.2)THEN XWIDTH=CPUMAX IMAX=NDIST-1 DO2300I=1,IMAX IP1=I+1 XWIDT2=DIST(IP1)-DIST(I) IF(XWIDT2.LT.XWIDTH)XWIDTH=XWIDT2 2300 CONTINUE ENDIF BARHAW=XWIDTH/3.0 BARHAW=BARWEF*BARHAW C C COMPUTE RANGE OF VERTICAL AXIS DATA C CALL RANGE(Y2,N2,'OFF ',Y2RANG,IBUGG3,IERROR) Y2GAP=0.04*Y2RANG Y2GAP=BARHEF*Y2GAP C C ************************************************** C ** STEP 24-- ** C ** LOOP THROUGH EACH DISTINCT HOR. AXIS VALUE. ** C ** FOR A GIVEN HORIZONTAL AXIS VALUE-- ** C ** FIND THE VERTICAL AXIS MINIMUM; ** C ** FIND THE VERTICAL AXIS MAXIMUM; ** C ** FORM PLOT COORDINATES OF THE BOX. ** C ************************************************** C ISTEPN='24' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2400ISET=1,NDIST C Y2MIN=CPUMAX Y2MAX=CPUMIN DO2410I=1,N2 IF(X2(I).EQ.DIST(ISET))THEN IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I) IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I) ENDIF 2410 CONTINUE Y2MING=Y2MIN-Y2GAP Y2MAXG=Y2MAX+Y2GAP C JD=JD+1 J=J+1 X3(J)=DIST(ISET)-BARHAW Y3(J)=Y2MING D3(J)=JD J=J+1 X3(J)=DIST(ISET)+BARHAW Y3(J)=Y2MING D3(J)=JD C JD=JD+1 J=J+1 X3(J)=DIST(ISET)+BARHAW Y3(J)=Y2MING D3(J)=JD J=J+1 X3(J)=DIST(ISET)+BARHAW Y3(J)=Y2MAXG D3(J)=JD C JD=JD+1 J=J+1 X3(J)=DIST(ISET)+BARHAW Y3(J)=Y2MAXG D3(J)=JD J=J+1 X3(J)=DIST(ISET)-BARHAW Y3(J)=Y2MAXG D3(J)=JD C JD=JD+1 J=J+1 X3(J)=DIST(ISET)-BARHAW Y3(J)=Y2MAXG D3(J)=JD J=J+1 X3(J)=DIST(ISET)-BARHAW Y3(J)=Y2MING D3(J)=JD C 2400 CONTINUE N3=J NPLOTV=3 GOTO9000 C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BLO2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBLO2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,ISUBRO,BARHEF,BARWEF 9012 FORMAT('ICASPL,ISUBRO,BARHEF,BARWEF = ',A4,2X,A4,2X,2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NDIST,N2,N3,IERROR 9013 FORMAT('N,NDIST,N2,N3,IERROR = ',4I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XWIDT2,XWIDTH,BARHAW 9015 FORMAT('XWIDT2,XWIDTH,BARHAW = ',3E15.7) CALL DPWRST('XXX','BUG ') C DO9021I=1,N2 WRITE(ICOUT,9022)I,Y2(I),X2(I),TAG2(I) 9022 FORMAT('I,Y2(I),X2(I),TAG2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9021 CONTINUE C WRITE(ICOUT,9031)Y2RANG,Y2GAP 9031 FORMAT('Y2RANG,Y2GAP = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)Y2MIN,Y2MAX,Y2MING,Y2MAXG 9032 FORMAT('Y2MIN,Y2MAX,Y2MING,Y2MAXG = ',4E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,N3 WRITE(ICOUT,9036)I,Y3(I),X3(I),D3(I) 9036 FORMAT('I,Y3(I),X3(I),D3(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBLO3(Y,X,TAG,N,ICASPL,DIST,NDIST, CCCCC MARCH 1995. ADD MAXNXT TO ARGUMENT LIST. 1MAXNXT, 1ISEED, 1Y2,X2,TAG2,N2,IBUGG3,ISUBRO,IERROR) C C PURPOSE--IF NO STATISTIC IS CALLED FOR, C CARRY OVER THE RAW DATA INTO Y2,X2,TAG2,N2. C IF A STATISTIC IS CALLED FOR, C COMPUTE THE STATISTICS AND COPY IT INTO Y2,X2,TAG2,N2. C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 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 ORIGINAL VERSION--JUNE 1992. C UPDATED --AUGUST 1993. ADD SOME DECLARATIONS C UPDATED --DECEMBER 1993. LINFIT ARGS + GARBAGE VECTORS C UPDATED --DECEMBER 1993. LINFIT ARGS: PROTECT RESSD/DF C UPDATED --FEBRUARY 1994. COMMENT OUT 2 VARIABLE STATS C UPDATED --NOVEMBER 1994. ISUBN2 TO ISUBN3 C UPDATED --MARCH 1995. AAD AND MAD STATISTICS C UPDATED --MAY 1995. ADDITIONAL EQUIVALENCE C UPDATED --NOVEMBER 1998. AAD PERCENTILE C UPDATED --AUGUST 2002. CALL "CMPSTA" TO COMPUTE C STATISTICS C UPDATED --APRIL 2003. SUPPORT FOR SN AND QN REQUIRES C ADDITIONAL SCRATCH ARRAYS C FOR CMPSTA C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN3 CHARACTER*4 ISTEPN C CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION TAG(*) C DIMENSION DIST(*) C DIMENSION Y2(*) DIMENSION X2(*) DIMENSION TAG2(*) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' C DIMENSION TAG9(MAXOBV) DIMENSION DTAG9(MAXOBV) DIMENSION TEMP(MAXOBV) DIMENSION TEMPZ(MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZI.INC' C DIMENSION XTEMP1(MAXOBV) DIMENSION XTEMP2(MAXOBV) DIMENSION XTEMP3(MAXOBV) INTEGER ITEMP1(MAXOBV) INTEGER ITEMP2(MAXOBV) INTEGER ITEMP3(MAXOBV) INTEGER ITEMP4(MAXOBV) INTEGER ITEMP5(MAXOBV) INTEGER ITEMP6(MAXOBV) C EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1)) EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1)) EQUIVALENCE (GARBAG(IGARB7),TAG9(1)) EQUIVALENCE (GARBAG(IGARB8),DTAG9(1)) EQUIVALENCE (GARBAG(IGARB9),TEMP(1)) EQUIVALENCE (GARBAG(IGAR10),XTEMP3(1)) EQUIVALENCE (G2RBAG(IGAR11),TEMPZ(1)) 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 INCLUDE 'DPCOST.INC' 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='DPBL' ISUBN3='O3 ' C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BLO3')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPBLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICASPL,ISUBRO 53 FORMAT('ICASPL,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)N 54 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I),TAG(I) 56 FORMAT('I, Y(I), X(I),TAG(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,61)NDIST 61 FORMAT('NDIST = ',I8) CALL DPWRST('XXX','BUG ') DO62I=1,NDIST WRITE(ICOUT,63)I,DIST(I) 63 FORMAT('I, DIST(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 62 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** LOOP THROUGH EACH DISTINCT HOR. AXIS VALUE. ** C ** FOR A GIVEN HORIZONTAL AXIS VALUE-- ** C ** COPY OVER THE RAW DATA, OR ** C ** COMPUTE THE STATISTIC ** C ************************************************** C ISTEPN='24' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN3) C IWRITE='OFF' N2=0 DO1100ISET=1,NDIST NTAG9=0 DO1200I=1,N IF(X(I).EQ.DIST(ISET))THEN NTAG9=NTAG9+1 TAG9(NTAG9)=TAG(I) ENDIF 1200 CONTINUE CALL DISTIN(TAG9,NTAG9,'OFF ',DTAG9,NDTAG9,IBUGG3,IERROR) CALL SORT(DTAG9,NDTAG9,DTAG9) DO1300K=1,NDTAG9 NS2=0 DO1400I=1,N IF(X(I).EQ.DIST(ISET).AND.TAG(I).EQ.DTAG9(K))THEN NS2=NS2+1 TEMP(NS2)=Y(I) ENDIF 1400 CONTINUE C IF(ICASPL.EQ.'RAW ')THEN RIGHT=TEMP(1) ELSE 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) ENDIF C 79000 CONTINUE N2=N2+1 Y2(N2)=RIGHT X2(N2)=DIST(ISET) TAG2(N2)=DTAG9(K) C 1300 CONTINUE 1100 CONTINUE C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'BLO3')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBLO3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,ISUBRO 9012 FORMAT('ICASPL,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NDIST,N2,IERROR 9013 FORMAT('N,NDIST,N2,IERROR = ',3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NTAG9,NDTAG9,NS2 9014 FORMAT('NTAG9,NDTAG9,NS2 = ',3I8) CALL DPWRST('XXX','BUG ') C DO9021I=1,N2 WRITE(ICOUT,9022)I,Y2(I),X2(I),TAG2(I) 9022 FORMAT('I,Y2(I),X2(I),TAG2(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9021 CONTINUE C 9090 CONTINUE C RETURN END SUBROUTINE DPBLPA(IHARG,IHARG2,NUMARG, 1IPSTBP,IFOUND,IERROR) C C PURPOSE--TURN ON/OFF THE (INITIAL) BLANK PAGE SWITCH C FOR POSTSCRIPT. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IHARG2 (A CHARACTER VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IPSTBP (A CHARACTER VECTOR C WHICH CONTAINS THE C POSTSCRIPT BLANK PAGE SWITCH (ON/OFF) 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--92/6 C ORIGINAL VERSION--MAY 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IPSTBP CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) 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(NUMARG.LE.0)THEN IPSTBP='ON' ELSE IF(IHARG(NUMARG).EQ.'ON')IPSTBP='ON' IF(IHARG(NUMARG).EQ.'OFF')IPSTBP='OFF' IF(IHARG(NUMARG).EQ.'AUTO')IPSTBP='ON' IF(IHARG(NUMARG).EQ.'DEFA')IPSTBP='OFF' ENDIF C IFOUND='YES' IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE POSTSCRIPT (INITIAL) BLANK PAGE SWITCH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IPSTBP 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPBOB(NPTS,NLAB, 1AMEAN,ASD,AMNX,AMXX,SW, 1ASM,ASB,AKU,AKUK1,AKUK2, 1DLOWBO,DHIGBO,STXMU,ST2SB, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT BOUNDS ON BIAS (BOB) APPROACH TO C CONSENSUS MEANS. BASED ON MACRO PROVIDED BY C STEFAN LEIGH. C PRINTING--YES C SUBROUTINES NEEDED--NONE C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/3 C ORIGINAL VERSION--MARCH 2006. EXTRACTED FROM DPMAN2 ROUTINE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) C CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*1 IBASLC C CHARACTER*20 IMETH C REAL APPF REAL ASM REAL AMNX REAL AMXX REAL ASB REAL AKU REAL AKUK1 REAL AKUK2 REAL SW REAL AMEAN(*) REAL ASD(*) C C---------------------------------------------------------------- C INCLUDE 'DPCOST.INC' C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDI2(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDI2,ALIGN,VALIGN CHARACTER*45 IVALUE(MAXHED) INTEGER NCHAR(MAXHED) REAL AVALUE(MAXHED) C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*132 ITTEMP CHARACTER*132 IHEAD C CHARACTER*4 IRTFMD COMMON/COMRTF/IRTFMD C REAL CPUMIN REAL CPUMAX 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='DPVR' ISUBN2='ML ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOB')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBOB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB,SW,STXMU,ST2SB 52 FORMAT('NPTS,NLAB,SW,STXMU,ST2SB = ',2I8,3G15.7) CALL DPWRST('XXX','BUG ') DO55I=1,NLAB WRITE(ICOUT,56)I,AMEAN(I) 56 FORMAT('I,AMEAN(I) = ',2I8,G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C CALL MEAN(AMEAN,NLAB,IWRITE,ASM,IBUGA3,IERROR) DSB=DBLE(AMXX - AMNX)/DSQRT(12.0D0) DKU=2.0D0*DSQRT((SW**2) + (DSB**2)) ASB=REAL(DSB) AKU=REAL(DKU) AKUK2=AKU AKUK1=AKU/2.0 DLOWBO=DBLE(ASM - AKU) DHIGBO=DBLE(ASM + AKU) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C WRITE(ICOUT,5107) 5107 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5111) 5111 FORMAT('') CALL DPWRST('XXX','WRIT') C 5121 FORMAT(' ') 5123 FORMAT(' ') 5126 FORMAT(' ') 5151 FORMAT(' ',I8) 5152 FORMAT(' ',F15.7) 5155 FORMAT('  ') 5191 FORMAT('
    ') 5127 FORMAT(' ') 5128 FORMAT('
    ') 5193 FORMAT('
') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5170) 5170 FORMAT(' 4. Method: BOB (Bound On Bias):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5171) 5171 FORMAT('      ', 1 'Estimate of Consensus Mean:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)ASM CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5172) 5172 FORMAT('      ', 1 'Within Lab Uncertainty:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)SW CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5173) 5173 FORMAT('      ', 1 'Between Lab Uncertainty:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)ASB CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5178) 5178 FORMAT('      ', 1 'Standard Uncertainty (k = 1):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)AKU/2.0 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5179) 5179 FORMAT('      ', 1 'Expanded Uncertainty (k = 2):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)AKU CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5181) 5181 FORMAT('      ', 1 'Lower 95% (k = 2) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWBO) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5182) 5182 FORMAT('      ', 1 'Upper 95% (k=2) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGBO) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5183) 5183 FORMAT('      ', 1 'Note: BOB Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5184) 5184 FORMAT('      ', 1 '         ', 1 '5 or Fewer Labs') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5155) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN C CALL DPCONA(92,IBASLC) C 8002 FORMAT(A1,'begin{table}') 8005 FORMAT(A1,'begin{center}') 8006 FORMAT(5X,A1,'begin{tabular} {lr}') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8002)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006)IBASLC CALL DPWRST('XXX','WRIT') C 8011 FORMAT(5X,'{',A1,'bf 4. Method: BOB ', 1 '(Bound on Bias):} & ',2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)ASM,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8016 FORMAT(5X,'Within Lab Uncertainty: & ', 1 F15.7,2X,A1,A1) 8017 FORMAT(5X,'Between Lab Uncertainty: & ', 1 F15.7,2X,A1,A1) 8020 FORMAT(5X,'Standard Uncertainty (k = 1): & ', 1 F15.7,2X,A1,A1) 8021 FORMAT(5X,'Expanded Uncertainty (k = 2): & ', 1 F15.7,2X,A1,A1) WRITE(ICOUT,8016)SW,IBASLC,IBASLC CALL DPWRST('XXX','RIT') WRITE(ICOUT,8017)ASB,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8020)AKU/2.0,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)AKU,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8026 FORMAT(5X,'Lower 95',A1,'% (k = 2) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (k = 2) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: BOB Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' 5 or Fewer Labs & ', 1 2X,A1,A1) WRITE(ICOUT,8026)IBASLC,REAL(DLOWBO),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGBO),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8028)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8029)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8030 FORMAT(A1,'end{tabular}') 8031 FORMAT(A1,'end{center}') 8032 FORMAT(A1,'end{table}') WRITE(ICOUT,8030)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8031)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8032)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN C CALL DPCONA(92,IBASLC) C 6191 FORMAT(A1,'f',I1) IF(IRTFFF.EQ.'Courier New')THEN ITEMP=1 ELSEIF(IRTFFF.EQ.'Lucida Console')THEN ITEMP=8 ELSE ITEMP=1 ENDIF WRITE(ICOUT,6191)IBASLC,ITEMP CALL DPWRST(ICOUT,'WRIT') C NCOL=4 IDEFPS=20 IFRST=IRTFPS*5500/IDEFPS IINC1=IRTFPS*1540/IDEFPS C DO6105ISET1=1,NCOL VALIGN(ISET1)='b' ALIGN(ISET1)='r' IF(NUMDI2(ISET1).LT.0.OR.NUMDI2(ISET1).GT.9)NUMDI2(ISET1)=7 6105 CONTINUE ALIGN(1)='l' NUMDI2(1)=0 NUMDI2(2)=7 C IWIDTH(1)=IFRST IWIDTH(2)=IWIDTH(1) + IINC1 C ITTEMP=' ' NCTEMP=0 NHEAD=0 C CALL DPRTF1(ITTEMP,NCTEMP,IHEAD,NHEAD) C NHEAD=2 IFLAG1=.FALSE. IFLAG2=.FALSE. C IVALUE(1)=' b 4. Method: BOB (Bound on Bias)' IVALUE(1)(1:1)=IBASLC NCHAR(1)=33 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IFLAG1=.FALSE. NHEAD=1 C NCHAR(1)=30 IVALUE(1)=' Estimate of Consensus Mean:' AVALUE(2)=ASM CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=26 IVALUE(1)=' Within Lab Uncertainty:' AVALUE(2)=SW CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=27 IVALUE(1)=' Between Lab Uncertainty:' AVALUE(2)=ASB CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=AKU/2.0 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=AKU CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Lower 95% (normal) Confidence Limit:' AVALUE(2)=REAL(DLOWBO) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Upper 95% (normal) Confidence Limit:' AVALUE(2)=REAL(DHIGBO) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: BOB Best Usage:' NCHAR(1)=24 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' 5 or Fewer Labs:' NCHAR(1)=25 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C CALL DPRTF6(NHEAD) IFLAG1=.TRUE. IFLAG2=.FALSE. C ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'WOML')THEN ELSE C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4001) 4001 FORMAT('4. Method: BOB (Bound on Bias)') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)ASM 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4006)SW 4006 FORMAT(' Within Lab Uncertainty: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4007)ASB 4007 FORMAT(' Between Lab Uncertainty: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4012)AKU/2.0 4012 FORMAT(' Standard Uncertainty (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4013)AKU 4013 FORMAT(' Expanded Uncertainty (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4022)REAL(DLOWBO) 4022 FORMAT(' Lower 95% (k = 2) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DHIGBO) 4023 FORMAT(' Upper 95% (k = 2) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: BOB Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' 5 or Fewer Labs') CALL DPWRST('XXX','WRIT') C ENDIF ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOB')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBOB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NPTS,NLAB 9013 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ASM,ASB,AKU 9014 FORMAT('ASM,ASB,AKU = ',3G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWBO,DHIGBO 9015 FORMAT('DLOWBO,DHIGBO = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPBOCC(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1MAXBOX,PBOXXC,PBOXYC,NUMBOX,IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 PAIRS OF (X,Y) COORDINATES C FOR A BOX. C THE FIRST PAIR WILL BE FOR THE LOWER LEFT CORNER C OF THE BOX; C THE SECOND PAIR WILL BE FOR THE UPPER RIGHT CORNER C OF THE BOX. C THE (X1,Y1), (X2,Y2) COORDINATES WILL BE PLACED IN THE C FIRST AND SECOND ELEMENTS (RESPECTIVELY) OF C THE 2 BOXAYS PBOXXC(.,.) AND PBOXYC(.,.) C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXBOX C OUTPUT ARGUMENTS--PBOXXC (A FLOATING POINT VECTOR C WHOSE (I,1)-TH ELEMENT CONTAINS THE C X COORDINATE FOR THE ONE CORNER OF BOX I; C WHOSE (I,2)-TH ELEMENT CONTAINS THE C X COORDINATE FOR THE OPPOSITE CORNER OF BOX I; C --PBOXYC (A FLOATING POINT VECTOR C WHOSE (I,1)-TH ELEMENT CONTAINS THE C Y COORDINATE FOR THE ONE CORNER OF BOX I; C WHOSE (I,2)-TH ELEMENT CONTAINS THE C Y COORDINATE FOR THE OPPOSITE CORNER OF BOX I; C --NUMBOX = THE NUMBER OF BOXES DEFINED SO FAR C (ACTUALLY, THE HIGHEST REFERENCED BOX SO FAR) 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--SEPTEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 1992. FIX BUG (ALAN) C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHWORD CHARACTER*4 IHWOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IANS(*) C DIMENSION PBOXXC(100,2) DIMENSION PBOXYC(100,2) 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='DPBO' ISUBN2='CC ' C IFOUND='NO' IERROR='NO' C HOLD1=0.0 HOLD2=0.0 HOLD3=0.0 HOLD4=0.0 C IF(NUMARG.EQ.0)GOTO9000 CCCCC OCTOBER 1992. DISTINGUISH: BOX 1 COORDINATES FROM CCCCC BOX CORNER COORDINATES CASE IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.IHARG(2).EQ.'COOR') 1GOTO1110 IF(NUMARG.GE.2.AND.IHARG(1).NE.'CORN'.AND.IHARG(2).EQ.'COOR')THEN ILASTC=2 GOTO1140 ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO1110 ILASTC=3 C END CHANGE IF(NUMARG.GE.3.AND.IHARG(3).EQ.'COOR')GOTO1140 GOTO9000 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1120 IF(IHARG(3).EQ.'OFF')GOTO1120 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 IF(NUMARG.GE.6)GOTO1125 C IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPBOCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IN THE BOX ... CORNER COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' THE CORNER COORDINATES ARE SPECIFIED ', 1'BY 4 NUMBERS, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' BOX 3 CORNER COORDINATES 30 50 40 60') CALL DPWRST('XXX','BUG ') GOTO9000 C 1120 CONTINUE HOLD1=CPUMIN HOLD2=CPUMIN HOLD3=CPUMIN HOLD4=CPUMIN NUMBOX=0 GOTO1130 C 1125 CONTINUE DO1126J=3,6 IF(IARGT(J).EQ.'NUMB')GOTO1127 GOTO1128 1127 CONTINUE IF(J.EQ.3)HOLD1=ARG(J) IF(J.EQ.4)HOLD2=ARG(J) IF(J.EQ.5)HOLD3=ARG(J) IF(J.EQ.6)HOLD4=ARG(J) GOTO1126 1128 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.3)HOLD1=VALUE(ILOC) IF(J.EQ.4)HOLD2=VALUE(ILOC) IF(J.EQ.5)HOLD3=VALUE(ILOC) IF(J.EQ.6)HOLD4=VALUE(ILOC) 1126 CONTINUE NUMBOX=MAXBOX GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX PBOXXC(I,1)=HOLD1 PBOXYC(I,1)=HOLD2 PBOXXC(I,2)=HOLD3 PBOXYC(I,2)=HOLD4 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136) 1136 FORMAT('ALL BOX CORNER COORDINATES HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137)PBOXXC(I,1),PBOXYC(I,1) 1137 FORMAT(' (X,Y) FOR LOWER LEFT CORNER OF BOX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)PBOXXC(I,2),PBOXYC(I,2) 1138 FORMAT(' (X,Y) FOR LOWER RIGHT CORNER OF BOX = ',2E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO9000 C CCCCC OCTOBER 1992. FOLLOWING SECTION MODIFIED TO HANDLE CCCCC BOX COOR CASE. 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... CORNER COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 CORNER COORDINATES 30 50 40 60') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... CORNER COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1160 CONTINUE CCCCC IF(NUMARG.LE.3)GOTO1170 IF(NUMARG.LE.ILASTC)GOTO1170 CCCCC IF(IHARG(4).EQ.'ON')GOTO1170 CCCCC IF(IHARG(4).EQ.'OFF')GOTO1170 CCCCC IF(IHARG(4).EQ.'AUTO')GOTO1170 CCCCC IF(IHARG(4).EQ.'DEFA')GOTO1170 IFRSTC=ILASTC+1 IF(IHARG(IFRSTC).EQ.'ON')GOTO1170 IF(IHARG(IFRSTC).EQ.'OFF')GOTO1170 IF(IHARG(IFRSTC).EQ.'AUTO')GOTO1170 IF(IHARG(IFRSTC).EQ.'DEFA')GOTO1170 CCCCC IF(NUMARG.GE.7)GOTO1175 IF(NUMARG.GE.IFRSTC+3)GOTO1175 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) CALL DPWRST('XXX','BUG ') GOTO9000 C 1170 CONTINUE HOLD1=CPUMIN HOLD2=CPUMIN HOLD3=CPUMIN HOLD4=CPUMIN IF(I.EQ.NUMBOX)NUMBOX=I-1 GOTO1180 C 1175 CONTINUE CCCCC DO1176J=4,7 DO1176J=IFRSTC,IFRSTC+3 IF(IARGT(J).EQ.'NUMB')GOTO1177 GOTO1178 1177 CONTINUE IF(J.EQ.4)HOLD1=ARG(J) IF(J.EQ.5)HOLD2=ARG(J) IF(J.EQ.6)HOLD3=ARG(J) IF(J.EQ.7)HOLD4=ARG(J) GOTO1176 1178 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.4)HOLD1=VALUE(ILOC) IF(J.EQ.5)HOLD2=VALUE(ILOC) IF(J.EQ.6)HOLD3=VALUE(ILOC) IF(J.EQ.7)HOLD4=VALUE(ILOC) 1176 CONTINUE IF(I.GT.NUMBOX)NUMBOX=I GOTO1180 C 1180 CONTINUE IFOUND='YES' PBOXXC(I,1)=HOLD1 PBOXYC(I,1)=HOLD2 PBOXXC(I,2)=HOLD3 PBOXYC(I,2)=HOLD4 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I 1186 FORMAT('THE CORNER COORDINATES FOR BOX ',I8, 1' HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137)PBOXXC(I,1),PBOXYC(I,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1138)PBOXXC(I,2),PBOXYC(I,2) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBOCC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBOCL(IHARG,IARGT,IARG,NUMARG,IDEFXC, 1MAXBOX,IBOFCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR A BOX. C THE COLOR FOR A BOX IS THE COLOR C THAT WILL APPEAR ON THE BORDER OF THE BOX. C THE COLOR FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR IBOFCO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFXC C --MAXBOX C OUTPUT ARGUMENTS--IBOFCO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C COLOR FOR BOX I. 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--SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --AUGUST 1992. FEEDBACK MESSAGES C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFXC CHARACTER*4 IBOFCO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IBOFCO(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFXC GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX IBOFCO(I)=IHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)IBOFCO(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1136 FORMAT('ALL BOX COLORS HAVE JUST BEEN SET TO ', 1136 FORMAT('ALL BOX BORDER COLORS HAVE JUST BEEN SET TO ', 1A4) GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 COLOR GREEN') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFXC GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOFCO(I)=IHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,IBOFCO(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1186 FORMAT('THE COLOR FOR BOX ',I8, 1186 FORMAT('THE BORDER COLOR FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',A4) GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC, 1MAXBOX,IBOFCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE FILL PATTERN IN A BOX C I.E., THE COLOR C THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX. C THE COLOR FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR IBOFCO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFXC C --MAXBOX C OUTPUT ARGUMENTS--IBOFCO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C COLOR FOR BOX I. 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 ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFXC CHARACTER*4 IBOFCO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IBOFCO(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO') 1GOTO1110 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'COLO') 1GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1120 IF(IHARG(3).EQ.'OFF')GOTO1120 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFXC GOTO1130 C 1125 CONTINUE IHOLD=IHARG(3) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX IBOFCO(I)=IHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)IBOFCO(I) 1136 FORMAT('ALL BOX FILL COLORS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOFC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... FILL COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 FILL COLOR GREEN') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOFC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... FILL COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1170 IF(IHARG(4).EQ.'OFF')GOTO1170 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFXC GOTO1180 C 1175 CONTINUE IHOLD=IHARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOFCO(I)=IHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,IBOFCO(I) 1186 FORMAT('THE FILL COLOR FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOFI(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1ISEED,IBOOSS, 1IFOUND,IERROR) C C PURPOSE--GENERATE BOOTSTRAP BASED MULTI-LINEAR FIT. C BOOTSTRAP ESTIMATES FOR A0, A1, ETC. WILL BE C WRITTEN TO FILE DPST1F.DAT. 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--2002/6 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' C CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 IBUGAZ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IOP CHARACTER*4 ICASFI CHARACTER*4 ICASJB CHARACTER*4 ICASEQ CHARACTER*4 IKEY CCCCC CHARACTER*4 IHWUSE CCCCC CHARACTER*4 MESSAG CHARACTER*4 IHRESP(MAXCMF) CHARACTER*4 IHRES2(MAXCMF) CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CCCCC CHARACTER*4 IPARN CCCCC CHARACTER*4 IPARN2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INTEGER ILOCRV(MAXCMF) INTEGER ICOLRV(MAXCMF) CCCCC DIMENSION IPARN(100) CCCCC DIMENSION IPARN2(100) C DIMENSION PARAM(100) DIMENSION T(101) DIMENSION S(102) DIMENSION PARAM2(100) DIMENSION T2(101) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZI.INC' C DIMENSION W(MAXOBV) DIMENSION VSDPRD(MAXOBV) DIMENSION PRED2(MAXOBV) DIMENSION RES2(MAXOBV) C DIMENSION TEMP1(MAXOBV) DIMENSION TEMP2(MAXOBV) DIMENSION TEMP3(MAXOBV) DIMENSION TEMP4(MAXOBV) DIMENSION RES3(MAXOBV) DIMENSION RES4(MAXOBV) DIMENSION ITEMP1(MAXOBV) C DIMENSION XMAT(MAXOBV,MAXCMF) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOST.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' C EQUIVALENCE (W(1),X3D(1)) EQUIVALENCE (PRED2(1),X(1)) EQUIVALENCE (RES2(1),D(1)) EQUIVALENCE (DFILL(1),VSDPRD(1)) EQUIVALENCE (G2RBAG(IGAR11),XMAT(1,1)) EQUIVALENCE (GARBAG(IGARB1),PARAM(1)) EQUIVALENCE (GARBAG(IGARB1+200),T(1)) EQUIVALENCE (GARBAG(IGARB1+400),S(1)) EQUIVALENCE (GARBAG(IGARB1+600),PARAM2(1)) EQUIVALENCE (GARBAG(IGARB1+800),T2(1)) EQUIVALENCE (GARBAG(IGARB2),TEMP1(1)) EQUIVALENCE (GARBAG(IGARB3),TEMP2(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP3(1)) EQUIVALENCE (GARBAG(IGARB5),RES3(1)) EQUIVALENCE (GARBAG(IGARB6),RES4(1)) EQUIVALENCE (GARBAG(IGARB7),TEMP4(1)) EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1)) 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='DPBO' ISUBN2='FI ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C MAXV2=MAXCMF MINV2=2 MINN2=2 NQ=1 C NUMPV=(-999) IP=(-999) IV=(-999) C IWIDMO=(-999) C NUMIND=(-999) C C ************************************ C ** TREAT THE BOOTSTRAP FIT CASE ** C ************************************ C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BOFI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBOFI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE 90 CONTINUE C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASJB='BOOT' IF(ICOM.EQ.'BOOT'.AND.IHARG(1).EQ.'FIT ')THEN ICASJB='BOOT' GOTO111 ENDIF C IFOUND='NO' GOTO9000 C 111 CONTINUE ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' ICASFI='MLIN' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=0 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ****************************************************** C ** STEP 3-- ** C ** FOR THE CASES WHEN HAVE FIT Y = SOME EXPRESSION ** C ** DETERMINE IF WE HAVE A VALID FUNCTIONAL ** C ** EXPRESSION--IN PARTICULAR, CHECK THAT THE NUMBER** C ** OF ARGUMENTS IS AT LEAST 1, AND ALSO CHECK ** C ** THAT THERE IS EXACTLY 1 EQUAL SIGN AND THAT ** C ** THIS EQUAL SIGN OCCURS AS THE SECOND ARGUMENT. ** C ****************************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LT.MINV2)THEN WRITE(ICOUT,2001) 2001 FORMAT('***** ERROR IN DPBOFI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2002) 2002 FORMAT(' NUMBER OF ARGUMENTS DETECTED IN BOOTSTRAP FIT ', 1 'COMMAND < 2.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2003)NUMARG 2003 FORMAT(' NEED DEPENDENT VARIABLE AND AT LEAST 3 ', 1 'INDEPENDENT VARIABLES. NUMARG = ',I3) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2008)(IANS(J),J=1,MIN(100,IWIDTH)) 2008 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C DO2100J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO2110 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO2110 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO2110 2100 CONTINUE ILOCQ=NUMARG+1 GOTO2120 2110 CONTINUE ILOCQ=J1 GOTO2120 2120 CONTINUE C NQ=ILOCQ-1 C IF(NQ.GT.MAXV2+1)THEN WRITE(ICOUT,2145)MAXV2+1 2145 FORMAT('**** ERROR FROM BOOTSTRAP FIT: MAXIMIUM NUMBER OF ', 1 'VARIABLES,',I5,', EXCEEDED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 4-- ** C ** FOR ALL VARIATIONS OF THE 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 ** C ** FACT, A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ** NOTE: FOR IMPLICIT MODEL, NO RESPONSE ** C ** VARIABLE. ** C **************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2310J=1,NQ ILOCF1=J IF(J.EQ.1)THEN IHLEFT=IHARG(ILOCF1) IHLEF2=IHARG2(ILOCF1) ENDIF IHRESP(J)=IHARG(ILOCF1) IHRES2(J)=IHARG2(ILOCF1) C DO2350I=1,NUMNAM I2=I IF(IHRESP(J).EQ.IHNAME(I2).AND.IHRES2(J).EQ.IHNAM2(I2).AND. 1 IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN DPBOFI (BOOTSTRAP FIT)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME AFTER THE WORD BOOTSTRAP FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE THE DEPENDENT VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST OR IS A PARAMETER ', 1 '(AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT LIST OF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' AVAILABLE VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHRESP(J),IHRES2(J) 2369 FORMAT(' NAME AFTER THE WORD BOOTSTRAP FIT = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) 2378 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 2379 CONTINUE IF(J.EQ.1)THEN ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) ELSE ILOCRV(J)=I2 ICOLRV(J)=IVALUE(ILOCRV(J)) NTEMP=IN(ILOCRV(J)) IF(NTEMP.NE.NLEFT)THEN WRITE(ICOUT,2381) 2381 FORMAT('***** ERROR IN DPBOFI (BOOTSTRAP FIT)--ALL ', 1 'INDEPENDENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2383) 2383 FORMAT(' VARIABLES MUST HAVE THE SAME NUMBER OF ', 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2385)IHRESP(J),IHRES2(J),NTEMP 2385 FORMAT(' INDEPENDENT VARIABLE ',A4,A4,' HAS ',I8, 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2387)NLEFT 2387 FORMAT(' NUMBER OF OBSEVATIONS EXPECTED: ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2378)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF ENDIF 2310 CONTINUE C 2390 CONTINUE C C **************************************************** C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE COMMAND, CHECK THAT ** C ** THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER AND ** C ** LESS THAN MAXOB2. ** C **************************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NJUNK=MAX(MINN2,NQ-1) IF(NLEFT.GE.MINN2.AND.NLEFT.LE.MAXOBV)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPBOFI (BOOTSTRAP FIT)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS (FOR WHICH A ', 1'(IN VARIABLE ',A4,A4,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' BOOTSTRAP FIT ANALYSIS WAS TO HAVE BEEN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' PERFORMED MUST BE AT LEAST ',I8,' AND NO MORE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' THAN ',I8,'; SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,319)(IANS(I),I=1,MIN(100,IWIDTH)) 319 FORMAT(100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 C 390 CONTINUE C C ************************************************ C ** STEP 5.1-- ** C ** CHECK TO SEE IF HAVE A WEIGHTS VARIABLE. ** C ** IF DO HAVE, CHECK TO SEE IF A VARIABLE ** C ** (AS OPPOSED TO A PARAMETER). ** C ************************************************ C ISTEPN='5.1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PBOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCW=-99 ICOLW=-99 NWEIGH=-99 IF(IWEIGH.EQ.'OFF')GOTO2490 DO2450I=1,NUMNAM I2=I IF(IWEIG1.EQ.IHNAME(I2).AND.IWEIG2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2479 2450 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2461) 2461 FORMAT('***** ERROR IN DPBOFI--THE WEIGHTS VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2463) 2463 FORMAT(' (AS SPECIFIED VIA THE WEIGHTS COMMAND) EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2465) 2465 FORMAT(' DOES NOT EXIST OR IS A PARAMETER (AS OPPOSED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2466) 2466 FORMAT(' TO A VARIABLE) IN THE CURRENT LIST OF AVAILABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2468) 2468 FORMAT(' VARIABLE AND PARAMETER NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2469)IWEIG1,IWEIG2 2469 FORMAT(' NAME OF SPECIFIED WEIGHTS VARIABLE = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2478)(IANS(J),J=1,IWIDTH) 2478 FORMAT(' COMMAND LINE--',100A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 2479 CONTINUE ILOCW=I2 ICOLW=IVALUE(ILOCW) NWEIGH=IN(ILOCW) 2490 CONTINUE C IF(NTEMP.NE.NLEFT)THEN WRITE(ICOUT,2581) 2581 FORMAT('***** ERROR IN DPBOFI (BOOTSTRAP FIT)--THE WEIGHT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2583) 2583 FORMAT(' VARIABLE MUST HAVE THE SAME NUMBER OF ', 1 'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2585)IWEIGH,IWEIG2,NWEIGH 2585 FORMAT(' WEIGHT VARIABLE ',A4,A4,' HAS ',I8,'OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2587)NLEFT 2587 FORMAT(' NUMBER OF OBSEVATIONS EXPECTED: ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,2478)(IANS(JJ),JJ=1,MIN(100,IWIDTH)) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ********************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE FIT COMMAND, ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BOFI')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ***************************************************** C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN ** C ** COPY OVER THE DEPENDENT VARIABLE AND THE ** C ** THE INDPENENDENT VARIABLES INTO THE MATRIX ** C ** XMAT. ALSO, CREATE A COLUMN OF "1"'s IN THE ** C ** MODEL INCLUDES AN ADDITIVE CONSTANT. ** C ***************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) WRITE(ICOUT,601)N,ILOCQ-1 601 FORMAT('N,ILOCQ-1 = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C NTEMP=NLEFT C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NTEMP ISUB(I)=1 615 CONTINUE NQZ=NTEMP GOTO650 C 620 CONTINUE NIOLD=NTEMP CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQZ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NTEMP CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQZ=NFOR GOTO650 C 650 CONTINUE IFACT=1 IF(IFITAC.EQ.'OFF')IFACT=0 C J=0 DO4450I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4450 J=J+1 4450 CONTINUE NS=J C J=0 DO4500I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4500 K=ICOLL J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)Y(J)=V(IJ) IF(K.EQ.MAXCP1)Y(J)=PRED(I) IF(K.EQ.MAXCP2)Y(J)=RES(I) IF(K.EQ.MAXCP3)Y(J)=YPLOT(I) IF(K.EQ.MAXCP4)Y(J)=XPLOT(I) IF(K.EQ.MAXCP5)Y(J)=X2PLOT(I) IF(K.EQ.MAXCP6)Y(J)=TAGPLO(I) 4500 CONTINUE C N2=J C IF(IFITAC.EQ.'ON')THEN DO4510I=1,NS XMAT(I,1)=1.0 4510 CONTINUE NVARS=1 ELSE NVARS=0 ENDIF C J=0 C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4501) 4501 FORMAT('***** FROM DPBOFI, FORMING XMAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4503)NS,IFACT,NTEMP,NQ 4503 FORMAT('NS,IFACT,NTEMP,NQ = ',4(I8,2X)) CALL DPWRST('XXX','BUG ') DO4505I=1,ILOCQ WRITE(ICOUT,4507)I,ICOLRV(I),ILOCRV(I) 4507 FORMAT('I,ICOLRV(I),ILOCRV(I) = ',3(I8,2X)) CALL DPWRST('XXX','BUG ') 4505 CONTINUE ENDIF C J=0 NFRST=2 NLAST=NQ DO4520I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4520 J=J+1 DO4600L=NFRST,NLAST K=ICOLRV(L) IJ=MAXN*(K-1)+I ICOL=L-NFRST+1+NVARS IF(K.LE.MAXCOL)XMAT(J,ICOL)=V(IJ) IF(K.EQ.MAXCP1)XMAT(J,ICOL)=PRED(I) IF(K.EQ.MAXCP2)XMAT(J,ICOL)=RES(I) IF(K.EQ.MAXCP3)XMAT(J,ICOL)=YPLOT(I) IF(K.EQ.MAXCP4)XMAT(J,ICOL)=XPLOT(I) IF(K.EQ.MAXCP5)XMAT(J,ICOL)=X2PLOT(I) IF(K.EQ.MAXCP6)XMAT(J,ICOL)=TAGPLO(I) 4600 CONTINUE 4520 CONTINUE NVARS=NVARS+(NLAST-NFRST+1) C J=0 DO4720I=1,NTEMP IF(ISUB(I).EQ.0)GOTO4720 IF(IWEIGH.EQ.'OFF')THEN J=J+1 W(J)=1.0 ELSE J=J+1 K=ICOLW IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)W(J)=V(IJ) IF(K.EQ.MAXCP1)W(J)=PRED(I) IF(K.EQ.MAXCP2)W(J)=RES(I) IF(K.EQ.MAXCP3)W(J)=YPLOT(I) IF(K.EQ.MAXCP4)W(J)=XPLOT(I) IF(K.EQ.MAXCP5)W(J)=X2PLOT(I) IF(K.EQ.MAXCP6)W(J)=TAGPLO(I) ENDIF 4700 CONTINUE C 4720 CONTINUE NVARS=NLAST-NFRST+2 C C **************************************************************** C ** STEP 11-- C ** DUMP THE COMMON VECTOR V(.) OUT ONTO MASS STORAGE C ** SO AS TO PRESERVE THEIR CONTENTS FOR LATER USE C ** (AFTER DPFIT2). C ** THE ABOVE DUMP TO MASS STORAGE IS UNNECESSARY AND IS NOT DON C ** FOR THE SPECIAL CASE WHEN THE NUMBER OF PARAMETERS C ** IS 0 (A NO-FIT CASE WHEREBY WE ARE REALLY INTERESTED C ** IN GENERATING PREDICTED VALUES AND RESIDUALS C ** FOR A GIVEN FULLY-SPECIFIED MODEL). C **************************************************************** C ISTEPN='11' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOP='WRIT' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C C ************************************************* C ** STEP 14-- ** C ** CARRY OUT THE ACTUAL FIT ** C ** VIA CALLING ** C ** DPBOF2 (FOR GENERAL MODELS), OR ** C ************************************************* C ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IBUGAZ=IBUGA3 C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BOFI')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM DPBOFI, AS ABOUT TO CALL DPBOF2--') CALL DPWRST('XXX','BUG ') DO6083I=1,N WRITE(ICOUT,6084)I,(XMAT(I,J),J=1,5) 6084 FORMAT('I,(XMAT(I,J),J=1,5) = ',I6,2X,5G15.7) CALL DPWRST('XXX','BUG ') 6083 CONTINUE WRITE(ICOUT,6082)NLEFT,MAXN,NS,NVARS 6082 FORMAT('NLEFT,MAXN,NS,NVARS = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6091)IBUGA3,IBUGCO,IBUGEV 6091 FORMAT('IBUGA3,IBUGCO,IBUGEV = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 6099 CONTINUE C 6520 CONTINUE C CALL DPBOF2(Y,XMAT,N2,NVARS,MAXOBV,MAXCMF, 1PARAM,T,S,W,VSDPRD,PRED2,RES2,V, 1PARAM2,T2,RES3,RES4, 1TEMP1,TEMP2,TEMP3,TEMP4,ITEMP1, 1ICASFI,ICASJB,IBOOME,IBOOSS,ISEED, 1IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO6590 C 6590 CONTINUE C IOP='READ' CALL DPSWAP(IOP,V,NUMNAM,IHNAME,IHNAM2,IUSE,IN, 1IVALUE,MAXN,MAXCOL,MAXN2,MAXCO2,MAXIJ2,IBUGA3,ISUBRO,IERROR) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BOFI')GOTO8129 WRITE(ICOUT,8121) 8121 FORMAT('WE ARE IN DPBOFI AND HAVE JUST READ ', 1'V(.) BACK IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8122)MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) 8122 FORMAT('MAXN2,MAXCO2,MAXIJ2,NLEFT,NS,V(1),PRED(1),RES(1) = ', 15I6,3E15.7) CALL DPWRST('XXX','BUG ') 8129 CONTINUE C C *************************************** C ** STEP 15-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C 7000 CONTINUE C ISTEPN='15' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'BOFI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBOFI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3,NS 9012 FORMAT('IBUGA2,IBUGA3,NS = ',A4,2X,A4,1X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NUMNAM 9016 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9017I=1,NUMNAM WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 9018 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 9017 CONTINUE 9042 CONTINUE 9049 CONTINUE WRITE(ICOUT,9051)NLEFT,NS,V(1),PRED(1),RES(1) 9051 FORMAT('NLEFT,NS,V(1),PRED(1),RES(1) = ',2I8,3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH)) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBOF2(Y,XMAT,N,NVARS,MAXOBV,MAXCMF, 1B,T,S,W,VSDPRD,PRED,RES,SCR, 1BORG,TORG,RES1,RES2, 1TEMP1,TEMP2,TEMP3,TEMP4,ITEMP1, 1ICASFI,iCASJB,IBOOME,IBOOSS,ISEED, 1IBUGA3,ISUBRO,IERROR) C C BOOTSTRAP MULTILINEAR FIT. 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--2002/7 C ORIGINAL VERSION--JULY 2002. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBOOME CHARACTER*4 ICASFI CHARACTER*4 ICASJB CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 IWRITE C CHARACTER*80 IFILE1 CHARACTER*12 ISTAT1 CHARACTER*12 IFORM1 CHARACTER*12 IACCE1 CHARACTER*12 IPROT1 CHARACTER*12 ICURS1 CHARACTER*4 IERRF1 CHARACTER*4 IENDF1 CHARACTER*4 IREWI1 C CHARACTER*80 IFILE2 CHARACTER*12 ISTAT2 CHARACTER*12 IFORM2 CHARACTER*12 IACCE2 CHARACTER*12 IPROT2 CHARACTER*12 ICURS2 CHARACTER*4 IERRF2 CHARACTER*4 IENDF2 CHARACTER*4 IREWI2 C CHARACTER*80 IFILE3 CHARACTER*12 ISTAT3 CHARACTER*12 IFORM3 CHARACTER*12 IACCE3 CHARACTER*12 IPROT3 CHARACTER*12 ICURS3 CHARACTER*4 IERRF3 CHARACTER*4 IENDF3 CHARACTER*4 IREWI3 C CHARACTER*80 IFILE4 CHARACTER*12 ISTAT4 CHARACTER*12 IFORM4 CHARACTER*12 IACCE4 CHARACTER*12 IPROT4 CHARACTER*12 ICURS4 CHARACTER*4 IERRF4 CHARACTER*4 IENDF4 CHARACTER*4 IREWI4 C CHARACTER*4 ISUBN0 C CHARACTER*3 IPARNM C C--------------------------------------------------------------------- C INTEGER N, NVARS INTEGER ITEMP1(*) C REAL Y(MAXOBV) REAL XMAT(MAXOBV,MAXCMF) REAL B(*) REAL T(*) REAL S(*) REAL BORG(*) REAL TORG(*) REAL W(MAXOBV) REAL VSDPRD(MAXOBV) REAL PRED(MAXOBV) REAL RES(MAXOBV) REAL RES1(*) REAL RES2(*) REAL SCR(*) REAL TEMP1(MAXOBV) REAL TEMP2(MAXOBV) REAL TEMP3(MAXOBV) REAL TEMP4(MAXOBV) C DOUBLE PRECISION DSUM1 C INCLUDE 'DPCOF2.INC' 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='DPBO' ISUBN2='F2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'BOF2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBOF2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NVARS 52 FORMAT('N,NVARS= ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBOOSS,IBOOME 54 FORMAT('IBOOSS, IBOOME = ',I8,A4) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),W(I) 56 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,N WRITE(ICOUT,66)I,(XMAT(I,J),J=1,MIN(5,NVARS)) 66 FORMAT('I,(XMAT(I,J),J=1,MIN(NVARS,5) = ',I8,5E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 0.5-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C ISTEPN='0.5' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='BOF2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='BOF2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='BOF2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4='UNFORMATTED' IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='BOF2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C ***************************************************** C ** STEP 1-- ** C ** PRINT SUMMARY INFORMATION. ** C ***************************************************** C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('BOOTSTRAP LINEAR/MULTILINEAR FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)N 103 FORMAT('NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)IBOOSS 104 FORMAT('NUMBER OF BOOTSTRAP SAMPLES = ',I8) CALL DPWRST('XXX','BUG ') IF(IBOOME.EQ.'DATA')THEN WRITE(ICOUT,912) 912 FORMAT('BOOTSTRAP METHOD = DATA (WU METHOD)') CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,922) 922 FORMAT('BOOTSTRAP METHOD = RESIDUALS (EFRON ', 1 ' METHOD)') CALL DPWRST('XXX','BUG ') ENDIF WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,105) 105 FORMAT(' SUMMARY TABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,107) 107 FORMAT( 1' ESTIMATES FROM ', 1' ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,108) 108 FORMAT( 1'PARA- ORIGINAL FIT ESTIMATES FROM ', 1' BOOTSTRAP FIT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,109) 109 FORMAT( 1'METER COEF SD MEAN SD ', 1' 2.5 97.5') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C C ***************************************************** C ** STEP 2-- ** C ** BOOTSTRAP FIT BY "DATA" METHOD. ** C ***************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2') 1 CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NPAR=NVARS IT=2 ICASJB='BOOT' NRESAM=IBOOSS C IF(IBOOME.EQ.'DATA')THEN C C GENERATE FIT FROM ORIGINAL DATA C CALL LSQRTX(Y,W,N,XMAT,MAXOBV,NPAR,IT, 1 B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID, 1 IBUGA3,ISUBRO,IERROR) DO210I=1,NPAR BORG(I)=B(I) TORG(I)=T(I) 210 CONTINUE C C SAVE ORIGINAL DATA TO UNFORMATTED FILE FOR FAST ACCESS C WRITE(IOUNI4)Y WRITE(IOUNI4)XMAT WRITE(IOUNI4)W IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C DO110IRESAM=1,NRESAM IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN WRITE(ICOUT,112)IRESAM 112 FORMAT('FROM DPBOFI, IRESAM = ',I8) CALL DPWRST('XXX','BUG ') ENDIF IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 READ(IOUNI4)Y READ(IOUNI4)XMAT READ(IOUNI4)W IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN DO155I=1,N WRITE(ICOUT,156)I,Y(I),W(I) 156 FORMAT('I,Y(I),W(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 155 CONTINUE DO165I=1,N WRITE(ICOUT,166)I,(XMAT(I,J),J=1,MIN(5,NVARS)) 166 FORMAT('I,(XMAT(I,J),J=1,MIN(NVARS,5) = ',I8,5E15.7) CALL DPWRST('XXX','BUG ') 165 CONTINUE ENDIF IENDF4='OFF' IREWI4='ON' CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1 IENDF4,IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C CALL DPJBS3(Y,N,ICASJB,IRESAM,ISEED,TEMP1,N2,ITEMP1, 1 TEMP4,IBUGA3,IERROR) C DO120J=1,N Y(J)=TEMP1(J) TEMP2(J)=W(ITEMP1(J)) 120 CONTINUE DO125J=1,N W(J)=TEMP2(J) 125 CONTINUE C DO130L=1,NVARS DO135J=1,N TEMP3(J)=XMAT(ITEMP1(J),L) 135 CONTINUE DO138J=1,N XMAT(J,L)=TEMP3(J) 138 CONTINUE 130 CONTINUE C CALL LSQRTX(Y,W,N,XMAT,MAXOBV,NPAR,IT, 1 B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID, 1 IBUGA3,ISUBRO,IERROR) C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN WRITE(ICOUT,142) 142 FORMAT('FROM DPBOFI, BEFORE WRITE TO FILES') CALL DPWRST('XXX','BUG ') ENDIF WRITE(IOUNI1,'(35E15.7)')(B(LL),LL=1,NPAR) WRITE(IOUNI2,'(35E15.7)')(T(LL),LL=1,NPAR) WRITE(IOUNI3,'(E15.7)')RESSD C 110 CONTINUE ELSE C C ***************************************************** C ** STEP 3-- ** C ** BOOTSTRAP FIT BY "RESIDUAL" METHOD ** C ***************************************************** C C C GENERATE FIT FROM ORIGINAL DATA C CALL LSQRTX(Y,W,N,XMAT,MAXOBV,NPAR,IT, 1 B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID, 1 IBUGA3,ISUBRO,IERROR) DO710I=1,NPAR BORG(I)=B(I) TORG(I)=T(I) 710 CONTINUE C C COMPUTE AND STORE RESIDUALS FROM ORIGINAL FIT C DO720I=1,N DSUM1=0.0 DO725J=1,NPAR DSUM1 = DSUM1 + DBLE(BORG(J)*XMAT(I,J)) 725 CONTINUE RES1(I) = Y(I) - REAL(DSUM1) 720 CONTINUE C C RESAMPLE RESIDUALS, COMPUTE NEW Y (XMAT STAYS CONSTANT, SO C NO NEED TO SAVE/RELOAD ORIGINAL X MATRIX). C DO610IRESAM=1,NRESAM IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN WRITE(ICOUT,662)IRESAM 662 FORMAT('FROM DPBOFI, IRESAM = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C CALL DPJBS3(RES1,N,ICASJB,IRESAM,ISEED,RES2,N2,ITEMP1, 1 TEMP4,IBUGA3,IERROR) C DO620I=1,N DSUM1=0.0 DO625J=1,NPAR DSUM1 = DSUM1 + DBLE(BORG(J)*XMAT(I,J)) 625 CONTINUE TEMP3(I) = RES2(I) + REAL(DSUM1) 620 CONTINUE C CALL LSQRTX(TEMP3,W,N,XMAT,MAXOBV,NPAR,IT, 1 B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID, 1 IBUGA3,ISUBRO,IERROR) C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN WRITE(ICOUT,642) 642 FORMAT('FROM DPBOF2, BEFORE WRITE TO FILES') CALL DPWRST('XXX','BUG ') ENDIF WRITE(IOUNI1,'(35E15.7)')(B(LL),LL=1,NPAR) WRITE(IOUNI2,'(35E15.7)')(T(LL),LL=1,NPAR) WRITE(IOUNI3,'(E15.7)')RESSD C 610 CONTINUE ENDIF C C ************************************** C ** STEP 4-- ** C ** CLOSE THE STORAGE FILES. ** C ************************************** C 8200 CONTINUE C ISTEPN='82' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IENDF3='OFF' IREWI3='ON' CALL DPCLFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IENDF3,IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C ********************************************* C ** STEP 5-- ** C ** COMPUTE AND PRINT SUMMARY INFORMATION. ** C ********************************************* C 8500 CONTINUE C ISTEPN='85' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C REOPEN DPST1F.DAT, DPST2F.DAT TO RETRIEVE PARAMETER AND C PARAMETER SD ESTIMATES. C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='BOF2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='BOF2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IWRITE='OFF' DO8510J=1,NPAR DO8520I=1,NRESAM READ(IOUNI1,'(35E15.7)',END=8599,ERR=8599)(B(LL),LL=1,NPAR) READ(IOUNI2,'(35E15.7)',END=8599,ERR=8599)(T(LL),LL=1,NPAR) TEMP1(I)=B(J) TEMP2(I)=T(J) 8520 CONTINUE CALL MEDIAN(TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV,XMED, 1 IBUGA3,IERROR) CALL MEAN(TEMP1,NRESAM,IWRITE,XMEAN,IBUGA3,IERROR) CALL MEAN(TEMP2,NRESAM,IWRITE,XSD,IBUGA3,IERROR) P100=2.5 CALL PERCEN(P100,TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV, 1 X025,IBUGA3,IERROR) P100=97.5 CALL PERCEN(P100,TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV, 1 X975,IBUGA3,IERROR) IPARNM(1:3)='A ' IF(J.LE.9)THEN WRITE(IPARNM(2:2),'(I1)')J-1 ELSE WRITE(IPARNM(2:3),'(I2)')J-1 ENDIF WRITE(ICOUT,8529)IPARNM,BORG(J),TORG(J),XMEAN,XSD,X025,X975 8529 FORMAT(A3,3X,6(E12.5)) CALL DPWRST('XXX','BUG ') REWIND(IOUNI1) REWIND(IOUNI2) 8510 CONTINUE 8599 CONTINUE C IENDF1='OFF' IREWI1='ON' CALL DPCLFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IENDF1,IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IENDF2='OFF' IREWI2='ON' CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IENDF2,IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C C C C **************************************************** C ** STEP 6-- ** C ** WRITE INFO OUT TO FILES-- ** C ** 1) DPST1F.DAT--XXXXX ** C **************************************************** C 8100 CONTINUE C ISTEPN='81' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO8119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112) 8112 FORMAT('COEFFICIENT ESTIMATES WRITTEN TO FILE DPST1F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT('COEFFICIENT STANDARD DEVIATIONS WRITTEN TO FILE ', 1 'DPST2F.DAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8116) 8116 FORMAT('RESIDUAL STANDARD DEVIATIONS WRITTEN TO FILE ', 1 'DPST3F.DAT') CALL DPWRST('XXX','BUG ') 8119 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO8129 8129 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE C CCCCC BE SURE TO RESET DPST4F.DAT TO FORMATTED. C IFORM4='FORMATTED' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'BOF2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBOF2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR 9012 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFPA, 1MAXBOX,IBOFPA,IFOUND,IERROR) C C PURPOSE--DEFINE THE FILL PATTERN FOR A BOX. C THE FILL PATTERN FOR A BOX IS THE PATTERN C THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX. C THE PATTERN FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR IBOFPA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFPA C --MAXBOX C OUTPUT ARGUMENTS--IBOFPA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C PATTERN FOR BOX I. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFPA CHARACTER*4 IBOFPA CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IBOFPA(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'PATT') 1GOTO1110 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'PATT') 1GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1123 IF(IHARG(3).EQ.'SOLI')GOTO1123 IF(IHARG(3).EQ.'EMPT')GOTO1124 IF(IHARG(3).EQ.'OFF')GOTO1124 IF(IHARG(3).EQ.'BLAN')GOTO1124 IF(IHARG(3).EQ.'NONE')GOTO1124 IF(IHARG(3).EQ.'HOLL')GOTO1124 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFPA GOTO1130 C 1123 CONTINUE IHOLD='ON' GOTO1130 C 1124 CONTINUE IHOLD='OFF' GOTO1130 C 1125 CONTINUE IHOLD=IHARG(3) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX IBOFPA(I)=IHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)IBOFPA(I) 1136 FORMAT('ALL BOX FILL PATTERNS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOFP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... FILL PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 FILL PATTERN ON') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOFP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... FILL PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1173 IF(IHARG(4).EQ.'SOLI')GOTO1173 IF(IHARG(4).EQ.'OFF')GOTO1174 IF(IHARG(4).EQ.'EMPT')GOTO1174 IF(IHARG(4).EQ.'BLAN')GOTO1174 IF(IHARG(4).EQ.'NONE')GOTO1174 IF(IHARG(4).EQ.'HOLL')GOTO1174 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFPA GOTO1180 C 1173 CONTINUE IHOLD='ON' GOTO1180 C 1174 CONTINUE IHOLD='OFF' GOTO1180 C 1175 CONTINUE IHOLD=IHARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOFPA(I)=IHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,IBOFPA(I) 1186 FORMAT('THE FILL PATTERN FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 1MAXBOX,PBOFTH,IFOUND,IERROR) C C PURPOSE--DEFINE THE THICKNESS FOR A BOX. C THE THICKNESS FOR A BOX IS THE THICKNESS C THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX. C THE THICKNESS FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PBOFTH(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFTH C --MAXBOX C OUTPUT ARGUMENTS--PBOFTH (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C THICKNESS FOR BOX I. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT REAL PDEFTH REAL PBOFTH CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PBOFTH(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'THIC') 1GOTO1110 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'THIC') 1GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1120 IF(IHARG(3).EQ.'OFF')GOTO1120 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFTH GOTO1130 C 1125 CONTINUE PHOLD=ARG(3) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX PBOFTH(I)=PHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PBOFTH(I) 1136 FORMAT('ALL BOX FILL THICKNESSS HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOFT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... FILL THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 FILL THICKNESS 0.3') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOFT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... FILL THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1170 IF(IHARG(4).EQ.'OFF')GOTO1170 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFTH GOTO1180 C 1175 CONTINUE PHOLD=ARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' PBOFTH(I)=PHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PBOFTH(I) 1186 FORMAT('THE FILL THICKNESS FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA, 1MAXBOX,PBOPGA,IFOUND,IERROR) C C PURPOSE--DEFINE THE GAP FOR A BOX. C THE GAP FOR A BOX IS THE GAP C BETWEEN THE LINES OF A REGION FILL PATTERN. C THE GAP FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PBOPGA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFGA C --MAXBOX C OUTPUT ARGUMENTS--PBOPGA (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C GAP FOR BOX I. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT REAL PDEFGA REAL PBOPGA CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PBOPGA(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'GAP') 1GOTO1110 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'GAP') 1GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1120 IF(IHARG(3).EQ.'OFF')GOTO1120 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFGA GOTO1130 C 1125 CONTINUE PHOLD=ARG(3) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX PBOPGA(I)=PHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PBOPGA(I) 1136 FORMAT('ALL BOX FILL GAPS HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOFG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... FILL GAP COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 FILL GAP 1.0') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOFG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... FILL GAP COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1170 IF(IHARG(4).EQ.'OFF')GOTO1170 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFGA GOTO1180 C 1175 CONTINUE PHOLD=ARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' PBOPGA(I)=PHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PBOPGA(I) 1186 FORMAT('THE FILL GAP FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPBOFL(IHARG,IARGT,IARG,NUMARG,IDEFPA, 1MAXBOX,IBOPPA,IFOUND,IERROR) C C PURPOSE--DEFINE THE LINE PATTERN FOR THE FILL OF C A BOX. THIS ONLY APPLIES FOR NON-SOLID FILL C PATTERNS (E.G., HORI, VERT, ETC.) C THE PATTERN FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR IBOPPA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFPA C --MAXBOX C OUTPUT ARGUMENTS--IBOPPA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C PATTERN FOR BOX I. 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--92/8 C ORIGINAL VERSION--AUGUST 1992. 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 IARGT CHARACTER*4 IDEFPA CHARACTER*4 IBOPPA CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IBOPPA(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'LINE') 1GOTO1110 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.IHARG(3).EQ.'LINE') 1GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1123 IF(IHARG(3).EQ.'SOLI')GOTO1123 IF(IHARG(3).EQ.'EMPT')GOTO1124 IF(IHARG(3).EQ.'OFF')GOTO1124 IF(IHARG(3).EQ.'BLAN')GOTO1124 IF(IHARG(3).EQ.'NONE')GOTO1124 IF(IHARG(3).EQ.'HOLL')GOTO1124 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFPA GOTO1130 C 1123 CONTINUE IHOLD='SOLI' GOTO1130 C 1124 CONTINUE IHOLD='BLAN' GOTO1130 C 1125 CONTINUE IHOLD=IHARG(3) IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD='DA5' GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX IBOPPA(I)=IHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)IBOPPA(I) 1136 FORMAT('ALL BOX FILL LINES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... FILL LINE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 FILL LINE ON') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOFL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... FILL LINE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1173 IF(IHARG(4).EQ.'SOLI')GOTO1173 IF(IHARG(4).EQ.'OFF')GOTO1174 IF(IHARG(4).EQ.'EMPT')GOTO1174 IF(IHARG(4).EQ.'BLAN')GOTO1174 IF(IHARG(4).EQ.'NONE')GOTO1174 IF(IHARG(4).EQ.'HOLL')GOTO1174 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFPA GOTO1180 C 1173 CONTINUE IHOLD='SOLI' GOTO1180 C 1174 CONTINUE IHOLD='BLAN' GOTO1180 C 1175 CONTINUE IHOLD=IHARG(4) IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'5')IHOLD='DA5' GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOPPA(I)=IHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,IBOPPA(I) 1186 FORMAT('THE FILL LINE FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPBOPA(IHARG,IARGT,IARG,NUMARG,IDEFPA, 1MAXBOX,IBOFPA,IFOUND,IERROR) C C PURPOSE--DEFINE THE LINE TYPE FOR THE BORDER BOX. C THE PATTERN FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR IBOFPA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFPA C --MAXBOX C OUTPUT ARGUMENTS--IBOFPA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C PATTERN FOR BOX I. 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--SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --AUGUST 1992. FORMAT STATEMENTS 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 IARGT CHARACTER*4 IDEFPA CHARACTER*4 IBOFPA CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION IBOFPA(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PATT')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFPA GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD='DA5' GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX IBOFPA(I)=IHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)IBOFPA(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1136 FORMAT('ALL BOX PATTERNS HAVE JUST BEEN SET TO ', 1136 FORMAT('ALL BOX BORDER PATTERNS HAVE JUST BEEN SET TO ', 1A4) GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 PATTERN SOLID') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOPA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... PATTERN COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFPA GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD='DA5' GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOFPA(I)=IHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,IBOFPA(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1186 FORMAT('THE PATTERN FOR BOX ',I8, 1186 FORMAT('THE BORDER PATTERN FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',A4) GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOSS(IHARG,IARGT,IARG,NUMARG, 1IBOOSS,IDEBOO,IFOUND,IERROR) C C PURPOSE--DEFINE THE BOOTSTRAP SAMPLE SIZE C THE SPECIFIED BOOTSTRAP SAMPLE SIZE WILL BE PLACED C IN THE INTEGER VARIABLE IBOOSS C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --NUMARG (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--IBOOSS (AN INTEGER VARIABLE) 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--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')GOTO1110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1110 GOTO1199 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'SAMP')GOTO1150 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1150 IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 GOTO1120 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPBOSS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' ILLEGAL FORM FOR BOOTSTRAP SAMPLE SIZE ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' EXAMPLES OF ALLOWABLE FORMS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131) 1131 FORMAT(' BOOTSTRAP SAMPLE SIZE 200') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1132) 1132 FORMAT(' BOOTSTRAP SIZE 50') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)IDEBOO 1133 FORMAT(' THE DEFAULT BOOTSTRAP SAMPLE SIZE ', 1'IS ',I8) CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE IHOLD=IDEBOO GOTO1180 C 1160 CONTINUE IHOLD=IARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IBOOSS=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBOOSS 1181 FORMAT('THE BOOTSTRAP SAMPLE SIZE HAS JUST BEEN SET TO ', 1I8) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 1MAXBOX,PBOFTH,IFOUND,IERROR) C C PURPOSE--DEFINE THE THICKNESS FOR A BOX. C THE THICKNESS FOR A BOX IS THE THICKNESS C OF THE BORDER REGION OF THE BOX. C THE THICKNESS FOR BOX I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PBOFTH(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFTH C --MAXBOX C OUTPUT ARGUMENTS--PBOFTH (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C THICKNESS FOR BOX I. 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--SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --AUGUST 1992. FORMAT STATEMENTS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT REAL PDEFTH REAL PBOFTH CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PBOFTH(*) 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'THIC')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFTH GOTO1130 C 1125 CONTINUE PHOLD=ARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXBOX PBOFTH(I)=PHOLD 1135 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PBOFTH(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1136 FORMAT('ALL BOX THICKNESSS HAVE JUST BEEN SET TO ', 1136 FORMAT('ALL BOX BORDER THICKNESSS HAVE JUST BEEN SET TO ', 1E15.7) GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBOTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE BOX ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE BOX IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' BOX 3 THICKNESS 0.3') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPBOTH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE BOX ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXBOX 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFTH GOTO1180 C 1175 CONTINUE PHOLD=ARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' PBOFTH(I)=PHOLD WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PBOFTH(I) CALL DPWRST('XXX','BUG ') CCCCC AUGUST 1992. C1186 FORMAT('THE THICKNESS FOR BOX ',I8, 1186 FORMAT('THE BORDER THICKNESS FOR BOX ',I8, 1' HAS JUST BEEN SET TO ',E15.7) GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBOX(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1ICONT,IFENCE,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE ONE OF THE FOLLOWING 2 BOX PLOTS-- C 1) MEDIAN; C 2) MEAN; 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--JANUARY 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 2002. SUPPORT FOR FIXED WIDTH BOX PLOT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IAND1 CHARACTER*4 IAND2 CHARACTER*4 ICONT CHARACTER*4 IFENCE CHARACTER*4 IBUGG2 CHARACTER*4 IBUGG3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHHOR CHARACTER*4 IHHOR2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CCCCC CHARACTER*4 IH CCCCC CHARACTER*4 IH2 CCCCC CHARACTER*4 IERRO2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION X1(MAXOBV) C DIMENSION XIDTEM(MAXOBV) DIMENSION TEMP(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),X1(1)) EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1)) EQUIVALENCE (GARBAG(IGARB4),TEMP(1)) CCCCC END CHANGE C C-----COMMON---------------------------------------------------------- C 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 IERROR='NO' C ISUBN1='DPBO' ISUBN2='X ' 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 BOX PLOT 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 DPBOX--') 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)ICONT,IBUGG2,IBUGG3,IBUGQ 53 FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IFENCE 54 FORMAT('IFENCE = ',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 C ********************************** C ** STEP 1.1-- ** C ** SEARCH FOR MEDIAN BOX PLOT ** C ********************************** C ICASPL='MDBP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEDI'.AND.IHARG(1).EQ.'BOX'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'BOX'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C C ******************************** C ** STEP 1.2-- ** C ** SEARCH FOR MEAN BOX PLOT ** C ******************************** C ICASPL='MEBP' C IF(NUMARG.GE.2.AND. 1ICOM.EQ.'MEAN'.AND.IHARG(1).EQ.'BOX'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'XBAR'.AND.IHARG(1).EQ.'BOX'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'BOX'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 C ICASPL=' ' C IFOUND='NO' GOTO9000 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 1-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C *********************************************************** C ISTEPN='1' 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 C ******************************************** C ** STEP 2-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='2' 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) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,ICOLL,NLEFT 211 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C C *************************************************************** C ** STEP 3-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C *************************************************************** C ISTEPN='3' 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 DPBOX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDBP')WRITE(ICOUT,321) 321 FORMAT(' (FOR WHICH A (MEDIAN) BOX PLOT ') IF(ICASPL.EQ.'MDBP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEBP')WRITE(ICOUT,322) 322 FORMAT(' (FOR WHICH A MEAN BOX PLOT ') IF(ICASPL.EQ.'MEBP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN FORMED)') 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 4-- ** 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='4' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO480 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 C 480 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,481) 481 FORMAT('***** INTERNAL ERROR IN DPBOX') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,482) 482 FORMAT(' AT BRANCH POINT 481--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,483) 483 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,484) 484 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,485)NUMARG 485 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,486) 486 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH) 487 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ 491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ************************************************************ C ** STEP 5-- ** 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 BOX 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='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(NUMV2.EQ.1)GOTO590 IF(NUMV2.EQ.2)GOTO530 GOTO510 C 510 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,511) 511 FORMAT('***** ERROR IN DPBOX--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDBP')WRITE(ICOUT,512) 512 FORMAT(' FOR A (MEDIAN) BOX PLOT, ') IF(ICASPL.EQ.'MDBP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEBP')WRITE(ICOUT,513) 513 FORMAT(' FOR A MEAN BOX PLOT, ') IF(ICASPL.EQ.'MEBP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518) 518 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,519) 519 FORMAT(' MUST BE EITHER 1 OR 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,520) 520 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,521) 521 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,522)NUMV2 522 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,523) 523 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,524)(IANS(I),I=1,IWIDTH) 524 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 530 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')WRITE(ICOUT,531)IHHOR,ICOLH,NHOR 531 FORMAT('IHHOR,ICOLH,NHOR = ',A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') C IF(NHOR.NE.NLEFT)GOTO570 GOTO590 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPBOX--') CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MDBP')WRITE(ICOUT,572) 572 FORMAT(' FOR A (MEDIAN) BOX PLOT CHART, ') IF(ICASPL.EQ.'MDBP')CALL DPWRST('XXX','BUG ') IF(ICASPL.EQ.'MEBP')WRITE(ICOUT,573) 573 FORMAT(' FOR A MEAN BOX PLOT,') IF(ICASPL.EQ.'MEBP')CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578) 578 FORMAT(' WHEN HAVE 2 VARAIBLES SPECIFIED, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,580) 580 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,581) 581 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,582) 582 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,583) 583 FORMAT(' THE FIRST VARIABLE (RESPONSE VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,584)IHLEFT,NLEFT 584 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,585) 585 FORMAT(' THE SECOND VARIABLE (HORIZ. AXIS VALUES)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,586)IHHOR,NHOR 586 FORMAT(' ',A4,' HAS ',I8,' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,587) 587 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH) 588 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ************************************************* C ** STEP 6-- ** 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='6' IF(IBUGG2.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 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)GOTO660 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) C 660 CONTINUE NLOCAL=J C C **************************************************************** C ** STEP 7-- ** C ** FOR THE 1-VARIABLE CASE ONLY, * C ** DETERMINE IF THE ANALYST ** C ** HAS SPECIFIED THE GROUP SIZE, ** C ** FOR THE BOX 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='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC IF(NUMV2.GE.2)GOTO790 C CCCCC IH='NI ' CCCCC IH2=' ' CCCCC IHWUSE='P' CCCCC MESSAG='YES' CCCCC CALL CHECKN(IH,IH2,IHWUSE, CCCCC1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, CCCCC1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2) CCCCC IERROR=IERRO2 CCCCC IF(IERRO2.EQ.'YES')GOTO9000 CCCCC ISIZE=VALUE(ILOCP)+0.5 CC790 CONTINUE C C C ************************************************************* C ** STEP 8-- ** C ** COMPUTE THE APPROPRIATE BOX PLOT STATISTIC-- ** C ** (MEDIAN OR MEDAN ). ** 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='8' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C 809 CONTINUE CALL DPBOX2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT,IFENCE,IBXPWI, 1XIDTEM,TEMP, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) 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 DPBOX--') 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)IFENCE,ISIZE 9014 FORMAT('IFENCE,ISIZE = ',A4,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 DPBOX2(Y,X,N,NUMV2,ICASPL,ISIZE,ICONT,IFENCE,IBXPWI, 1XIDTEM,TEMP, 1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE A BOX PLOT C OF THE FOLLOWING TYPES-- C 1) (MEDIAN) BOX PLOT; C 2) MEAN BOX 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --JANUARY 1981. C UPDATED --MARCH 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JANUARY 1989. BUG--MULTI-BOX PLOTS W/FENCES (ALAN) C UPDATED --MARCH 2002. SUPPORT FIXED WIDTH BOX PLOTS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IFENCE CHARACTER*4 IBXPWI CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION D2(*) C DIMENSION XIDTEM(*) DIMENSION TEMP(*) INCLUDE 'DPCOPA.INC' 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='DPBO' ISUBN2='X2 ' C I2=0 ISIZE2=0 C AN=0.0 SIZE=0.0 SIZE2=0.0 XWIDTH=0.0 XWIDT2=0.0 YBARI=0.0 SDI=0.0 YMED=0.0 C H=0.0 STEP=0.0 AINNFU=0.0 AOUTFU=0.0 IREV=0 AINNFL=0.0 AOUTFL=0.0 C BUG FIX: AUGUST, 1987 C IF FENCES ON AND MORE THAN ONE SET OF BOX PLOTS DONE, C CAN GET GARBAGE. NEED TO INITIALIZE X2, Y2, D2 DO 10 I=1,MAXOBV X2(I)=0.0 Y2(I)=0.0 D2(I)=0.0 10 CONTINUE C END FIX 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 DPBOX2--') 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 DPBOX2--') 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=Y(1) DO60I=1,N IF(Y(I).NE.HOLD)GOTO69 60 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61) 61 FORMAT('***** ERROR IN DPBOX2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' ALL RESPONSE VARIABLE ELEMENTS') 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')GOTO90 WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF DPBOX2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,NUMV2,ISIZE,ICONT 71 FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT = ',I8,2X,A4,I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)IFENCE 72 FORMAT('IFENCE = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,N WRITE(ICOUT,76)I,Y(I),X(I) 76 FORMAT('I, Y(I), X(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (THE GROUP VARIABLE). ** C ** IF ALL VALUES ARE DISTINCT, THEN THIS ** C ** IMPLIES WE HAVE THE NO REPLICATION CASE ** C ** WHICH IS AN ERROR CONDITION FOR A BOX PLOT. ** C ******************************************************** C ISTEPN='1' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMV2.EQ.1)GOTO110 IF(NUMV2.EQ.2)GOTO150 C 110 CONTINUE CCCCC NUMSET=0 CCCCC DO120I=ISIZE,N,ISIZE CCCCC I2=I CCCCC NUMSET=NUMSET+1 CCCCC XIDTEM(NUMSET)=NUMSET CC120 CONTINUE CCCCC IF(I2.LT.N)GOTO130 CCCCC GOTO140 CC130 CONTINUE CCCCC NUMSET=NUMSET+1 CCCCC XIDTEM(NUMSET)=NUMSET CC140 CONTINUE CCCCC DO145I=1,N CCCCC IGROUP=1+((I-1)/ISIZE) CCCCC IMID=(IGROUP-1)*ISIZE+(ISIZE/2) CCCCC X(I)=IMID CC145 CONTINUE CCCCC GOTO190 DO120I=1,N X(I)=1.0 120 CONTINUE NUMSET=1 XIDTEM(1)=X(1) GOTO190 C 150 CONTINUE NUMSET=0 DO160I=1,N IF(NUMSET.EQ.0)GOTO165 DO170J=1,NUMSET IF(X(I).EQ.XIDTEM(J))GOTO160 170 CONTINUE 165 CONTINUE NUMSET=NUMSET+1 XIDTEM(NUMSET)=X(I) 160 CONTINUE CALL SORT(XIDTEM,NUMSET,XIDTEM) C XID1=XIDTEM(1) XID2=XIDTEM(NUMSET) C 190 CONTINUE C IF(NUMSET.EQ.0)WRITE(ICOUT,191) 191 FORMAT('ERROR IN DPBOX2 SUBROUTINE--NUMSET = 0') IF(NUMSET.EQ.0)CALL DPWRST('XXX','BUG ') IF(NUMSET.EQ.0)GOTO9000 IF(NUMSET.EQ.0)IERROR='YES' C IF(NUMSET.EQ.N)WRITE(ICOUT,192) 192 FORMAT('ERROR IN DPBOX2 SUBROUTINE--NUMSET = N') IF(NUMSET.EQ.N)CALL DPWRST('XXX','BUG ') IF(NUMSET.EQ.N)IERROR='YES' IF(NUMSET.EQ.N)GOTO9000 C C ********************************** C ** STEP 2-- ** C ** IF NECESSARY, ** C ** COMPUTE AVERAGE CLASS SIZE ** C ********************************** C ISTEPN='2' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C AN=N ANUMSE=NUMSET C SIZE=ISIZE SIZE2=SIZE CCCCC IF(NUMV2.NE.1)SIZE2=AN/ANUMSE SIZE2=AN/ANUMSE ISIZE2=SIZE2+0.5 C C *********************************** C ** STEP 3-- ** C ** COMPUTE MINIMUM CLASS WIDTH ** C *********************************** C ISTEPN='3' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMSET.EQ.1)XWIDTH=0.10*XIDTEM(1) IF(NUMSET.EQ.1)GOTO390 XWIDTH=CPUMAX IMAX=NUMSET-1 DO300I=1,IMAX IP1=I+1 XWIDT2=XIDTEM(IP1)-XIDTEM(I) IF(XWIDT2.LT.XWIDTH)XWIDTH=XWIDT2 300 CONTINUE 390 CONTINUE C C ************************************** C ** STEP 4-- ** C ** COMPUTE MAXIMUM SUBSAMPLE SIZE ** C ************************************** C ISTEPN='4' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NIMAX=0 DO400ISET=1,NUMSET C K=0 DO420I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 420 CONTINUE NI=K IF(NI.GT.NIMAX)NIMAX=NI C 400 CONTINUE ANIMAX=NIMAX C C ************************************************************** C ** STEP 5-- ** C ** IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES ** C ** FOR THE DESIRED PLOT, ** C ** FIRST BRANCH TO THE PROPER SUBCASE-- ** C ** 1) (MEDIAN) BOX PLOT; ** C ** 2) MEAN BOX PLOT; ** C ************************************************************** C ISTEPN='5' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'MDBP')GOTO1100 IF(ICASPL.EQ.'MEBP')GOTO1100 C 260 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,261) 261 FORMAT('***** INTERNAL ERROR IN DPBOX2') 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 2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,264) 264 FORMAT(' MDBP OR MEBP,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,266)ICASPL 266 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C *************************************************** C ** STEP 5A-- ** C ** DETERMINE PLOT COORDINATES FOR 2 SUBCASES-- ** C ** 1) (MEDIAN) BOX PLOT; ** C ** 2) MEAN BOX PLOT; ** C *************************************************** C 1100 CONTINUE C ISTEPN='4A' IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMCPL=11 J=0 JD=0 DO1110ISET=1,NUMSET C K=0 DO1120I=1,N IF(X(I).EQ.XIDTEM(ISET))K=K+1 IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I) 1120 CONTINUE NI=K ANI=NI C IF(NI.LE.0)GOTO1140 CALL SORT(TEMP,NI,TEMP) C XMID=XIDTEM(ISET) C CCCCC MARCH 2002: SUPPORT EITHER FIXED OR VARIABLE WIDTH CCCCC BOX PLOTS. IF(IBXPWI.EQ.'FIXE')THEN FACTOR=1.0 ELSE FACTOR=SQRT(ANI/ANIMAX) ENDIF XLEFT=XMID-(XWIDTH/4.0)*FACTOR XRIGHT=XMID+(XWIDTH/4.0)*FACTOR C C *************************** C ** STEP 5.1-- ** C ** COMPUTE THE MAXIMUM ** C *************************** C YMAX=TEMP(NI) C C *********************************************** C ** STEP 5.2-- ** C ** COMPUTE THE POINT AT THE TOP OF THE BOX ** C ** (THE UPPER HINGE FOR A MEDIAN BOX PLOT) ** C ** (XBAR + 2 STANDARD DEVIATIONS ** C ** FOR A MEAN BOX PLOT) ** C *********************************************** C IF(ICASPL.EQ.'MDBP')GOTO1121 IF(ICASPL.EQ.'MEBP')GOTO1122 C 1121 CONTINUE NI2=(NI+1)/2 IARG1=(NI2+1)/2 IARG2=(NI2+1)-IARG1 IARG1R=NI-IARG1+1 IARG2R=NI-IARG2+1 Y75=(TEMP(IARG1R)+TEMP(IARG2R))/2.0 GOTO1129 C 1122 CONTINUE SUM=0.0 DO1124I=1,NI SUM=SUM+TEMP(I) 1124 CONTINUE YBARI=SUM/ANI C SUM=0.0 DO1126I=1,NI SUM=SUM+(TEMP(I)-YBARI)**2 1126 CONTINUE DENOM=ANI-1.0 VARI=0.0 IF(NI.GE.2)VARI=SUM/DENOM SDI=0.0 IF(VARI.GT.0.0)SDI=SQRT(VARI) Y75=YBARI+2.0*SDI 1129 CONTINUE C C *************************************** C ** STEP 5.3-- ** C ** COMPUTE UPPER CONFIDENCE LIMITS ** C ** FOR THE MEAN ** C *************************************** C IF(ICASPL.EQ.'MDBP')YUCL=Y75 IF(ICASPL.EQ.'MEBP')YUCL=YBARI+2.0*SDI/SQRT(ANI) C C ********************************* C ** STEP 5.4-- ** C ** COMPUTE THE TYPICAL VALUE ** C ** (MEDIAN OR MEAN) ** C ********************************* C IF(ICASPL.EQ.'MDBP')GOTO1131 IF(ICASPL.EQ.'MEBP')GOTO1132 C 1131 CONTINUE N50=NI/2 N50P1=N50+1 IEVODD=NI-2*(NI/2) IF(IEVODD.EQ.0)YMED=(TEMP(N50)+TEMP(N50P1))/2.0 IF(IEVODD.EQ.1)YMED=TEMP(N50P1) Y50=YMED GOTO1133 C 1132 CONTINUE Y50=YBARI GOTO1133 C 1133 CONTINUE C C **************************************************** C ** STEP 5.5-- ** C ** COMPUTE LOWER CONFIDENCE LIMITS FOR THE MEAN ** C **************************************************** C IF(ICASPL.EQ.'MDBP')YLCL=Y50 IF(ICASPL.EQ.'MEBP')YLCL=YBARI-2.0*SDI/SQRT(ANI) C C **************************************************** C ** STEP 5.6-- ** C ** COMPUTE THE POINT AT THE BOTTOM OF THE BOX ** C ** (THE LOWER HINGE FOR A MEDIAN BOX PLOT) ** C ** (XBAR - 2 STANDARD DEVIATIONS ** C ** FOR A MEAN BOX PLOT) ** C **************************************************** C IF(ICASPL.EQ.'MDBP')GOTO1135 IF(ICASPL.EQ.'MEBP')GOTO1136 C 1135 CONTINUE NI2=(NI+1)/2 IARG1=(NI2+1)/2 IARG2=(NI2+1)-IARG1 Y25=(TEMP(IARG1)+TEMP(IARG2))/2.0 GOTO1137 C 1136 CONTINUE Y25=YBARI-2.0*SDI GOTO1137 C 1137 CONTINUE C C *************************** C ** STEP 5.7-- ** C ** COMPUTE THE MINIMUM ** C *************************** C YMIN=TEMP(1) C GOTO1149 C 1140 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** INTERNAL ERROR IN DPBOX2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT('NI FOR SOME CLASS = 0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143)ISET,XIDTEM(ISET),NI 1143 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1149 CONTINUE C C ********************************************************* C ** STEP 5.7A-- ** C ** FOR THE UPPER HALF OF THE DATA-- ** C ** COMPUTE THE OUTER FENCE, THE INNER FENCE, AND THE ** C ** ADJACENT VALUE ** C ********************************************************* C H=Y75-Y25 STEP=1.5*H C AINNFU=Y75+STEP AOUTFU=Y75+2.0*STEP YADJU=Y75 DO1155I=1,NI IREV=NI-I+1 IF(TEMP(IREV).LE.AINNFU)GOTO1156 1155 CONTINUE GOTO1159 1156 CONTINUE YADJU=TEMP(IREV) 1159 CONTINUE IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1157)Y75,YADJU,TEMP(IREV),IREV 1157 FORMAT('Y75,YADJU,TEMP(IREV),IREV = ',3E15.7,I8) IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ') C C ********************************************************* C ** STEP 5.7B-- ** C ** FOR THE LOWER HALF OF THE DATA-- ** C ** COMPUTE THE OUTER FENCE, THE INNER FENCE, AND THE ** C ** ADJACENT VALUE ** C ********************************************************* C AINNFL=Y25-STEP AOUTFL=Y25-2.0*STEP YADJL=Y25 DO1165I=1,NI I2=I IF(TEMP(I2).GE.AINNFL)GOTO1166 1165 CONTINUE GOTO1169 1166 CONTINUE YADJL=TEMP(I2) 1169 CONTINUE C 1170 CONTINUE C C ******************************************** C ** STEP 6.1-- ** C ** IF IFENCE IS OFF, THEN ** C ** DEFINE THE CHARACTER AT THE MAXIMUM. ** C ** IF IFENCE IS ON, THEN ** C ** DEFINE THE CHARACTER AT THE UPPER ADJACENT VALUE; ** C ******************************************** C IF(IFENCE.EQ.'OFF') 1CALL DPCHLI(ICONT,NUMCPL,YMAX,YMAX,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) IF(IFENCE.EQ.'ON') 1CALL DPCHLI(ICONT,NUMCPL,YADJU,YADJU,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C **************************************** C ** STEP 6.2-- ** C ** DEFINE THE CHARACTER AT THE TOP ** C ** OF THE BOX ** C ** (UPPER HINGE CHARACTER, IF ANY). ** C **************************************** C CALL DPCHLI(ICONT,NUMCPL,Y75,Y75,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C **************************************************************** C ** STEP 6.3-- ** C ** DEFINE THE CHARACTER IN THE BOX ** C ** BUT TOWARDS THE TOP OF THE BOX ** C ** (SUCH AS AN UPPER CONFIDENCE LIMIT FOR THE MEAN, IF ANY) ** C **************************************************************** C CALL DPCHLI(ICONT,NUMCPL,YUCL,YUCL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C *************************************** C ** STEP 6.4-- ** C ** DEFINE THE CHARACTER IN THE BOX ** C ** NEAR THE MIDDLE ** C ** (SUCH AS THE MEDIAN OR MEAN) ** C *************************************** C CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C *************************************************************** C ** STEP 6.5-- ** C ** DEFINE THE CHARACTER IN THE BOX ** C ** BUT TOWARDS THE BOX OF THE BOX ** C ** (SUCH AS A LOWER CONFIDENCE LIMIT FOR THE MEAN, IF ANY) ** C *************************************************************** C CALL DPCHLI(ICONT,NUMCPL,YLCL,YLCL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ****************************************** C ** STEP 6.6-- ** C ** DEFINE THE CHARACTER AT THE BOTTOM ** C ** OF THE BOX ** C ** (LOWER HINGE CHARACTER, IF ANY). ** C ****************************************** C CALL DPCHLI(ICONT,NUMCPL,Y25,Y25,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ******************************************** C ** STEP 6.7-- ** C ** IF IFENCE IS OFF, THEN ** C ** DEFINE THE CHARACTER AT THE MINIMUM. ** C ** IF IFENCE IS ON, THEN ** C ** DEFINE THE CHARACTER AT THE LOWER ADJACENT VALUE; ** C ******************************************** C IF(IFENCE.EQ.'OFF') 1CALL DPCHLI(ICONT,NUMCPL,YMIN,YMIN,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) IF(IFENCE.EQ.'ON') 1CALL DPCHLI(ICONT,NUMCPL,YADJL,YADJL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ************************************* C ** STEP 6.8-- ** C ** IF IFENCE IS OFF, THEN ZZ C ** DEFINE THE VERTICAL LINE FROM ** C ** THE MAXIMUM VALUE TO THE TOP OF THE BOX ** C ** IF IFENCE IS ON, THEN ZZ C ** DEFINE THE VERTICAL LINE FROM ** C ** THE UPPER ADJACENT VALUE TO THE TOP OF THE BOX ** C ************************************* C IF(IFENCE.EQ.'OFF') 1CALL DPCHLI(ICONT,NUMCPL,YMAX,Y75,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) IF(IFENCE.EQ.'ON') 1CALL DPCHLI(ICONT,NUMCPL,YADJU,Y75,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ******************************************************* C ** STEP 6.9-- ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE TOP OF THE BOX (THE UPPER HINGE POINT) ** C ** TO THE POINT IN THE BOX TOWARD THE TOP ** C ** (SUCH AS THE UPPER CONFIDENCE LIMIT POINT) ** C ******************************************************* C CALL DPCHLI(ICONT,NUMCPL,Y75,YUCL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ************************************************** C ** STEP 6.10-- ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE POINT IN THE BOX TOWARD THE TOP ** C ** (SUCH AS THE UPPER CONFIDENCE LIMIT POINT) ** C ** TO THE POINT IN THE BOX ** C ** IN THE MIDDLE ** C ** (SUCH AS THE MEDIAN OR MEAN) ** C ************************************************** C CALL DPCHLI(ICONT,NUMCPL,YUCL,Y50,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ************************************************** C ** STEP 6.11-- ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE POINT IN THE BOX ** C ** IN THE MIDDLE ** C ** (SUCH AS THE MEDIAN OR MEAN) ** C ** TO THE POINT IN THE BOX TOWARD THE BOTTOM ** C ** (SUCH AS THE LOWER CONFIDENCE LIMIT POINT) ** C ************************************************** C CALL DPCHLI(ICONT,NUMCPL,Y50,YLCL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ******************************************************** C ** STEP 6.12-- ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE POINT IN THE BOX TOWARD THE BOTTOM ** C ** (SUCH AS THE LOWER CONFIDENCE LIMIT POINT) ** C ** TO THE BOTTOM OF THE BOX (THE LOWER HINGE POINT) ** C ******************************************************** C CALL DPCHLI(ICONT,NUMCPL,YLCL,Y25,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ********************************** C ** STEP 6.13-- ** C ** IF IFENCE IS OFF, THEN ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE BOTTOM OF THE BOX ** C ** TO THE MINIMUM VALUE ** C ** IF IFENCE IS ON, THEN ** C ** DEFINE THE VERTICAL LINE ** C ** FROM THE BOTTOM OF THE BOX ** C ** TO THE LOWER ADJACENT VALUE ** C ********************************** C IF(IFENCE.EQ.'OFF') 1CALL DPCHLI(ICONT,NUMCPL,Y25,YMIN,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) IF(IFENCE.EQ.'ON') 1CALL DPCHLI(ICONT,NUMCPL,Y25,YADJL,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) C C ********************************************* C ** STEP 6.14-- ** C ** DEFINE THE VERTICAL LINE ** C ** CONSTITUTING THE LEFT SIDE OF THE BOX ** C ** WHICH GOES FROM THE TOP OF THE BOX ** C ** TO THE BOTTOM OF THE BOX ** C ********************************************* C CALL DPCHLI(ICONT,NUMCPL,Y75,Y25,XLEFT,XLEFT,J,JD,Y2,X2,D2, 1IERROR) C C ********************************************** C ** STEP 6.15-- ** C ** DEFINE THE VERTICAL LINE ** C ** CONSTITUTING THE RIGHT SIDE OF THE BOX ** C ** WHICH GOES FROM THE TOP OF THE BOX ** C ** TO THE BOTTOM OF THE BOX ** C ********************************************** C CALL DPCHLI(ICONT,NUMCPL,Y75,Y25,XRIGHT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C *********************************************** C ** STEP 6.16-- ** C ** DEFINE THE HORIZONTAL LINE ** C ** AT THE TOP OF THE BOX ** C ** (RUNNING THROUGH THE UPPER HINGE POINT) ** C *********************************************** C CALL DPCHLI(ICONT,NUMCPL,Y75,Y75,XLEFT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C **************************************************** C ** STEP 6.17-- ** C ** DEFINE THE HORIZONTAL LINE ** C ** IN THE BOX ** C ** (RUNNING THROUGH THE UPPER CONFIDENCE LIMIT) ** C **************************************************** C CALL DPCHLI(ICONT,NUMCPL,YUCL,YUCL,XLEFT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C ********************************************* C ** STEP 6.18-- ** C ** DEFINE THE HORIZONTAL LINE ** C ** IN THE BOX ** C ** (RUNNING THROUGHT THE MEDIAN OR MEAN) ** C ********************************************* C CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XLEFT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C **************************************************** C ** STEP 6.19-- ** C ** DEFINE THE HORIZONTAL LINE ** C ** IN THE BOX ** C ** (RUNNING THROUGH THE LOWER CONFIDENCE LIMIT) ** C **************************************************** C CALL DPCHLI(ICONT,NUMCPL,YLCL,YLCL,XLEFT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C *********************************************** C ** STEP 6.20-- ** C ** DEFINE THE HORIZONTAL LINE ** C ** AT THE BOTTOM OF THE BOX ** C ** (RUNNING THROUGH THE LOWER HINGE POINT) ** C *********************************************** C CALL DPCHLI(ICONT,NUMCPL,Y25,Y25,XLEFT,XRIGHT,J,JD,Y2,X2,D2, 1IERROR) C C ********************************************************* C ** STEP 6.20B-- ** C ** IF A BOX PLOT WITH NO FENCES HAS BEEN CALLED FOR, ** C ** THEN SKIP PAST THE FINAL 4 SPECIFICATIONS. ** C ********************************************************* C IF(IFENCE.EQ.'OFF')GOTO1110 C C ********************************************************* C ** STEP 6.21-- ** C ** DEFINE THE CHARACTER FOR THE UPPER FAR OUT VALUES ** C ** (BEYOND THE UPPER OUTER FENCE) ** C ********************************************************* C YTEMP=Y25 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 C IPASS=0 DO1215I=1,NI IREV=NI-I+1 YTEMP=TEMP(IREV) IF(YTEMP.LE.AOUTFU)GOTO1219 IPASS=IPASS+1 IF(IPASS.EQ.1)J=J-1 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 1215 CONTINUE 1219 CONTINUE JD=JD+1 C C ********************************************************* C ** STEP 6.22-- ** C ** DEFINE THE CHARACTER FOR THE UPPER NEAR OUT VALUES ** C ** (BETWEEN THE UPPER INNER AND OUTER FENCES) C ********************************************************* C YTEMP=Y25 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 C IPASS=0 DO1225I=1,NI IREV=NI-I+1 YTEMP=TEMP(IREV) IF(YTEMP.GE.AOUTFU)GOTO1225 IF(YTEMP.LE.AINNFU)GOTO1229 IPASS=IPASS+1 IF(IPASS.EQ.1)J=J-1 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 1225 CONTINUE 1229 CONTINUE JD=JD+1 C C ********************************************************* C ** STEP 6.23-- ** C ** DEFINE THE CHARACTER FOR THE LOWER NEAR OUT VALUES ** C ** (BETWEEN THE LOWER INNER AND OUTER FENCES) C ********************************************************* C YTEMP=Y25 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 C IPASS=0 DO1235I=1,NI I2=I YTEMP=TEMP(I2) IF(YTEMP.LE.AOUTFL)GOTO1235 IF(YTEMP.GE.AINNFL)GOTO1239 IPASS=IPASS+1 IF(IPASS.EQ.1)J=J-1 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 1235 CONTINUE 1239 CONTINUE JD=JD+1 C C ********************************************************* C ** STEP 6.24-- ** C ** DEFINE THE CHARACTER FOR THE LOWER FAR OUT VALUES ** C ** (BEYOND THE LOWER OUTER FENCE) C ********************************************************* C YTEMP=Y25 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 C IPASS=0 DO1245I=1,NI I2=I YTEMP=TEMP(I2) IF(YTEMP.GE.AOUTFL)GOTO1249 IPASS=IPASS+1 IF(IPASS.EQ.1)J=J-1 CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2, 1IERROR) JD=JD-1 1245 CONTINUE 1249 CONTINUE JD=JD+1 C IF(IBUGG3.EQ.'OFF')GOTO1259 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1251) 1251 FORMAT('***** FROM THE MIDDLE OF DPBOX2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1252)ANI,J,JD,XMID 1252 FORMAT('ANI,J,JD,XMID = ',E15.7,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1253)YMAX,Y75,Y50,Y25,YMIN 1253 FORMAT('YMAX,Y75,Y50,Y25,YMIN = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1254)H,STEP,Y75,YADJU,AINNFU,AOUTFU 1254 FORMAT('H,STEP,Y75,YADJU,AINNFU,AOUTFU = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1255)H,STEP,Y25,YADJL,AINNFL,AOUTFL 1255 FORMAT('H,STEP,Y25,YADJL,AINNFL,AOUTFL = ',6E15.7) CALL DPWRST('XXX','BUG ') 1259 CONTINUE C 1110 CONTINUE C N2=J 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 DPBOX2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR 9012 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IFENCE 9013 FORMAT('IFENCE = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NUMV2,ISIZE,SIZE,SIZE2,ISIZE2 9014 FORMAT('NUMV2,ISIZE,SIZE,SIZE2,ISIZE2 = ',2I8,2E15.7,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)AN,XWIDT2,XWIDTH 9015 FORMAT('AN,XWIDT2,XWIDTH = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)YMAX,Y75,Y50,Y25,YMIN 9021 FORMAT('YMAX,Y75,Y50,Y25,YMIN = ',5E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)H,STEP,Y75,YADJU,AINNFU,AOUTFU 9022 FORMAT('H,STEP,Y75,YADJU,AINNFU,AOUTFU = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)H,STEP,Y25,YADJL,AINNFL,AOUTFL 9023 FORMAT('H,STEP,Y25,YADJL,AINNFL,AOUTFL = ',6E15.7) 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 DPBPCO(IHARG,NUMARG,IDEBPC,MAXBAR,IBAPCO, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR PATTERN COLORS = THE COLORS C OF THE LINES MAKING UP A PATTERN WITHIN A BAR. C THESE ARE LOCATED IN THE VECTOR IBAPCO(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBPC C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBAPCO (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 IDEBPC CHARACTER*4 IBAPCO 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 IBAPCO(*) 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='DPBP' ISUBN2='CO ' C NUMBAR=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 DPBPCO--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPC 55 FORMAT('IDEBPC = ',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)IBAPCO(1) 70 FORMAT('IBAPCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBAPCO(I) 76 FORMAT('I,IBAPCO(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBAPCO(1)=IDEBPC GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPC IBAPCO(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBAPCO(I) 1276 FORMAT('THE COLOR OF BAR PATTERN ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2=IDEBPC IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBPC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPC DO1315I=1,NUMBAR IBAPCO(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)IBAPCO(I) 1316 FORMAT('THE COLOR OF ALL BAR PATTERNS', 1' HAS 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 DPBPCO--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPC 9015 FORMAT('IDEBPC = ',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)IBAPCO(1) 9030 FORMAT('IBAPCO(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBAPCO(I) 9036 FORMAT('I,IBAPCO(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBPLI(IHARG,IHARG2,NUMARG,IDEBPL,MAXBAR,IBAPLI, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPBPLI(IHARG,NUMARG,IDEBPL,MAXBAR,IBAPLI, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES C OF THE PATTERN WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR IBAPLI(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBPL C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBAPLI (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 VERSION--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 IDEBPL CHARACTER*4 IBAPLI 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 IBAPLI(*) 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='DPBP' ISUBN2='LI ' C NUMBAR=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 DPBPLI--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPL 55 FORMAT('IDEBPL = ',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)IBAPLI(1) 70 FORMAT('IBAPLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBAPLI(I) 76 FORMAT('I,IBAPLI(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.2)GOTO9000 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 IF(NUMARG.EQ.5)GOTO1150 GOTO1160 C 1130 CONTINUE GOTO1200 C 1140 CONTINUE IF(IHARG(5).EQ.'ALL')IHOLD1=' ' IF(IHARG(5).EQ.'ALL')GOTO1300 GOTO1200 C 1150 CONTINUE IF(IHARG(5).EQ.'ALL')THEN CCCCC APRIL 1996. CHANGE IHOLD TO IHOLD1 IHOLD1=IHARG(6) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF IF(IHARG(6).EQ.'ALL')THEN IHOLD1=IHARG(5) IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4' IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5' GOTO1300 ENDIF GOTO1200 C 1160 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.3)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBAPLI(1)=' ' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-3 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+3 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=IDEBPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPL IBAPLI(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBAPLI(I) 1276 FORMAT('THE LINE TYPE FOR BAR PATTERN ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPL IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPL DO1315I=1,NUMBAR IBAPLI(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)IBAPLI(I) 1316 FORMAT('THE LINE TYPE FOR ALL BAR PATTERNS', 1' HAS 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 DPBPLI--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPL 9015 FORMAT('IDEBPL = ',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)IBAPLI(1) 9030 FORMAT('IBAPLI(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBAPLI(I) 9036 FORMAT('I,IBAPLI(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBPSP(IHARG,IARGT,ARG,NUMARG,PDEBPS,MAXBAR,PBAPSP, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR PATTERN SPACINGS = THE SPACINGS C BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR PBAPSP(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEBPS C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PBAPSP (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 PBAPSP(*) 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='DPBP' ISUBN2='SP ' C NUMBAR=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 DPBPSP--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)PDEBPS 55 FORMAT('PDEBPS = ',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)PBAPSP(1) 70 FORMAT('PBAPSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PBAPSP(I) 76 FORMAT('I,PBAPSP(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')HOLD1=PDEBPS IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 PBAPSP(1)=PDEBPS GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBPS IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPS IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPS IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPS PBAPSP(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,PBAPSP(I) 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6, 1' HAS JUST BEEN SET TO ',E15.7) 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 NUMBAR=MAXBAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBPS IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPS IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPS IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPS DO1315I=1,NUMBAR PBAPSP(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)PBAPSP(I) 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS', 1' HAS JUST BEEN SET TO ',E15.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 DPBPSP--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)PDEBPS 9015 FORMAT('PDEBPS = ',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)PBAPSP(1) 9030 FORMAT('PBAPSP(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PBAPSP(I) 9036 FORMAT('I,PBAPSP(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBPTH(IHARG,IARGT,ARG,NUMARG,PDEBPT,MAXBAR,PBAPTH, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE BAR PATTERN THICKNESSES = THE THICKNESSES C OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR PBAPTH(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --IARGT (A CHARACTER VECTOR) C --ARG C --NUMARG C --PDEBPT C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--PBAPTH (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 PBAPTH(*) 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='DPBP' ISUBN2='TH ' C NUMBAR=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 DPBPTH--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)PDEBPT 55 FORMAT('PDEBPT = ',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)PBAPTH(1) 70 FORMAT('PBAPTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,PBAPTH(I) 76 FORMAT('I,PBAPTH(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')HOLD1=PDEBPT IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 PBAPTH(1)=PDEBPT GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) HOLD1=ARG(J) HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPT PBAPTH(I)=HOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,PBAPTH(I) 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6, 1' HAS JUST BEEN SET TO ',E15.7) 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 NUMBAR=MAXBAR HOLD2=HOLD1 IF(IHOLD1.EQ.'ON')HOLD2=PDEBPT IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPT IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPT IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPT DO1315I=1,NUMBAR PBAPTH(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)PBAPTH(I) 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS', 1' HAS JUST BEEN SET TO ',E15.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 DPBPTH--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)PDEBPT 9015 FORMAT('PDEBPT = ',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)PBAPTH(1) 9030 FORMAT('PBAPTH(1) = ',E15.7) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,PBAPTH(I) 9036 FORMAT('I,PBAPTH(I) = ',I8,2X,E15.7) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBPTY(IHARG,NUMARG,IDEBPT,MAXBAR,IBAPTY, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES C OF THE PATTERN WITHIN THE BARS. C THESE ARE LOCATED IN THE VECTOR IBAPTY(.). C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEBPT C --MAXBAR C --IBUGP2 ('ON' OR 'OFF' ) C OUTPUT ARGUMENTS--IBAPTY (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 IDEBPT CHARACTER*4 IBAPTY 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 IBAPTY(*) 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='DPBP' ISUBN2='TY ' C NUMBAR=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 DPBPTY--') 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)MAXBAR,NUMBAR 53 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPT 55 FORMAT('IDEBPT = ',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)IBAPTY(1) 70 FORMAT('IBAPTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO75I=1,10 WRITE(ICOUT,76)I,IBAPTY(I) 76 FORMAT('I,IBAPTY(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.1)GOTO9000 IF(NUMARG.EQ.2)GOTO1120 IF(NUMARG.EQ.3)GOTO1130 IF(NUMARG.EQ.4)GOTO1140 GOTO1150 C 1120 CONTINUE GOTO1200 C 1130 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=' ' IF(IHARG(3).EQ.'ALL')GOTO1300 GOTO1200 C 1140 CONTINUE IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4) IF(IHARG(3).EQ.'ALL')GOTO1300 IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3) IF(IHARG(4).EQ.'ALL')GOTO1300 GOTO1200 C 1150 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.2)GOTO1210 GOTO1220 C 1210 CONTINUE NUMBAR=1 IBAPTY(1)=' ' GOTO1270 C 1220 CONTINUE NUMBAR=NUMARG-2 IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR DO1225I=1,NUMBAR J=I+2 IHOLD1=IHARG(J) IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPT IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPT IBAPTY(I)=IHOLD2 1225 CONTINUE GOTO1270 C 1270 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1279 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO1278I=1,NUMBAR WRITE(ICOUT,1276)I,IBAPTY(I) 1276 FORMAT('THE TYPE FOR BAR PATTERN ',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 NUMBAR=MAXBAR IHOLD2=IHOLD1 IF(IHOLD1.EQ.'ON')IHOLD2='SOLI' IF(IHOLD1.EQ.'OFF')IHOLD2=' ' IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPT IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPT DO1315I=1,NUMBAR IBAPTY(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)IBAPTY(I) 1316 FORMAT('THE TYPE FOR ALL BAR PATTERNS', 1' HAS 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 DPBPTY--') 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)MAXBAR,NUMBAR 9013 FORMAT('MAXBAR,NUMBAR = ',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)IDEBPT 9015 FORMAT('IDEBPT = ',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)IBAPTY(1) 9030 FORMAT('IBAPTY(1) = ',A4) CALL DPWRST('XXX','BUG ') DO9035I=1,10 WRITE(ICOUT,9036)I,IBAPTY(I) 9036 FORMAT('I,IBAPTY(I) = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') 9035 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBSCL(IHARG,NUMARG,IDBSCO,IBSPCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D BASEPLANE. C THE COLOR FOR THE BASEPLANE WILL BE PLACED C IN THE CHARACTER VARIABLE IBSPCO. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBSCO C OUTPUT ARGUMENTS--IBSPCO C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBSCO CHARACTER*4 IBSPCO 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IBSPCO=IDBSCO GOTO1180 C 1160 CONTINUE IBSPCO=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBSPCO 1181 FORMAT('THE (3-D) BASEPLANE COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBSGC(IHARG,NUMARG,IDBSGC,IBSPGC,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR THE 3-D BASEPLANE GRID. C THE COLOR FOR THE BASEPLANE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IBSPGC. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBSGC C OUTPUT ARGUMENTS--IBSPGC C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBSGC CHARACTER*4 IBSPGC 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(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 GOTO1160 C 1150 CONTINUE IBSPGC=IDBSGC GOTO1180 C 1160 CONTINUE IBSPGC=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBSPGC 1181 FORMAT('THE (3-D) BASEPLANE GRID COLOR ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBSGP(IHARG,NUMARG,IDBSGP,IBSPGP,IFOUND,IERROR) C C PURPOSE--DEFINE THE PATTERN FOR THE 3-D BASEPLANE GRID. C THE PATTERN FOR THE BASEPLANE GRID WILL BE PLACED C IN THE CHARACTER VARIABLE IBSPGP. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDBSGP C OUTPUT ARGUMENTS--IBSPGP C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGPON, 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBSGP CHARACTER*4 IBSPGP 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(NUMARG.LE.1)GOTO1199 IF(NUMARG.EQ.2)GOTO1160 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1175 C 1150 CONTINUE IBSPGP='SOLI' GOTO1180 C 1160 CONTINUE IBSPGP='BLAN' GOTO1180 C 1170 CONTINUE IBSPGP=IDBSGP GOTO1180 C 1175 CONTINUE IBSPGP=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBSPGP 1181 FORMAT('THE (3-D) BASEPLANE GRID PATTERN ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBSGR(IHARG,NUMARG,IDBSGR,IBSPGR,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D BASEPLANE GRID SWITCH IBSPGR. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDBSGR C OUTPUT ARGUMENTS--IBSPGR ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDBSGR CHARACTER*4 IBSPGR 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(NUMARG.EQ.0)GOTO1199 IF(NUMARG.EQ.1)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170 GOTO1199 C 1150 CONTINUE IBSPGR='ON' GOTO1180 C 1160 CONTINUE IBSPGR='OFF' GOTO1180 C 1170 CONTINUE IBSPGR=IDBSGR GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBSPGR 1181 FORMAT('THE (3-D) BASEPLANE GRID SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBSP(IHARG,NUMARG,IBSPSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 3-D BASEPLANE SWITCH IBSPSW. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IBSPSW ('ON' OR 'OFF') C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C NOTE--THIS SUBROUTINE ASSUMES A C COMPLICATED-TO-SIMPLE CHECKING ORDER C (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS. 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/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IBSPSW 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(NUMARG.EQ.0)GOTO1150 C 1110 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1150 IF(IHARG(NUMARG).EQ.'OFF')GOTO1160 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160 GOTO1199 C 1150 CONTINUE IBSPSW='ON' GOTO1180 C 1160 CONTINUE IBSPSW='OFF' GOTO1180 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181)IBSPSW 1181 FORMAT('THE (3-D) BASEPLANE SWITCH ', 1'HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW, 1MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR) C C PURPOSE--DEFINE THE SHADOW HEIGHT & WIDTH FOR A BOX. C THE SHADOW HEIGHT & WIDTH FOR A BOX IS THE THICKNESS C OF THE SHADOW THAT WILL APPEAR BELOW AND TO THE RIGHT C OF THE BOX. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFSH C --PDEFSW C --MAXBOX C OUTPUT ARGUMENTS--PBOSHE (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C SHADOW HEIGHT FOR BOX I) C --PBOSWI (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C SHADOW WIDTH FOR BOX I) 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/9 C ORIGINAL VERSION--AUGUST 1992. C UPDATED --DECEMBER 1999. ADD "OFF" OPTION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT REAL PDEFSH REAL PDEFSW REAL PBOSHE REAL PBOSWI CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLDH REAL PHOLDW C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PBOSHE(*) DIMENSION PBOSWI(*) 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 C ************************************************** C ** STEP 1-- ** C ** TREAT THE BOX SHADOW HEIGHT CASE ** C ************************************************** C IF(NUMARG.GE.2)THEN IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'HEIG')THEN IF(NUMARG.EQ.2)THEN PHOLDH=PDEFSH GOTO1100 ELSE IF(IHARG(3).EQ.'ON'.OR. CCCCC1 IHARG(3).EQ.'OFF'.OR. 1 IHARG(3).EQ.'AUTO'.OR. 1 IHARG(3).EQ.'DEFA')THEN PHOLDH=PDEFSH GOTO1100 ELSE IF(IHARG(3).EQ.'OFF')THEN PHOLDH=0.0 GOTO1100 ELSE IF(IHARG(3).EQ.'?')THEN GOTO1150 ELSE PHOLDH=ARG(3) GOTO1100 ENDIF ELSEIF(IHARG(2).EQ.'OFF')THEN PHOLDH=0.0 GOTO3100 ENDIF ENDIF ENDIF GOTO1190 C 1100 CONTINUE IFOUND='YES' DO1110I=1,MAXBOX PBOSHE(I)=PHOLDH 1110 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1130)PBOSHE(1) 1130 FORMAT('ALL BOX SHADOW HEIGHTS ', 1'HAVE JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1160)PBOSHE(1) 1160 FORMAT('ALL BOX SHADOW HEIGHTS ', 1'HAVE THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C C ************************************************** C ** STEP 2-- ** C ** TREAT THE BOX SHADOW WIDTH CASE ** C ************************************************** C IF(NUMARG.GE.2)THEN IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'WIDT')THEN IF(NUMARG.EQ.2)THEN PHOLDW=PDEFSW GOTO2100 ELSE IF(IHARG(3).EQ.'ON'.OR. CCCCC1 IHARG(3).EQ.'OFF'.OR. 1 IHARG(3).EQ.'AUTO'.OR. 1 IHARG(3).EQ.'DEFA')THEN PHOLDW=PDEFSW GOTO2100 ELSE IF(IHARG(3).EQ.'OFF')THEN PHOLDW=0.0 GOTO2100 ELSE IF(IHARG(3).EQ.'?')THEN GOTO2150 ELSE PHOLDW=ARG(3) GOTO2100 ENDIF ENDIF ENDIF ENDIF GOTO2190 C 2100 CONTINUE IFOUND='YES' DO2110I=1,MAXBOX PBOSWI(I)=PHOLDW 2110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2130)PBOSWI(1) 2130 FORMAT('ALL BOX SHADOW WIDTHS ', 1'HAVE JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 2150 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2160)PBOSWI(1) 2160 FORMAT('ALL BOX SHADOW WIDTHS ', 1'HAVE THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 2190 CONTINUE C C ************************************************** C ** STEP 3-- ** C ** TREAT THE BOX SHADOW HEIGHT AND WIDTH CASE ** C ************************************************** C IF(NUMARG.GE.2)THEN IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'HW')THEN IF(NUMARG.EQ.2)THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO3100 ELSE IF(IHARG(3).EQ.'ON'.OR. CCCCC1 IHARG(3).EQ.'OFF'.OR. 1 IHARG(3).EQ.'AUTO'.OR. 1 IHARG(3).EQ.'DEFA')THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO3100 ELSE IF(IHARG(3).EQ.'OFF')THEN PHOLDH=0.0 PHOLDW=0.0 GOTO3100 ELSE IF(IHARG(3).EQ.'?')THEN GOTO3150 ELSE PHOLDH=ARG(3) IF(NUMARG.LE.3)PHOLDW=ARG(3) IF(NUMARG.GE.4)PHOLDW=ARG(4) GOTO3100 ENDIF ELSEIF(IHARG(2).EQ.'HW')THEN PHOLDH=0.0 PHOLDW=0.0 GOTO3100 ENDIF ENDIF ENDIF GOTO3190 C 3100 CONTINUE IFOUND='YES' DO3110I=1,MAXBOX PBOSHE(I)=PHOLDH PBOSWI(I)=PHOLDW 3110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3131)PBOSHE(1) 3131 FORMAT('ALL BOX SHADOW HEIGHTS ', 1'HAVE JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3132)PBOSWI(1) 3132 FORMAT('ALL BOX SHADOW WIDTHS ', 1'HAVE JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 3150 CONTINUE IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3161)PBOSHE(1) 3161 FORMAT('ALL BOX SHADOW HEIGHTS ', 1'HAVE THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3162)PBOSWI(1) 3162 FORMAT('ALL BOX SHADOW WIDTHS ', 1'HAVE THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 C 3190 CONTINUE C C ************************************************** C ** STEP 4-- ** C ** TREAT THE BOX ... SHADOW HEIGHT CASE ** C ************************************************** C IF(NUMARG.GE.3)THEN CCCCC IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'SHAD')THEN IF(IHARG(3).EQ.'HEIG')THEN IF(NUMARG.EQ.3)THEN PHOLDH=PDEFSH GOTO4100 ELSE IF(IHARG(4).EQ.'ON'.OR. CCCCC1 IHARG(4).EQ.'OFF'.OR. 1 IHARG(4).EQ.'AUTO'.OR. 1 IHARG(4).EQ.'DEFA')THEN PHOLDH=PDEFSH GOTO4100 ELSE IF(IHARG(4).EQ.'OFF')THEN PHOLDH=0.0 GOTO4100 ELSE IF(IHARG(4).EQ.'?')THEN GOTO4150 ELSE PHOLDH=ARG(4) GOTO4100 ENDIF ENDIF ENDIF ENDIF GOTO4190 C 4100 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4110)I,PBOSHE(1) 4110 FORMAT('THE SHADOW HEIGHT FOR BOX ',I8, 1 ' HAS JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 4150 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4160)I,PBOSHE(I) 4160 FORMAT('THE SHADOW HEIGHT FOR BOX ',I8, 1 ' HAS THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 4190 CONTINUE C C ************************************************** C ** STEP 5-- ** C ** TREAT THE BOX ... SHADOW WIDTH CASE ** C ************************************************** C IF(NUMARG.GE.3)THEN CCCCC IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'SHAD')THEN IF(IHARG(3).EQ.'WIDT')THEN IF(NUMARG.EQ.3)THEN PHOLDW=PDEFSW GOTO5100 ELSE IF(IHARG(4).EQ.'ON'.OR. CCCCC1 IHARG(4).EQ.'OFF'.OR. 1 IHARG(4).EQ.'AUTO'.OR. 1 IHARG(4).EQ.'DEFA')THEN PHOLDW=PDEFSW GOTO5100 ELSE IF(IHARG(4).EQ.'OFF')THEN PHOLDW=0.0 GOTO5100 ELSE IF(IHARG(4).EQ.'?')THEN GOTO5150 ELSE PHOLDW=ARG(4) GOTO5100 ENDIF ENDIF ENDIF ENDIF GOTO5190 C 5100 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' PBOSWI(I)=PHOLDW WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5110)I,PBOSWI(1) 5110 FORMAT('THE SHADOW WIDTH FOR BOX ',I8, 1 ' HAS JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 5150 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5160)I,PBOSWI(I) 5160 FORMAT('THE SHADOW WIDTH FOR BOX ',I8, 1 ' HAS THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 5190 CONTINUE C C ************************************************** C ** STEP 6-- ** C ** TREAT THE BOX ... SHADOW HEIGHT & WIDTH CASE** C ************************************************** C IF(NUMARG.GE.3)THEN CCCCC IF(IHARG(1).EQ.'SHAD')THEN IF(IHARG(2).EQ.'SHAD')THEN IF(IHARG(3).EQ.'HW')THEN IF(NUMARG.EQ.3)THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO6100 ELSE IF(IHARG(4).EQ.'ON'.OR. CCCCC1 IHARG(4).EQ.'OFF'.OR. 1 IHARG(4).EQ.'AUTO'.OR. 1 IHARG(4).EQ.'DEFA')THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO6100 ELSE IF(IHARG(4).EQ.'OFF')THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO6100 ELSE IF(IHARG(4).EQ.'?')THEN GOTO6150 ELSE PHOLDH=ARG(4) IF(NUMARG.LE.4)PHOLDW=ARG(4) IF(NUMARG.GE.5)PHOLDW=ARG(5) GOTO6100 ENDIF ELSEIF(IHARG(3).EQ.'OFF')THEN PHOLDH=PDEFSH PHOLDW=PDEFSW GOTO6100 ENDIF ENDIF ENDIF GOTO6190 C 6100 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' PBOSHE(I)=PHOLDH PBOSWI(I)=PHOLDW WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6110)I,PBOSHE(1) 6110 FORMAT('THE SHADOW HEIGHT FOR BOX ',I8, 1 ' HAS JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6120)I,PBOSWI(1) 6120 FORMAT('THE SHADOW WIDTH FOR BOX ',I8, 1 ' HAS JUST BEEN SET TO ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 6150 CONTINUE IF(IARGT(1).EQ.'NUMB')THEN I=IARG(1) IF(1.LE.I.AND.I.LE.MAXBOX)THEN IFOUND='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6161)I,PBOSHE(I) 6161 FORMAT('THE SHADOW HEIGHT FOR BOX ',I8, 1 ' HAS THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6162)I,PBOSWI(I) 6162 FORMAT('THE SHADOW WIDTH FOR BOX ',I8, 1 ' HAS THE CURRENT VALUE ',F10.4) CALL DPWRST('XXX','BUG ') GOTO9000 ELSE GOTO8200 ENDIF ENDIF GOTO8100 C 6190 CONTINUE GOTO9000 C C ************************************************** C ** STEP 11-- ** C ** WRITE OUT MESSAGES FOR ERROR CONDITIONS C ************************************************** C 8100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8111) 8111 FORMAT('***** ERROR IN DPBSHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8112) 8112 FORMAT(' IN THE BOX ... HEIGHT COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8113) 8113 FORMAT(' IN THE BOX ... WIDTH COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8114) 8114 FORMAT(' IN THE BOX ... HW COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8115) 8115 FORMAT(' THE BOX MUST BE IDENTIFIED BY A NUMBER,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8116) 8116 FORMAT(' AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8117) 8117 FORMAT(' BOX 3 HW 1 .8') CALL DPWRST('XXX','BUG ') GOTO9000 C 8200 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8211) 8211 FORMAT('***** ERROR IN DPBSHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8212) 8212 FORMAT(' IN THE BOX ... HEIGHT COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8213) 8213 FORMAT(' IN THE BOX ... WIDTH COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8214) 8214 FORMAT(' IN THE BOX ... HW COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8216) 8216 FORMAT(' THE NUMBER OF BOXES MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8217)MAXBOX 8217 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8218) 8218 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8219)I 8219 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'BOX.') CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--CARRY OUT BARTLETT TEST C (K-SAMPLE HOMOGENEITY OF VARIANCES) C EXAMPLE--BARTLETT TEST Y X C REFERENCE--DIXON & MASSEY, PAGE 179-180 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--94/12 C ORIGINAL VERSION--DECEMBER 1994. C UPDATED --MAY 1995. BUG FIX C UPDATED --AUGUST 1999. CHANGE DEFINITION TO USE C MORE COMMONLY ACCEPTED C FORM. ADD "DIXON BARTLETT C TEST" TO USE PREVIOUS C DEFINITION. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN 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 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 C CCCCC MAY 1995. ADD FOLLOWING DECLARATIONS CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' 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='DPBT' ISUBN2='ES ' 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 NS1=(-999) NS2=(-999) C IUSE1='-999' IUSE2='-999' C 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 BARTLETT TEST 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 DPBTES--') 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=2 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 SHULD 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) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPBTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR BARTLETT TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1146) 1146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1147) 1147 FORMAT(' ARGUMENT 1 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1148) 1148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1150)(IANS(I),I=1,IWIDTH) 1150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE1=IUSE(ILOCV) ICOL1=IVALUE(ILOCV) N1=IN(ILOCV) 1190 CONTINUE 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 DPBTES--') 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 BARTLETT TEST ') 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 21-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS SHOULD ALSO BE A VARIABLE) ** C **************************************** C ISTEPN='21' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) C IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2141) 2141 FORMAT('***** ERROR IN DPBTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2142) 2142 FORMAT(' FOR BARTLETT TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2145) 2145 FORMAT(' BOTH ARGUMENTS MUST BE A VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2146) 2146 FORMAT(' (AS OPPOSED TO A PARAMETER OR FUNCTION).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2147) 2147 FORMAT(' ARGUMENT 2 WAS NOT A VARIABLE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2148) 2148 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2150)(IANS(I),I=1,IWIDTH) 2150 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IUSE2=IUSE(ILOCV) ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) 2190 CONTINUE C C ******************************************************** C ** STEP 22-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1. ** C ******************************************************** C ISTEPN='22' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IUSE2.NE.'V')GOTO2290 IF(N2.EQ.N1)GOTO2290 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPBTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' (FOR VARIABLE 2 OF BARTLETT TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' MUST BE THE SAME AS VARIABLE 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2216)N1,N2 2216 FORMAT(' N1 = ',I8,' N2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2219) 2219 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2220)(IANS(I),I=1,IWIDTH) 2220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2290 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 DPBTES--') 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 BARTLETT TEST ') 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 NS1=J C 4190 CONTINUE C C *********************************************** C ** STEP 42-- ** C ** TEMPORARILY FORM THE VARIABLE X(.) ** C ** WHICH WILL HOLD THE DATAN FROM SAMPLE 2. ** C ** FORM THIS VARIABLE BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C *********************************************** C IF(IUSE2.NE.'V')GOTO4290 C ISTEPN='42' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO4210 IF(ICASEQ.EQ.'SUBS')GOTO4220 IF(ICASEQ.EQ.'FOR')GOTO4230 C 4210 CONTINUE DO4215I=1,N2 ISUB(I)=1 4215 CONTINUE NQ=N2 GOTO4250 C 4220 CONTINUE NIOLD=N2 CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO4250 C 4230 CONTINUE NIOLD=N2 CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO4250 C 4250 CONTINUE IF(NQ.GE.MINN2)GOTO4260 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4251) 4251 FORMAT('***** ERROR IN DPBTES--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4252) 4252 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4253)IH21,IH22 4253 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4254) 4254 FORMAT(' (FOR WHICH BARTLETT TEST ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4255) 4255 FORMAT(' IS TO BE CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4256)MINN2 4256 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4257)NQ 4257 FORMAT(' SUCH WAS NOT THE CASE HERE. (N = ',I8,')') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4258) 4258 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,4259)(IANS(I),I=1,IWIDTH) 4259 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 4260 CONTINUE J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO4270I=1,IMAX IF(ISUB(I).EQ.0)GOTO4270 J=J+1 C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C 4270 CONTINUE NS2=J C 4290 CONTINUE C C ********************************* C ** STEP 52-- ** C ** DO BARTLETT TEST ** 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 DPBTES, AS WE ARE ABOUT TO CALL DPTTE2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5212)N1,N2,NS1,NS2,MAXN 5212 FORMAT('N1,N2,NS1,NS2,MAXN = ',5I8) CALL DPWRST('XXX','BUG ') DO5215I=1,NS1 WRITE(ICOUT,5216)I,Y(I) 5216 FORMAT('I,Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 5215 CONTINUE DO5217I=1,NS1 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 CALL DPBTE2(Y,X,NS1, 1XTEMP1,XTEMP2,MAXNXT,ICASAN, 1STATVA,STANU1,STANU2,STATCD,CUTL95,CUTU95,CUTL99,CUTU99, 1IBUGA3,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' CCCCC MAY 1995. FIX FOLLOWING LINE CCCCC IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPBT' C IH='STAT' IH2='VAL ' VALUE0=STATVA CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='NU1 ' VALUE0=STANU1 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='NU2 ' VALUE0=STANU2 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='STAT' IH2='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTL' IH2='OW95' VALUE0=CUTL95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP95' VALUE0=CUTU95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTL' IH2='OW99' VALUE0=CUTL99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTU' IH2='PP99' VALUE0=CUTU99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) 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 DPBTES--') 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 SUBROUTINE DPBTE2(Y,TAG,N, 1XTEMP1,XTEMP2,MAXNXT,ICASAN, 1STATVA,STANU1,STANU2,STATCD,CUTL95,CUTU95,CUTL99,CUTU99, 1IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT BARTLETT'S TEST C (K-SAMPLE HOMOSCEDASTICITY TEST) C EXAMPLE--BARTLETT'S TEST Y TAG C REFERENCE--DIXON & MASSEY, PAGE 179-180 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--94/2 C ORIGINAL VERSION--FEBRUARY 1994. C UPDATED --AUGUST 1999. ADD NEW DEFINITION C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION TAG(*) C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION DTAG(1000) DIMENSION YTEMP(1000) DIMENSION ANI(1000) DIMENSION VARI(1000) 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='DPBT' ISUBN2='E2 ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPBTE2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,55)N 55 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I) 57 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE WRITE(ICOUT,65)N 65 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO66I=1,N WRITE(ICOUT,67)I,TAG(I) 67 FORMAT('I,TAG(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 66 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 11-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.GE.1)GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPBTE2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 1 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1112)N 1112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1119 CONTINUE C IF(N.EQ.1)GOTO1120 GOTO1129 1120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1121) 1121 FORMAT('***** NOTE FROM DPBTE2--VARIABLE 1 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1129 CONTINUE C HOLD=Y(1) DO1135I=2,N IF(Y(I).NE.HOLD)GOTO1139 1135 CONTINUE 1130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1131)HOLD 1131 FORMAT('***** NOTE FROM DPBTE2--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C IF(N.GE.1)GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPBTE2--THE NUMBER OF OBSERVATIONS ', 1'FOR VARIABLE 2 IS NON-POSITIVE') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1212)N 1212 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 1219 CONTINUE C IF(N.EQ.1)GOTO1220 GOTO1229 1220 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1221) 1221 FORMAT('***** NOTE FROM DPBTE2--VARIABLE 2 ', 1'HAS ONLY 1 ELEMENT') CALL DPWRST('XXX','WRIT') GOTO9000 1229 CONTINUE C HOLD=TAG(1) DO1235I=2,N IF(TAG(I).NE.HOLD)GOTO1239 1235 CONTINUE 1230 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1231)HOLD 1231 FORMAT('***** NOTE FROM DPBTE2--VARIABLE 2 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1239 CONTINUE C 1290 CONTINUE C IF(ICASAN.EQ.'DMBT')GOTO4100 GOTO5100 C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR BARTLETT'S TEST ** C ** DIXON-MASSEY DEFINITION ** C ****************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR) C KPRIME=0 NPRIME=0 DO4200IDIS=1,NUMDIS J=0 DO4300I=1,N IF(TAG(I).EQ.DTAG(IDIS))THEN J=J+1 YTEMP(J)=Y(I) ENDIF 4300 CONTINUE ANI(IDIS)=J IF(J.GE.2)THEN KPRIME=KPRIME+1 NPRIME=NPRIME+J CALL VAR(YTEMP,J,IWRITE,VARI(IDIS),IBUGA3,IERROR) ENDIF 4200 CONTINUE ANPRIM=NPRIME AKPRIM=KPRIME C TERM1=0.0 TERM2=0.0 TERM3=0.0 DO4400IDIS=1,NUMDIS J=ANI(IDIS)+0.5 IF(J.GE.2)THEN TERM1=TERM1+(ANI(IDIS)-1.0)*VARI(IDIS) TERM2=TERM2+(ANI(IDIS)-1.0)*ALOG(VARI(IDIS)) TERM3=TERM3+(1.0/(ANI(IDIS)-1.0)) ENDIF 4400 CONTINUE C ANUM=TERM1 ADEN=NPRIME-KPRIME VARPOO=ANUM/ADEN C AM=(ANPRIM-AKPRIM)*ALOG(VARPOO)-TERM2 C TERM4=1.0/(3.0*(AKPRIM-1.0)) TERM5=1.0/(ANPRIM-AKPRIM) A=TERM4*(TERM3-TERM5) C ANU1=AKPRIM-1.0 NU1=ANU1+0.5 ANU1=NU1 STANU1=ANU1 C ANU2=(AKPRIM+1.0)/(A**2) NU2=ANU2+0.5 ANU2=NU2 STANU2=ANU2 C B=ANU2/(1.0-A+(2.0/ANU2)) C ANUM=ANU2*AM ADEN=ANU1*(B-AM) STATVA=ANUM/ADEN C CALL FCDF(STATVA,NU1,NU2,STATCD) CUTL95=0.0 CALL FPPF(.95,NU1,NU2,CUTU95) CUTL99=0.0 CALL FPPF(.99,NU1,NU2,CUTU99) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C CCCCC IF(0.000.LE.STATCD.AND.STATCD.LE.0.950)ICONC1='ACCEPT' CCCCC IF(0.025.LE.STATCD.AND.STATCD.LE.0.975)ICONC2='ACCEPT' CCCCC IF(0.050.LE.STATCD.AND.STATCD.LE.1.000)ICONC3='ACCEPT' IF(0.000.LE.STATCD.AND.STATCD.LE.0.950)ICONC2='ACCEPT' C C ****************************** C ** STEP 42-- ** C ** WRITE OUT EVERYTHING ** C ** FOR BARTLETT'S TEST ** C ****************************** C ISTEPN='42' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO4290 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4211) 4211 FORMAT( 1' BARTLETT TEST') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4212) 4212 FORMAT( 1' (DIXON-MASSEY DEFINITION)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4213) 4213 FORMAT('HYPOTHESIS BEING TESTED--ALL SIGMA(I) ARE EQUAL') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4241) 4241 FORMAT('TEST:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4242)ANU1 4242 FORMAT(3X,'DEG. OF FREEDOM (NUMER.) = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4243)ANU2 4243 FORMAT(3X,'DEG. OF FREEDOM (DENOM.) = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4244)STATVA 4244 FORMAT(3X,'TEST STATISTIC VALUE = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4245)CUTU95 4245 FORMAT(3X,'CUTOFF: 95% PERCENT POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4246)CUTU99 4246 FORMAT(3X,'CUTOFF: 99% PERCENT POINT = ',G15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4247)STATCD 4247 FORMAT(3X,'F CDF VALUE = ',F11.6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4259) 4259 FORMAT(' NULL NULL') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4260) 4260 FORMAT(' NULL HYPOTHESIS HYPOTHESIS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4261) 4261 FORMAT(' HYPOTHESIS ACCEPTANCE INTERVAL CONCLUSION') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4262)ICONC2 4262 FORMAT('ALL SIGMA EQUAL (0.000,0.950) ',A6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 4290 CONTINUE GOTO9000 C C ****************************** C ** STEP 51-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR BARTLETT'S TEST ** C ** STANDARD DEFINITION ** C ****************************** C 5100 CONTINUE C ISTEPN='51' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR) C KPRIME=0 NPRIME=0 DO5200IDIS=1,NUMDIS J=0 DO5300I=1,N IF(TAG(I).EQ.DTAG(IDIS))THEN J=J+1 YTEMP(J)=Y(I) ENDIF 5300 CONTINUE ANI(IDIS)=J IF(J.GE.2)THEN KPRIME=KPRIME+1 NPRIME=NPRIME+J CALL VAR(YTEMP,J,IWRITE,VARI(IDIS),IBUGA3,IERROR) ENDIF 5200 CONTINUE ANPRIM=NPRIME AKPRIM=KPRIME C TERM1=0.0 TERM2=0.0 TERM3=0.0 DO5400IDIS=1,NUMDIS J=ANI(IDIS)+0.5 IF(J.GE.2)THEN TERM1=TERM1+(ANI(IDIS)-1.0)*VARI(IDIS) TERM2=TERM2+(ANI(IDIS)-1.0)*ALOG(VARI(IDIS)) TERM3=TERM3+(1.0/(ANI(IDIS)-1.0)) ENDIF 5400 CONTINUE C ANUM=TERM1 ADEN=NPRIME-KPRIME VARPOO=ANUM/ADEN C AM=(ANPRIM-AKPRIM)*ALOG(VARPOO)-TERM2 C TERM4=1.0/(3.0*(AKPRIM-1.0)) TERM5=1.0/(ANPRIM-AKPRIM) A=TERM4*(TERM3-TERM5) C=1.0 + A C ANU1=AKPRIM-1.0 NU1=ANU1+0.5 ANU1=NU1 STANU1=ANU1 C ANU2=0.0 NU2=0 STANU2=ANU2 C STATVA=AM/C C CALL CHSCDF(STATVA,NU1,STATCD) CUTL95=0.0 CALL CHSPPF(.95,NU1,CUTU95) CUTL99=0.0 CALL CHSPPF(.99,NU1,CUTU99) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' C CCCCC IF(0.000.LE.STATCD.AND.STATCD.LE.0.950)ICONC1='ACCEPT' CCCCC IF(0.025.LE.STATCD.AND.STATCD.LE.0.975)ICONC2='ACCEPT' CCCCC IF(0.050.LE.STATCD.AND.STATCD.LE.1.000)ICONC3='ACCEPT' IF(0.000.LE.STATCD.AND.STATCD.LE.0.950)ICONC2='ACCEPT' C C ****************************** C ** STEP 52-- ** C ** WRITE OUT EVERYTHING ** C ** FOR BARTLETT'S TEST ** C ****************************** C ISTEPN='52' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO5290 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5211) 5211 FORMAT( 1' BARTLETT TEST') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5212) 5212 FORMAT( 1' (STANDARD DEFINITION)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5213) 5213 FORMAT('NULL HYPOTHESIS UNDER TEST--ALL SIGMA(I) ', 1'ARE EQUAL') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5241) 5241 FORMAT('TEST:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5242)ANU1 5242 FORMAT(3X,'DEGREES OF FREEDOM = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5244)STATVA 5244 FORMAT(3X,'TEST STATISTIC VALUE = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5245)CUTU95 5245 FORMAT(3X,'CUTOFF: 95% PERCENT POINT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5246)CUTU99 5246 FORMAT(3X,'CUTOFF: 99% PERCENT POINT = ',G15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5247)STATCD 5247 FORMAT(3X,'CHI-SQUARE CDF VALUE = ',F11.6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5260) 5260 FORMAT(' NULL NULL HYPOTHESIS NULL ', 1'HYPOTHESIS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5261) 5261 FORMAT(' HYPOTHESIS ACCEPTANCE INTERVAL CONCLUSION') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5262)ICONC2 5262 FORMAT('ALL SIGMA EQUAL (0.000,0.950) ',A6) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') 5290 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBTE2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9012)N,IBUGA3,IERROR 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,9015)N 9015 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO9016I=1,N WRITE(ICOUT,9017)I,Y(I) 9017 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 9016 CONTINUE WRITE(ICOUT,9025)N 9025 FORMAT('N = ',I8) CALL DPWRST('XXX','WRIT') DO9026I=1,N WRITE(ICOUT,9027)I,TAG(I) 9027 FORMAT('I,TAG(I) = ',I8,E15.7) CALL DPWRST('XXX','WRIT') 9026 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPBUGS(IBUGS2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DISPLAY CONTENTS OF DATAPLOT BUGS FILE. 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--86/1 C ORIGINAL VERSION--OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1985. C UPDATED --APRIL 1992. COMMENT OUT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGS2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IPROT CHARACTER*12 ICURST CHARACTER*4 IENDFI CHARACTER*4 IREWIN CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*80 ISTRIN C C-----COMMON---------------------------------------------------------- C 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='DPBU' ISUBN2='GS ' C IFOUND='YES' IERROR='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'BUGS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBUGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR 53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT APRIL 1992 (ALAN) CCCCC WRITE(ICOUT,54)IWIDTH CCC54 FORMAT('IWIDTH = ',I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IBUGNU 61 FORMAT('IBUGNU = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)IBUGNA 62 FORMAT('IBUGNA = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)IBUGST 63 FORMAT('IBUGST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)IBUGFO 64 FORMAT('IBUGFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IBUGAC 65 FORMAT('IBUGAC = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,66)IBUGFO 66 FORMAT('IBUGFO = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)IBUGCS 67 FORMAT('IBUGCS = ',A12) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************** C ** STEP 11-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=IBUGNU IFILE=IBUGNA ISTAT=IBUGST IFORM=IBUGFO IACCES=IBUGAC IPROT=IBUGPR ICURST=IBUGCS C ISUBN0='BUGS' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'BUGS')GOTO1199 WRITE(ICOUT,1193)IOUNIT 1193 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1194)IFILE 1194 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1196)ISUBN0,IERRFI 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1199 CONTINUE C C **************************************** C ** STEP 12-- ** C ** CHECK TO SEE IF BUGS FILE EXISTS ** C **************************************** C ISTEPN='12' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ISTAT.EQ.'NONE')GOTO1200 GOTO1290 1200 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN DPBUGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' THE DESIRED BUGS FILE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' CANNOT BE LISTED BECAUSE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' THE REQUIRED SYSTEM MASS STORAGE FILE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT(' WHICH STORES ANY BUGS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT(' IS NOT AVAILABLE AT THIS INSTALLATION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1217)ISTAT,IBUGST 1217 FORMAT('ISTAT,IBUGST = ',A12,2X,A12) CALL DPWRST('XXX','BUG ') GOTO9000 1290 CONTINUE C C ********************* C ** STEP 31-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='31' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IREWIN='ON' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERRFI.EQ.'YES')GOTO9000 C C ****************************** C ** STEP 41-- ** C ** READ THE FILE. ** C ** WRITE OUT THE BUGS. ** C ****************************** C ISTEPN='41' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'MESS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ANUMLI=0.0 READ(IOUNIT,4111,END=4190)ANUMLI 4111 FORMAT(F10.0) NUMLIN=ANUMLI+0.5 C IF(NUMLIN.LE.0)GOTO4190 DO4120I=1,NUMLIN READ(IOUNIT,4121,END=4190)(ISTRIN(J:J),J=1,80) 4121 FORMAT(80A1) CALL DPDB80(ISTRIN,JMAX,IBUGS2,ISUBRO,IERROR) IF(JMAX.GE.1)WRITE(ICOUT,4122)(ISTRIN(J:J),J=1,JMAX) 4122 FORMAT(5X,80A1) IF(JMAX.GE.1)CALL DPWRST('XXX','BUG ') IF(JMAX.LE.0)WRITE(ICOUT,999) IF(JMAX.LE.0)CALL DPWRST('XXX','BUG ') 4120 CONTINUE 4190 CONTINUE C C *********************** C ** STEP 51-- ** C ** CLOSE THE FILE. ** C *********************** C ISTEPN='51' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IENDFI='OFF' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'BUGS')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBUGS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR 9012 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IOUNIT 9021 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)IFILE 9022 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)ISTAT 9023 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)IFORM 9024 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)IACCES 9025 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9026)IPROT 9026 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)ICURST 9027 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IENDFI 9028 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IREWIN 9029 FORMAT('IREWIN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)ISUBN0 9031 FORMAT('ISUBN0 = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)IERRFI 9032 FORMAT('IERRFI = ',A12) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPBWCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--GENERATE (SYMMETRIC) CONFIDENCE LIMITS FOR THE MEAN C FOR PROBABILITY VALUE P = .90, .95, .99, .999, AND .9999. C BASED ON BIWEIGHT LOCATION AND SCALE ESTIMATES. 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 REFERENCE--"DATA ANALYSIS AND RGRESSION: A SECOND COURSE IN C STATISTICS", MOSTELLER AND TUKEY, ADDISON-WESLEY, C 1977. 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--2001/11 C ORIGINAL VERSION--NOVEMBER 2001. C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX OUTPUT 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 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IH21 CHARACTER*4 IH22 C CHARACTER*4 ICASAN CHARACTER*4 ICAPSW C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION W(MAXOBV) C INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),W(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='DPBW' ISUBN2='CO ' 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 IF(ICASAN.EQ.'TWOV')MAXV2=2 MINN2=2 C IFOUND='YES' C NLEFT=0 N2=0 C ICASEQ='UNKN' C C ************************************************* C ** TREAT THE BIWEIGHT CONFIDENCE LIMITS CASE ** C ************************************************* C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPBWCO--') 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 ') WRITE(ICOUT,57)ICASAN 57 FORMAT('ICASAN = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL 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 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 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) C C ****************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS ** C ** (NLEFT) FOR THE RESPONSE VARIABLE IS 2 OR MORE. ** C ****************************************************** C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN DPBWCO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FROM WHICH BIWEIGHT CONFIDENCE LIMITS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WERE TO HAVE BEEN CALCULATED)') 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,MAX(IWIDTH,80)) 318 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C **************************************** C ** STEP 3A-- ** C ** CHECK THE VALIDITY OF ARGUMENT 2 ** C ** (THIS MUST BE A VARIABLE ** C **************************************** C ISTEPN='3A' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASAN.NE.'TWOV')GOTO440 IH21=IHARG(2) IH22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IH21,IH22,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOL2=IVALUE(ILOCV) N2=IN(ILOCV) NUMVAR=2 C C ******************************************************** C ** STEP 3B-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS 2 OR MORE. ** C ******************************************************** C ISTEPN='3B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N2.GE.MINN2)GOTO419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** ERROR IN DPBWCO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402) 402 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,403) 403 FORMAT(' A BIWEIGHT CONFIDENCE INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,404) 404 FORMAT(' WAS TO HAVE BEEN CARRIED OUT)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,405)MINN2 405 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,406) 406 FORMAT(' SUCH WAS NOT THE CASE HERE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,407)IH21,IH22 407 FORMAT(' FOR VARIABLE ',A4,A4,' WHICH HAD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,408)N2 408 FORMAT(' NUMBER OF OBSERVATIONS = ',I8,';') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,409) 409 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,411)(IANS(I),I=1,MAX(IWIDTH,80)) 411 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 419 CONTINUE C 440 CONTINUE C C ******************************************************** C ** STEP 3C-- ** C ** IF ARGUMENT 2 IS A VARIABLE, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (N2) ** C ** FOR ARGUMENT 2 IS THE SAME AS ARGUMENT 1 ** C ******************************************************** C ISTEPN='3B' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 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'.OR.ISUBRO.EQ.'ON') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ') GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ') GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ') GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' 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'.OR.ISUBRO.EQ.'BWCO') 1CALL 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,MAX(NLEFT,N2) ISUB(I)=1 515 CONTINUE NQ=MAX(NLEFT,N2) GOTO550 C 520 CONTINUE NIOLD=MAX(NLEFT,N2) CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO550 C 530 CONTINUE NIOLD=MAX(NLEFT,N2) 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 DPBWCO--') 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(' (FROM WHICH BIWEIGHT CONFIDENCE LIMITS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' ARE TO BE CALCULATED)') 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,MAX(IWIDTH,80)) 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 IF(NUMVAR.GE.2)THEN C J=0 IMAX=N2 IF(NQ.LT.N2)IMAX=NQ DO580I=1,IMAX IF(ISUB(I).EQ.0)GOTO580 J=J+1 C IJ=MAXN*(ICOL2-1)+I IF(ICOL2.LE.MAXCOL)X(J)=V(IJ) IF(ICOL2.EQ.MAXCP1)X(J)=PRED(I) IF(ICOL2.EQ.MAXCP2)X(J)=RES(I) IF(ICOL2.EQ.MAXCP3)X(J)=YPLOT(I) IF(ICOL2.EQ.MAXCP4)X(J)=XPLOT(I) IF(ICOL2.EQ.MAXCP5)X(J)=X2PLOT(I) IF(ICOL2.EQ.MAXCP6)X(J)=TAGPLO(I) C 580 CONTINUE NS2=J ENDIF C C ****************************************************** C ** STEP 8-- C ** PREPARE FOR ENTRANCE INTO DPBWCO-- C ** SET THE WEIGHT VECTOR TO UNITY THROUGHOUT. C ****************************************************** C ISTEPN='8' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,NS W(I)=1.0 1110 CONTINUE C C ********************************* C ** STEP 9-- ** C ** FORM THE CONFIDENCE LIMITS ** C ********************************* C ISTEPN='9' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** FROM DPBWCO, AS WE ARE ABOUT TO CALL DPBWC2--') 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 ') ENDIF C C CALL DPBWC2(Y,W,NS,X,NS2,XTEMP1,XTEMP2,MAXNXT, 1ICAPSW,ICAPTY, 1ICASAN,IBUGA3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPBWCO--') 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 ') ENDIF C RETURN END SUBROUTINE DPBWC2(Y,W,N,X,N2,XTEMP1,XTEMP2,MAXNXT, 1ICAPSW,ICAPTY, 1ICASAN,IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS ROUTINE GENERATES BIWEIGHT CONFIDENCE LIMITS C FOR THE DATA IN THE INPUT VECTOR Y. C NOTE--ASSUMPTION--MODEL IS RESPONSE = CONSTANT + ERROR. C NOTE--WEIGHTS AND TWO VARIABLE (=DIFFERENCE OF TWO MEANS) C NOT YET SUPPORTED. ARGUMENTS PASSED FOR POSSIBLE C FUTURE IMPLEMENTATION. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C OF OBSERVATIONS C N = THE INTEGER NUMBER OF C OBSERVATIONS IN THE VECTOR Y. 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--2001/11 C ORIGINAL VERSION--NOVEMBER 2001. C UPDATED --OCTOBER 2003. ADD SUPPORT FOR HTML, LATEX C OUTPUT C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 ICASAN CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*1 IBASLC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION W(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION CONF(10) DIMENSION T(10) DIMENSION TSDM(10) DIMENSION ALOWER(10) DIMENSION AUPPER(10) 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='DPBW' ISUBN2='C2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPBWC2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)N,IBUGA3 52 FORMAT('N,IBUGA3 = ',I8,2X,A4) CALL DPWRST('XXX','WRIT') DO56I=1,N WRITE(ICOUT,57)I,Y(I),W(I),X(I) 57 FORMAT('I,Y(I),W(I),X(I) = ',I8,3E15.7) CALL DPWRST('XXX','WRIT') 56 CONTINUE WRITE(ICOUT,58)ICASAN 58 FORMAT('ICASAN = ',A4) CALL DPWRST('XXX','WRIT') ENDIF C IF(ICASAN.EQ.'TWOV')GOTO9000 C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(N.LE.1)GOTO110 GOTO119 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPBWC2--THE NUMBER OF OBSERVATIONS ', 1'IN THE RESPONSE VARIABLE IS LESS THAN 2') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,112)N 112 FORMAT('SAMPLE SIZE = ',I8) CALL DPWRST('XXX','WRIT') IERROR='YES' GOTO9000 119 CONTINUE C HOLD=Y(1) DO135I=2,N IF(Y(I).NE.HOLD)GOTO139 135 CONTINUE 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,131)HOLD 131 FORMAT('***** NOTE FROM DPBWC2--THE RESPONSE VARIABLE ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 139 CONTINUE C C *************************************************** C ** STEP 3-- ** C ** COMPUTE THE BIWEIGHT LOCATION ESTIMATE ** C ** COMPUTE THE BIWEIGHT SCALE ESTIMATE ** C ** COMPUTE THE SQRT(BIWEIGHT SCALE/N). ** C *************************************************** C C ISTEPN='3' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' C CALL BIWLOC(Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,YBW,IBUGA3,IERROR) CALL BIWSCA(Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,YBSC,IBUGA3,IERROR) AN1=N YSTERR=SQRT(YBSC/AN1) C V=0.7*(AN1-1.0) IV=INT(V+0.5) C C *************************************** C ** STEP 4-- ** C ** COMPUTE CONFIDENCE LIMITS ** C ** FOR VARIOUS PROBABILITY VALUES. ** C *************************************** C ISTEPN='4' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CONF(1)=50.0 CONF(2)=75.0 CONF(3)=90.0 CONF(4)=95.0 CONF(5)=99.0 CONF(6)=99.9 CONF(7)=99.99 CONF(8)=99.999 C DO1400I=1,8 PCONF=CONF(I)/100.0 CDF=0.5+PCONF/2.0 CALL TPPF(CDF,REAL(IV),T(I)) TSDM(I)=T(I)*YSTERR ALOWER(I)=YBW-TSDM(I) AUPPER(I)=YBw+TSDM(I) 1400 CONTINUE C C **************************** C ** STEP 7-- ** C ** WRITE EVERYTHING OUT ** C **************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN CCCCC OCTOBER 2003: WRITE OUTPUT IN HTML FORMAT IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN C C STEP 1: END ASIS MODE AND WRITE A HEADER C 5001 FORMAT('') 5004 FORMAT('

') WRITE(ICOUT,5001) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5004) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START TABLE AND DEFINE A CAPTION C 5011 FORMAT('
    ') 5013 FORMAT('') 5015 FORMAT(' ') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5013) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5015) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5017) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5018) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5019) CALL DPWRST('XXX','WRIT') C C STEP 3: DEFINE DATA ROW C 5041 FORMAT(' ') 5043 FORMAT(' ') 5049 FORMAT(' ') 5051 FORMAT(' Biweight Location:') 5052 FORMAT(' Biweight Scale:') 5053 FORMAT(' Standard Error:') 5054 FORMAT(' Degrees of Freedom:') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5045) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5033)N CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5039) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5031)YBW CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5039) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5031)YBSC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5039) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5053) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5031)YSTERR CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5039) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5054) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5049) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5033)IV CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5047) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5039) CALL DPWRST('XXX','WRIT') C C C STEP 4: END THE TABLE AND RESET ASIS MODE C 5091 FORMAT('
    ') 5017 FORMAT(' Confidence Limits for the Biweight ', 1 'Location
    ') 5018 FORMAT(' (2-Sided)    ') 5019 FORMAT('
    ') 5045 FORMAT(' Number of Observations:') 5047 FORMAT(' ') 5031 FORMAT(' ',G15.7) 5033 FORMAT(' ',I8) 5039 FORMAT('
    ') 5093 FORMAT('
') 5099 FORMAT('
')
        WRITE(ICOUT,5091)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5093)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 2B: START TABLE AND DEFINE A CAPTION
C
        WRITE(ICOUT,5004)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5011)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5013)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 3B: DEFINE HEADER ROW
C
 5121   FORMAT('   ')
 5123   FORMAT('      ')
 5127   FORMAT('      ')
 5139   FORMAT('   ')
 5131   FORMAT('         Confidence
Value (%)')
 5132   FORMAT('         t
Value')
 5133   FORMAT('         t X Standard Error)')
 5134   FORMAT('         Lower
Limit')
 5135   FORMAT('         Upper
Limit')
 5161   FORMAT('      ')
 5162   FORMAT('          
')
        WRITE(ICOUT,5121)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5131)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5132)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5133)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5134)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5135)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5139)
        CALL DPWRST('XXX','WRIT')
C
C  FOLLOWING ADDS A RULE LINE BETWEEN HEADER AND DATA LINES
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5161)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5162)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: DEFINE DATA ROW
C
 5141   FORMAT('   ')
 5143   FORMAT('      ')
 5147   FORMAT('      ')
 5151   FORMAT('         ',F8.3)
 5152   FORMAT('         ',G12.6)
 5149   FORMAT('   ')
        DO5180I=1,8
          WRITE(ICOUT,5141)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5151)CONF(I)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5151)T(I)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5152)TSDM(I)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5152)ALOWER(I)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5143)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5152)AUPPER(I)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5147)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5149)
          CALL DPWRST('XXX','WRIT')
 5180   CONTINUE
C
C  STEP 4: END THE TABLE AND RESET ASIS MODE
C
 5191   FORMAT('')
 5193   FORMAT('')
 5199   FORMAT('
')
        WRITE(ICOUT,5191)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5193)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5199)
        CALL DPWRST('XXX','WRIT')
C
CCCCC WRITE OUTPUT IN LATEX FORMAT
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
C
C  STEP 1: END ASIS FORMAT, START TABLE ENVIRONMENT, WRITE A HEADER, AND
C          WRITE A TABLE CAPTION
C
 8001 FORMAT(A1,'end{verbatim}')
 8003 FORMAT(A1,'begin{table}')
 8007 FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1,' ')
 8009 FORMAT(A1,'begin{center}')
 8011 FORMAT(5X,'{',A1,'bf Confidence Limits for the Biweight ',
     1      'Location (2-Sided)}')
 8013 FORMAT(A1,'end{center}')
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8001)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8007)IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8013)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8020 FORMAT(5X,A1,'begin{tabular} {lr}')
 8021 FORMAT(5X,'Number of Observations: & ',I8,2X,A1,A1)
 8022 FORMAT(5X,'Biweight Location: & ',G15.7,2X,A1,A1)
 8023 FORMAT(5X,'Biweight Scale: & ',G15.7,2X,A1,A1)
 8024 FORMAT(5X,'Standard Error: & ',G15.7,2X,A1,A1)
 8025 FORMAT(5X,'Degrees of Freedom: & ',I8,2X,A1,A1)
 8049 FORMAT(5X,A1,'end{tabular}')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8021)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8022)YBW,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8023)YBSC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8024)YSTERR,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)IV,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8049)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8091 FORMAT(A1,'end{table}')
 8093 FORMAT(A1,'end{center}')
        WRITE(ICOUT,8093)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C STEP 2: START TABULAR ENVIRONMENT, WRITE SUBSESQUENT ROWS, END
C         TABULAR ENVIRONMENT
C
 8120 FORMAT(5X,A1,'begin{tabular} {ccccc}')
 8121 FORMAT(5X,'{',A1,'bf Confidence} & {',A1,'bf t } & & ',
     1       '{',A1,'bf Lower } & {',A1,'bf Upper}',2X,A1,A1)
 8122 FORMAT(5X,'{',A1,'bf Value (',A1,'%) } & {',A1,'bf Value} & {',A1,
     1       'bf t x Standard Error} & {',A1,'bf Limit} & {',A1,
     1       'bf Limit }',2X,A1,A1)
 8123 FORMAT(5X,2(F8.3,' & '),2(G12.6,' & '),G12.6,2X,A1,A1)
 8130 FORMAT(5X,A1,'hline')
        WRITE(ICOUT,8009)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8120)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8121)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8122)IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,IBASLC,
     1                   IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8130)IBASLC
        CALL DPWRST('XXX','WRIT')
        DO8160I=1,8
          WRITE(ICOUT,8123)CONF(I),T(I),TSDM(I),ALOWER(I),AUPPER(I),
     1                     IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
 8160   CONTINUE
        WRITE(ICOUT,8049)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C STEP 3: END TABLE ENVIRONMENT, RESET ASIS MODE
C
 8199 FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8093)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8091)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8199)IBASLC
        CALL DPWRST('XXX','WRIT')
C
C PLACEHOLDER FOR RTF FORMAT OUTPUT
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
C
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,811)
  811   FORMAT(
     1'                   CONFIDENCE LIMITS FOR BIWEIGHT LOCATION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,812)
  812   FORMAT(
     1'                           (2-SIDED)')
        CALL DPWRST('XXX','WRIT')
 
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,821)N
  821   FORMAT(
     1'          NUMBER OF OBSERVATIONS     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,822)YBW
  822   FORMAT(
     1'          BIWEIGHT LOCATION          = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,823)YBSC
  823   FORMAT(
     1'          BIWEIGHT SCALE             = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,824)YSTERR
  824   FORMAT(
     1'          STANDARD ERROR             = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,826)IV
  826   FORMAT(
     1'          DEGREES OF FREEDOM         = ',I15)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,832)
  832   FORMAT(
     1'   CONFIDENCE   T     T X STDERR       LOWER         UPPER     ')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,833)
  833   FORMAT(
     1'   VALUE (%)  VALUE                    LIMIT         LIMIT     ')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,834)
  834   FORMAT(
     1'---------------------------------------------------------------')
        CALL DPWRST('XXX','WRIT')
        DO840I=1,8
          WRITE(ICOUT,841)CONF(I),T(I),TSDM(I),ALOWER(I),AUPPER(I)
  841     FORMAT(
     1'   ',F8.3,F8.3,2X,G12.6,2X,G12.6,2X,G12.6)
          CALL DPWRST('XXX','WRIT')
  840   CONTINUE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
      ELSE
      ENDIF
      ENDIF
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')THEN
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPBWC2--')
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9012)N,IBUGA3,IERROR
 9012 FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','WRIT')
      DO9016I=1,N
      WRITE(ICOUT,9017)I,Y(I),W(I)
 9017 FORMAT('I,Y(I),W(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','WRIT')
 9016 CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPBX(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1IBOBPA,IBOBCO,PBOPTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
CCCCC MARCH 1993.  ADD PARAMETERS FOR BOX SHADOW
     1PBOSHE,PBOSWI,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1IGRASW,IDIASW,
     1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1NUMDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
     1IDFONT,
CCCCC ADD FOLLOWING LINE JULY 1997.
     1UNITSW,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DRAW ONE OR MORE BOXES
C              (DEPENDING ON HOW MANY NUMBERS ARE PROVIDED).
C              THE COORDINATES ARE IN STANDARDIZED UNITS
C              OF 0 TO 100.
C     NOTE--THE INPUT COORDINATES DEFINE THE OPPOSING CORNERS
C           OF THE BOX.
C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
C     NOTE--IF 2 NUMBERS ARE PROVIDED,
C           THEN THE DRAWN BOX WILL GO
C           FROM THE LAST CURSOR POSITION
C           TO THE (X,Y) POINT
C           (EITHER ABSOLUTE OR RELATIVE)
C           AS DEFINED BY THE 2 NUMBERS.
C     NOTE--IF 4 NUMBERS ARE PROVIDED,
C           THEN THE DRAWN BOX WILL GO
C           FROM THE ABSOLUTE (X,Y) POSITION
C           AS DEFINED BY THE FIRST 2 NUMBERS
C           TO THE (X,Y) POINT
C           (EITHER ABSOLUTE OR RELATIVE)
C           AS DEFINED BY THE THIRD AND FOURTH NUMBERS.
C     NOTE--IF 6 NUMBERS ARE PROVIDED,
C           THEN THE DRAWN BOX WILL GO
C           FROM THE (X,Y) POSITION
C           AS RESULTING FROM THE THIRD AND FOURTH NUMBERS
C           TO THE (X,Y) POINT
C           (EITHER ABSOLUTE OR RELATIVE)
C           AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
C     INPUT  ARGUMENTS--IHARG
C                     --IARGT
C                     --ARG
C                     --NUMARG
C                     --PXSTAR
C                     --PYSTAR
C     OUTPUT ARGUMENTS--PXEND
C                     --PYEND
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--APRIL     1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --NOVEMBER  1982.
C     UPDATED         --JANUARY   1989.  CALL LIST FOR OFFSET VAR (ALAN)
C     UPDATED         --JANUARY   1989.  USE COMMON PARAMETERS (ALAN)
C     UPDATED         --MARCH     1993. ADD BOX SHADOW, PATTERN LINE
C     UPDATED         --MARCH     1993. GLOBALLY RENAMED IBOFPA, IBOFCO
C                                       PBOFTH TO IBOBPA, IBOBCO, PBOPTH
C     UPDATED         --MARCH     1997.  SUPPORT FOR DEVICE FONT (ALAN)
C     UPDATED         --JULY      1997.  SUPPORT FOR "DATA" UNITS (ALAN)
C
C-----NON-COMMON VARIABLES-----------------------------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBOBPA
      CHARACTER*4 IBOBCO
C
      CHARACTER*4 IREBLI
      CHARACTER*4 IREBCO
      CHARACTER*4 IREFSW
      CHARACTER*4 IREFCO
      CHARACTER*4 IREPTY
      CHARACTER*4 IREPLI
      CHARACTER*4 IREPCO
C
      CHARACTER*4 IGRASW
      CHARACTER*4 IDIASW
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
CCCCC ADD FOLLOWING LINE MARCH 1997.
      CHARACTER*4 IDFONT
CCCCC ADD FOLLOWING LINE JULY 1997.
      CHARACTER*4 UNITSW
C
      CHARACTER*4 IFOUND
      CHARACTER*4 IBUGD2
      CHARACTER*4 IERROR
      CHARACTER*4 ISUBRO
C
      CHARACTER*4 IFIG
      CHARACTER*4 IBELSW
      CHARACTER*4 IERASW
      CHARACTER*4 IBACCO
      CHARACTER*4 ICOPSW
      CHARACTER*4 ITYPEO
C
      DIMENSION IHARG(*)
      DIMENSION IARGT(*)
      DIMENSION ARG(*)
C
      DIMENSION IBOBPA(*)
      DIMENSION IBOBCO(*)
      DIMENSION PBOPTH(*)
C
      DIMENSION AREGBA(*)
      DIMENSION IREBLI(*)
      DIMENSION IREBCO(*)
      DIMENSION PREBTH(*)
      DIMENSION IREFSW(*)
      DIMENSION IREFCO(*)
      DIMENSION IREPTY(*)
      DIMENSION IREPLI(*)
      DIMENSION IREPCO(*)
      DIMENSION PREPTH(*)
      DIMENSION PREPSP(*)
CCCCC MARCH 1993.  ADD FOLLOWING 2 LINES
      DIMENSION PBOSHE(*)
      DIMENSION PBOSWI(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
CCCCC ADD FOLLOWING LINE MARCH 1997.
      DIMENSION IDFONT(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
C
      DIMENSION IDNVOF(*)
      DIMENSION IDNHOF(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      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
      IFOUND='NO'
      IERROR='NO'
      IERRG4=IERROR
CCCCC IBUGG4=IBUGD2
CCCCC ISUBG4=ISUBRO
C
      ILOCFN=0
      NUMNUM=0
C
      X1=0.0
      Y1=0.0
      X2=0.0
      Y2=0.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPBX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NUMARG
   53 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,57)PXSTAR,PYSTAR
   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)PXEND,PYEND
   58 FORMAT('PXEND,PYEND = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IBOBPA(1),IBOBCO(1),PBOPTH(1)
   61 FORMAT('IBOBPA(1),IBOBCO(1),PBOPTH(1) = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)AREGBA(1)
   62 FORMAT('AREGBA(1) = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
     1A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)PTEXHE,PTEXWI
   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)PTEXVG,PTEXHG
   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,76)IGRASW,IDIASW
   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,80)NUMDEV
   80 FORMAT('NUMDEV= ',I8)
      CALL DPWRST('XXX','BUG ')
      DO81I=1,NUMDEV
      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
     1A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
     1A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
     1I8,I8,I8)
      CALL DPWRST('XXX','BUG ')
   81 CONTINUE
      WRITE(ICOUT,87)IFOUND
   87 FORMAT('IFOUND= ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGD2,IERROR
   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IFIG='BOX'
      NUMPT=2
      NUMPT2=2*NUMPT
C
C               ********************************
C               **  STEP 0--                  **
C               **  STEP THROUGH EACH DEVICE  **
C               ********************************
C
      IF(NUMDEV.LE.0)GOTO9000
      DO8000IDEVIC=1,NUMDEV
C
      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
C
      IMANUF=IDMANU(IDEVIC)
      IMODEL=IDMODE(IDEVIC)
      IMODE2=IDMOD2(IDEVIC)
      IMODE3=IDMOD3(IDEVIC)
      IGCONT=IDCONT(IDEVIC)
      IGCOLO=IDCOLO(IDEVIC)
CCCCC ADD FOLLOWING LINE MARCH 1997.
      IGFONT=IDFONT(IDEVIC)
      NUMVPP=IDNVPP(IDEVIC)
      NUMHPP=IDNHPP(IDEVIC)
      ANUMVP=NUMVPP
      ANUMHP=NUMHPP
C  AUGUST 1988.  ADD OFFSET VARIABLE
      IOFFSV=IDNVOF(IDEVIC)
      IOFFSH=IDNHOF(IDEVIC)
C
      IGUNIT=IDUNIT(IDEVIC)
C
C               ************************************
C               **  STEP 1--                      **
C               **  CARRY OUT OPENING OPERATIONS  **
C               **  ON THE GRAPHICS DEVICES       **
C               ************************************
C
      CALL DPOPDE
C
      IBELSW='OFF'
      NUMRIN=0
      IERASW='OFF'
      IBACCO='JUNK'
C
      CALL DPOPPL(IGRASW,
     1IBELSW,NUMRIN,IERASW,
     1IBACCO)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
C               *****************************************
C
      IF(NUMARG.GE.2.AND.
     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1111
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
     1GOTO1112
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
     1GOTO1113
      GOTO1130
C
 1111 CONTINUE
      ITYPEO='ABSO'
      ILOCFN=1
      GOTO1119
C
 1112 CONTINUE
      ITYPEO='ABSO'
      ILOCFN=2
      GOTO1119
C
 1113 CONTINUE
      ITYPEO='RELA'
      ILOCFN=2
      GOTO1119
 1119 CONTINUE
C
      IF(ILOCFN.GT.NUMARG)GOTO1129
      DO1120I=ILOCFN,NUMARG
      IF(IARGT(I).EQ.'NUMB')GOTO1120
      GOTO1129
 1120 CONTINUE
      IFOUND='YES'
      GOTO1149
 1129 CONTINUE
      GOTO1130
C
 1130 CONTINUE
      IERRG4='YES'
      WRITE(ICOUT,1131)
 1131 FORMAT('***** ERROR IN DPBX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1132)
 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
     1'COMMAND.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1134)
 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
     1'PROPER FORM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1135)
 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A BOX ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)
 1136 FORMAT('      WITH ONE CORNER AT THE POINT 20 20 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1137)
 1137 FORMAT('      AND WITH OPPOSITE CORNER AT THE POINT 40 60')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      BOX 20 20 40 60 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      BOX ABSOLUTE 20 20 40 60 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1149 CONTINUE
C
C               ****************************
C               **  STEP 3--              **
C               **  DRAW OUT THE LINE(S)  **
C               ****************************
C
      NUMNUM=NUMARG-ILOCFN+1
      IF(NUMNUM.LT.NUMPT2)GOTO1151
      GOTO1152
C
 1151 CONTINUE
      J=ILOCFN-1
      X1=PXSTAR
      Y1=PYSTAR
      GOTO1159
C
 1152 CONTINUE
      J=ILOCFN
      IF(J.GT.NUMARG)GOTO1190
      X1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
      J=J+1
      IF(J.GT.NUMARG)GOTO1190
      Y1=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
      GOTO1159
 1159 CONTINUE
C
 1160 CONTINUE
      J=J+1
      IF(J.GT.NUMARG)GOTO1190
      X2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
      IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
      IF(ITYPEO.EQ.'RELA')X2=X1+X2
      J=J+1
      IF(J.GT.NUMARG)GOTO1190
      Y2=ARG(J)
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
      IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
C
 1170 CONTINUE
      CALL DPBX2(X1,Y1,X2,Y2,
     1IFIG,
     1IBOBPA,IBOBCO,PBOPTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
CCCCC MARCH 1993.  ADD FOLLOWING LINE (BOX SHADOW)  (ALAN)
     1PBOSHE,PBOSWI,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
      X1=X2
      Y1=Y2
C
      GOTO1160
 1190 CONTINUE
C
      PXEND=X2
      PYEND=Y2
C
C               ************************************
C               **  STEP 4--                      **
C               **  CARRY OUT CLOSING OPERATIONS  **
C               **  ON THE GRAPHICS DEVICES       **
C               ************************************
C
      ICOPSW='OFF'
      NUMCOP=0
      CALL DPCLPL(ICOPSW,NUMCOP,
     1PGRAXF,PGRAYF,
     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
C
      CALL DPCLDE
C
 8000 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPBX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ILOCFN,NUMNUM
 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)X1,Y1,X2,Y2
 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)PXSTAR,PYSTAR
 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)PXEND,PYEND
 9016 FORMAT('PXEND,PYEND = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IFIG
 9017 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)IFOUND
 9027 FORMAT('IFOUND = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGD2,IERROR
 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPBX2(X1,Y1,X2,Y2,
     1IFIG,
     1IBOBPA,IBOBCO,PBOPTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
CCCCC MARCH 1993.  BOX SHADOW PARAMETERS
     1PBOSHE,PBOSWI,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
C     PURPOSE--DRAW A BOX
C              WITH ONE END OF THE DIAGONAL AT (X1,Y1)
C              AND THE OTHER END AT (X2,Y2).
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--APRIL     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
C     UPDATED         --JANUARY   1989.  USE COMMON PARAMETERS (ALAN)
C     UPDATED         --MARCH     1993. BOX SHADOW, PATTERN LINE TYPE
C     UPDATED         --MARCH     1993. GLOBALLY RENAMED IBOFPA, IBOFCO
C                                       PBOFTH TO IBOBPA, IBOBCO, PBOPTH
C
C-----NON-COMMON VARIABLES-------------------------------------
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT2
C
      CHARACTER*4 IBOBPA
      CHARACTER*4 IBOBCO
C
      CHARACTER*4 IREBLI
      CHARACTER*4 IREBCO
      CHARACTER*4 IREFSW
      CHARACTER*4 IREFCO
      CHARACTER*4 IREPTY
      CHARACTER*4 IREPLI
      CHARACTER*4 IREPCO
C
      CHARACTER*4 IPATT
      CHARACTER*4 ICOLF
      CHARACTER*4 ICOLP
      CHARACTER*4 ICOL
      CHARACTER*4 IFLAG
C
      DIMENSION PX(10)
      DIMENSION PY(10)
CCCCC DIMENSION PX3(10)
CCCCC DIMENSION PY3(10)
C
      DIMENSION IBOBPA(*)
      DIMENSION IBOBCO(*)
      DIMENSION PBOPTH(*)
C
      DIMENSION AREGBA(*)
      DIMENSION IREBLI(*)
      DIMENSION IREBCO(*)
      DIMENSION PREBTH(*)
      DIMENSION IREFSW(*)
      DIMENSION IREFCO(*)
      DIMENSION IREPTY(*)
      DIMENSION IREPLI(*)
      DIMENSION IREPCO(*)
      DIMENSION PREPTH(*)
      DIMENSION PREPSP(*)
CCCCC MARCH 1993.  ADD FOLLOWING 2 LINES
      DIMENSION PBOSHE(*)
      DIMENSION PBOSWI(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      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.'BX2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPBX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)X1,Y1
   53 FORMAT('X1,Y1 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)X2,Y2
   54 FORMAT('X2,Y2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IFIG
   59 FORMAT('IFIG = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IBOBPA(1),IBOBCO(1),PBOPTH(1)
   61 FORMAT('IBOBPA(1),IBOBCO(1),PBOPTH(1) = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)AREGBA(1)
   62 FORMAT('AREGBA(1) = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
     1A4,2X,A4,2X,A4,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)PTEXHE,PTEXWI
   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)PTEXVG,PTEXHG
   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *********************************
C               **  STEP 1--                   **
C               **  DETERMINE THE COORDINATES  **
C               **  FOR THE BOX                **
C               *********************************
C
      PX(1)=X1
      PY(1)=Y1
C
      PX(2)=X2
      PY(2)=Y1
C
      PX(3)=X2
      PY(3)=Y2
C
      PX(4)=X1
      PY(4)=Y2
C
      PX(5)=X1
      PY(5)=Y1
C
      NP=5
C
C               ***********************
C               **  STEP 2--         **
C               **  FILL THE FIGURE  **
C               **  (IF CALLED FOR)  **
C               ***********************
C
CCCCC FOLLOWING BLOCK MODIFIED MARCH 1993.
CCCCC USE BOX PARAMETERS RATHER THAN REGION PARAMETERS.
CCCCC IF(IREFSW(1).EQ.'OFF')GOTO2190
      IPATT=IREPTY(1)
      IF(IPATT.EQ.'OFF')GOTO2190
      IF(IPATT.EQ.'EMPT')GOTO2190
      IF(IPATT.EQ.'    ')GOTO2190
      IF(IPATT.EQ.'NONE')GOTO2190
      IF(IPATT.EQ.'BLAN')GOTO2190
      IF(IPATT.EQ.'BLAN')GOTO2190
      IF(IPATT.EQ.'ON')IPATT='SOLI'
CCCCC IPATT2='SOLI'
      IPATT2=IREPLI(1)
      PTHICK=PREPTH(1)
      PXGAP=PREPSP(1)
      PYGAP=PREPSP(1)
CCCCC ICOLF=IREFCO(1)
CCCCC ICOLP=IREPCO(1)
      ICOLF=IREPCO(1)
      ICOLP=ICOLF
      CALL DPFIRE(PX,PY,NP,
     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
 2190 CONTINUE
C
C               ***************************
C               **  STEP 3--             **
C               **  DRAW OUT THE FIGURE  **
C               ***************************
C
      IPATT=IBOBPA(1)
      PTHICK=PBOPTH(1)
      ICOL=IBOBCO(1)
      IFLAG='ON'
CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
CCCCC1IFIG,IPATT,PTHICK,ICOL)
      CALL DPDRPL(PX,PY,NP,
     1IFIG,IPATT,PTHICK,ICOL,
     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
C
CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED
CCCCC TO ADD A SHADOW TO THE BOX   MARCH 1993
C               ***************************
C               **  STEP 4--             **
C               **  DRAW THE BOX SHADOW  **
C               ***************************
C
C
      PSH=PBOSHE(1)
      PSW=PBOSWI(1)
      EPSBS=0.000001
      IF(PSH.LT.EPSBS.AND.PSW.LT.EPSBS)GOTO4190
      PLEFT=X1
      PRIGHT=X2
      IF(X2.LT.X1)THEN
         PLEFT=X2
         PRIGHT=X1
      ENDIF
      PBOTTO=Y1
      PTOP=Y2
      IF(Y2.LT.Y1)THEN
         PBOTTO=Y2
         PTOP=Y1
      ENDIF
      PX(1)=PLEFT+PSW
      PY(1)=PBOTTO-PSH
      PX(2)=PRIGHT+PSW
      PY(2)=PBOTTO-PSH
      PX(3)=PRIGHT+PSW
      PY(3)=PBOTTO
      PX(4)=PLEFT+PSW
      PY(4)=PBOTTO
      PX(5)=PLEFT+PSW
      PY(5)=PBOTTO-PSH
      NP=5
      IPATT='SOLI'
      IPATT2='SOLI'
      ICOLF=IBOBCO(1)
      ICOLP=ICOLF
      CALL DPFIRE(PX,PY,NP,
     1IFIG,IPATT,PTHICK,PXSPA,PYSPA,ICOLF,ICOLP,IPATT2)
C
      PX(1)=PRIGHT
      PY(1)=PBOTTO-PSH
      PX(2)=PRIGHT+PSW
      PY(2)=PBOTTO-PSH
      PX(3)=PRIGHT+PSW
      PY(3)=PTOP-PSH
      PX(4)=PRIGHT
      PY(4)=PTOP-PSH
      PX(5)=PRIGHT
      PY(5)=PBOTTO-PSH
      CALL DPFIRE(PX,PY,NP,
     1IFIG,IPATT,PTHICK,PXSPA,PYSPA,ICOLF,ICOLP,IPATT2)
C
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPBX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NP
 9013 FORMAT('NP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NP
      WRITE(ICOUT,9016)I,PX(I),PY(I)
 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END