SUBROUTINE DPFUNC(IBUGA3,IERROR,ISFLAG) CCCCC APRIL 1996. ADD ISFLAG ARGUMENT CCCCC SUBROUTINE DPFUNC(IBUGA3,IERROR) C C PURPOSE--TREAT THE SUBCASE OF THE LET FUNCTION COMMAND C IN WHICH A FUNCTION IS DEFINED. C EXAMPLE--LET FUNCTION F1 = SIN(2*X) C --LET FUNCTION F2 = SIN(A*B*X+2*C)+E*X**4 FOR X=Z C --LET FUNCTION F3 = F1 FOR X=7 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 1979. C UPDATED --FEBRUARY 1979. C UPDATED --MARCH 1979. C UPDATED --JULY 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1996. ISFLAG TO PRESERVE STRING CASE C UPDATED --JULY 1998. FOR STRINGS, CHECK FOR C SP() AND CONVERT TO SPACE. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 IWD1 CHARACTER*4 IWD2 CHARACTER*4 IWD12 CHARACTER*4 IWD22 CHARACTER*4 ILAB CHARACTER*4 IKEY CHARACTER*4 IKEY2 CHARACTER*4 INCLUN CHARACTER*4 IFOUND CHARACTER*4 IFOUN1 CHARACTER*4 IFOUN2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IOLD CHARACTER*4 IOLD2 CHARACTER*4 INEW CHARACTER*4 INEW2 CHARACTER*4 IHOUT CHARACTER*4 IHOUT2 CHARACTER*4 IUOUT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CCCCC APRIL 1996. ADD FOLLOWING LINE CHARACTER*10 ISFLAG CCCCC JULY 1998. ADD FOLLOWING LINE CHARACTER*4 IATEMP C C--------------------------------------------------------------------- C DIMENSION ILAB(10) C DIMENSION IOLD(10) DIMENSION IOLD2(10) DIMENSION INEW(10) DIMENSION INEW2(10) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' 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='DPFU' ISUBN2='NC ' C IERROR='NO' C ILOC3=0 C C ***************************************************** C ** TREAT THE SUBCASE OF THE LET FUNCTION COMMAND ** C ** WHICH DEFINES A FUNCTION ** C ***************************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPFUNC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NUMNAM 53 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMNAM WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 56 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,57)NUMCHF,MAXCHF 57 FORMAT('NUMCHF,MAXCHF = ',2I8) CALL DPWRST('XXX','BUG ') NMAX=120 IF(MAXCHF.LT.NMAX)NMAX=MAXCHF CCCCC WRITE(ICOUT,60)(IFUNC(I),I=1,MAXCHF) WRITE(ICOUT,60)(IFUNC(I),I=1,NMAX) 60 FORMAT('IFUNC(.) = ',120A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' C MAXN2=MAXCHF MAXN3=MAXCHF C C **************************************************************** C ** STEP 2-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE FUNCTION NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C **************************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(2) IHLEF2=IHARG2(2) DO2000I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2100 2000 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO2200 GOTO2900 2200 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2201) 2201 FORMAT('***** ERROR IN DPFUNC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2202) 2202 FORMAT(' THE NUMBER OF VARIABLE, PARAMETER, & FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2203)MAXNAM 2203 FORMAT(' NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2204) 2204 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2205) 2205 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2206) 2206 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2207) 2207 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 2100 CONTINUE ILISTL=I2 2900 CONTINUE C C *************************************************************** C ** STEP 3-- ** C ** EXTRACT THE RIGHT-SIDE ** C ** EXPRESSION FROM THE INPUT COMMAND LINE ** C ** (STARTING WITH THE FIRST NON-BLANK LOCATION AFTER THE ** C ** EQUAL SIGN AND ENDING WITH THE END OF THE LINE ** C ** OR WITH THE LAST NON-BLANK CHARACTER BEWRTE FOR . ** C *************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC APRIL 1996. FOR LET STRING, PRESERVE CASE. FOR LET FUNCTION, CCCCC CONVERT TO UPPER CASE. IWD1='= ' IWD12=' ' IWD2='FOR ' IWD22=' ' IF(ISFLAG.EQ.'FUNCTION')THEN CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) ELSE CALL DPEXST(IANSLC,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) ENDIF IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3900 C IWD1='= ' IWD12=' ' IWD2=' ' IWD22=' ' IF(ISFLAG.EQ.'FUNCTION')THEN CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) ELSE CALL DPEXST(IANSLC,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2, 1IFUNC2,N2,IBUGA3,IFOUND,IERROR) ENDIF IF(IERROR.EQ.'YES')GOTO9000 IF(IFOUND.EQ.'YES')GOTO3900 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3101) 3101 FORMAT('***** ERROR IN DPFUNC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3102) 3102 FORMAT(' INVALID COMMAND FORM FOR FUNCTION DEFINITION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3103) 3103 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3104) 3104 FORMAT(' LET FUNCTION ... = ... FOR ... = ... ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3105) 3105 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100)) 3106 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3900 CONTINUE C C *********************************************************** C ** STEP 4.1-- ** C ** DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES ** C ** INBEDDED. IF SO, REPLACE THE FUNCTION NAMES ** C ** BY EACH FUNCTION'S DEFINITION. DO SO REPEATEDLY ** C ** UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED ** C ** AND THE EXPRESSION IS LEFT ONLY WITH ** C ** CONSTANTS, PARAMETERS, AND VARIABLES--NO FUNCTIONS. ** C ** PLACE THE RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.) ** C *********************************************************** C ISTEPN='4.1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,IFUNC3,N3,MAXN3, 1IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 CCCCC JULY 1998. CHECK FOR "SP()" IN STRINGS AND CONVERT TO SPACE. IF(ISFLAG.NE.'FUNCTION'.AND.N3.GE.4)THEN DO4100I=N3,4,-1 IATEMP(1:1)=IFUNC3(I-3)(1:1) IATEMP(2:2)=IFUNC3(I-2)(1:1) IATEMP(3:3)=IFUNC3(I-1)(1:1) IATEMP(4:4)=IFUNC3(I)(1:1) IF( 1 IATEMP(3:4).EQ.'()'.AND. 1 (IATEMP(2:2).EQ.'P'.OR.IATEMP(2:2).EQ.'p').AND. 1 (IATEMP(1:1).EQ.'S'.OR.IATEMP(1:1).EQ.'s') 1 )THEN IFUNC3(I-3)=' ' DO4110J=I-2,N3-3 J2=J+3 IFUNC3(J)=IFUNC3(J2) 4110 CONTINUE DO4120J=N3-2,N3 IFUNC3(J)=' ' 4120 CONTINUE N3=N3-3 ENDIF 4100 CONTINUE ENDIF C C ********************************************** C ** STEP 4.2-- ** C ** PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE FUNCTION ** C ** DEFINITION HAS BEEN CARRIED OUT. ** C ********************************************** C ISTEPN='4.2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO5190 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='INPU' ILAB(2)='T FU' ILAB(3)='NCTI' ILAB(4)='ON ' ILAB(5)=' ' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC2,N2,IBUGA3) C ILAB(1)='OUTP' ILAB(2)='UT F' ILAB(3)='UNCT' ILAB(4)='ION ' ILAB(5)=' ' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C 5190 CONTINUE C C ************************************* C ** STEP 5-- ** C ** EXTRACT QUALIFIER INFORMATION. ** C ************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ************************************* C ** STEP 5-- ** C ** EXTRACT QUALIFIER INFORMATION. ** C ************************************* C ISTEPN='5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C ********************************************** C ** STEP 6.3-- ** C ** SCAN THE QUALIFIERS FOR VARIABLE, ** C ** PARAMETER, FUNCTION, AND VALUE CHANGES ** C ** IN THE FUNCTION. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCLM=1 C NCHANG=0 DO6300IFORI=1,10 C IKEY='FOR ' IKEY2=' ' ISHIFT=1 IF(IFORI.EQ.1)ILOCA=ILOCLM IF(IFORI.NE.1)ILOCA=ILOC3 ILOCB=NUMARG INCLUN='NO' CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB, 1IHARG,IHARG2,NUMARG, 1INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,IUSE,IN,NUMNAM, 1IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,VOUT,IUOUT, 1INOUT,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO6380 IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6350 C ILOC3=ILOC2+2 IF(ILOC3.GT.NUMARG)GOTO6380 NCHANG=NCHANG+1 IOLD(NCHANG)=IHARG(ILOC2) IOLD2(NCHANG)=IHARG2(ILOC2) INEW(NCHANG)=IHARG(ILOC3) INEW2(NCHANG)=IHARG2(ILOC3) C 6300 CONTINUE 6350 CONTINUE GOTO6390 C 6380 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6301) 6301 FORMAT('***** ERROR IN DPFUNC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6302) 6302 FORMAT(' INVALID COMMAND FORM FOR LET FUNCTION.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6303) 6303 FORMAT(' GENERAL FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6304) 6304 FORMAT(' LET FUNCTION ... = ... FOR ... ', 1'FOR ... = ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6305) 6305 FORMAT(' THE ENTIRE COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,6306)(IANS(I),I=1,MIN(IWIDTH,100)) 6306 FORMAT(' ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 6390 CONTINUE C C ********************************************** C ** STEP 6.4-- ** C ** CARRY OUT THE VARIABLE, ** C ** PARAMETER, AND FUNCTION CHANGES ** C ** AND THEN PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE CHANGES ** C ** HAVE BEEN MADE. ** C ********************************************** C ISTEPN='6.4' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IFEEDB.EQ.'OFF')GOTO6490 IF(NCHANG.LE.0)GOTO6490 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') ILAB(1)='PRE ' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG, 1IFUNC3,N3,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C ILAB(1)='POST' ILAB(2)='-CHA' ILAB(3)='NGE ' ILAB(4)='FUNC' ILAB(5)='TION' ILAB(6)=' = ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C 6490 CONTINUE C C ******************************************************* C ** STEP 6.5-- ** C ** FOR THE CASE WHEN THE OUTPUT IS A FUNCTION, ** C ** DETERMINE IF THE INSERTION OF THE NEW FUNCTION ** C ** INTO THE GENERAL FUNCTION TABLE WOULD OVERFLOW ** C ** THE TABLE. IF NOT, THEN INSERT THE FUNCTION ** C ** INTO THE GENERAL FUNCTION TABLE. ** C ** MAKE ADJUSTMENTS TO THE INTERNAL LIST. ** C ******************************************************* C ISTEPN='6.5' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPINFU(IFUNC3,N3,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP, 1NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,NEWNAM,MAXN3, 1IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C 6590 CONTINUE C C ********************************************** C ** STEP 6.6-- ** C ** FOR THE CASE WHEN THE OUTPUT ** C ** IS A FUNCTION, ** C ** PRINT OUT A BRIEF MESSAGE ** C ** INDICATING THAT THE FUNCTION ** C ** DEFINITION HAS BEEN CARRIED OUT. ** C ********************************************** C ISTEPN='6.6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'OFF')GOTO6690 IF(IFEEDB.EQ.'OFF')GOTO6690 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6606)IHLEFT,IHLEF2 6606 FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ') CALL DPWRST('XXX','BUG ') ILAB(1)='TO T' ILAB(2)='HE F' ILAB(3)='UNCT' ILAB(4)='ION ' ILAB(5)=' ' ILAB(6)=' -- ' NUMWDL=6 CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3) C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') C 6690 CONTINUE C C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPFUNC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3 9012 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NUMNAM 9013 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMNAM WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I) 9016 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=', 1I8,2X,A4,A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9015 CONTINUE WRITE(ICOUT,9017)N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF 9017 FORMAT('N2,N3,NUMCHF,MAXN2,MAXN3,MAXCHF = ',6I8) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9018)(IFUNC2(I),I=1,N2) NMAX=N2 IF(NMAX.GT.120)NMAX=120 WRITE(ICOUT,9018)(IFUNC2(I),I=1,NMAX) 9018 FORMAT('IFUNC2(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)(IFUNC3(I),I=1,MIN(N3,120)) 9019 FORMAT('IFUNC3(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)(IFUNC(I),I=1,MIN(MAXCHF,120)) 9020 FORMAT('IFUNC(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)IERROR 9021 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPGCI(NPTS,NLAB, 1AMEAN,ASD,N, 1DTEMP1,DTEMP2, 1XGCI,SEGCI, 1DLOWGC,DHIGGC, 1IWRITE,IOUNI5, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT IYER-WANG APPROACH OF GENERALIZED CONFIDENCE C INTERVALS TO CONSENSUS MEANS. NOTE THAT THIS C ROUTINE DOES NOT RETURN AN ESTIMATE OF THE C STANDARD ERROR OF THE CONSENSUS MEAN, JUST CONFIDENCE C LIMITS DETERMINED VIA SIMULATION. C PRINTING--YES C SUBROUTINES NEEDED--GCI1 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. C UPDATED --MAY 2006. CHECK FOR NGROUPS = 1 CASE, C THIS RESULTS IN 0 DEGREES C OF FREEDOM FOR CHI-SQUARE C RANDOM NUMBERS C UPDATED --JUNE 2006. CHECK FOR LABS THAT HAVE C ONLY 1 OBSERVATION. 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 DOUBLE PRECISION DTEMP1(*) DOUBLE PRECISION DTEMP2(*) C REAL AMEAN(*) REAL ASD(*) C REAL XGCI REAL SEGCI C INTEGER N(*) C DOUBLE PRECISION DALPHA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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='DPGC' ISUBN2='I ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PGCI')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGCI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB 52 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C IFLAG=0 DO100I=1,NLAB IINDX1=I IINDX2=I+NLAB DTEMP1(IINDX1)=DBLE(AMEAN(I)) DTEMP1(IINDX2)=DBLE(ASD(I))**2 IF(N(I).LE.1)IFLAG=1 100 CONTINUE IINDX1=1 IINDX2=1+NLAB IINDX3=1+2*NLAB IINDX4=1+3*NLAB C DALPHA=0.95 NRUN=10000 IERROR='NO' C IF(NLAB.GT.1.AND.IFLAG.EQ.0)THEN CALL GCI1(NLAB,N,DTEMP1(IINDX1),DTEMP1(IINDX2), 1 DALPHA,NRUN,DTERM1, 1 DLOWGC,DHIGGC,DTERM2, 1 DTEMP1(IINDX3),DTEMP1(IINDX4),DTEMP2, 1 IERROR) SEGCI=REAL(DTERM2) IF(IERROR.EQ.'YES')THEN XGCI=0.0 SEGCI=0.0 DLOWGC=0.0D0 DHIGGC=0.0D0 GOTO9000 ELSE XGCI=REAL(DTERM1) ENDIF ELSE XGCI=0.0 SEGCI=0.0 DLOWGC=0.0D0 DHIGGC=0.0D0 GOTO9000 ENDIF C DO200I=1,NRUN WRITE(IOUNI5,'(E15.7)')DTEMP2(I) 200 CONTINUE 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(' 9. Method: Generalized Confidence ', 1 'Intervals') 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)XGCI 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 Uncertainty (k = 1):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)SEGCI 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 '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)2.0*SEGCI 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 'Lower 95% (Simulation) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWGC) 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 'Upper 95% (Simulation) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGGC) 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 'Note: Generalized Confidence Interval 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,5185) 5185 FORMAT('      ', 1 '         ', 1 'Any Number of 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 9. Method: Generalized Confidence ', 1 'Interval:} & ', 1 2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) 8013 FORMAT(5X,'Standard Uncertainty (k = 1): & ', 1 F15.7,2X,A1,A1) 8014 FORMAT(5X,'Expanded Uncertainty (k = 2): & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XGCI,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8013)SEGCI,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8014)2.0*SEGCI,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8026 FORMAT(5X,'Lower 95',A1,'% (Simulation) Confidence ', 1 'Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (Simulation) Confidence ', 1 'Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: Generalized Confidence Interval ', 1 'Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' Any Number of Labs ', 1 '& ',2X,A1,A1) WRITE(ICOUT,8026)IBASLC,REAL(DLOWGC),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGGC),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 9. Method: Generalized CI' IVALUE(1)(1:1)=IBASLC NCHAR(1)=28 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)=XGCI CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=SEGCI CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=2.0*SEGCI CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=43 IVALUE(1)=' Lower 95% (simulation) Confidence Limit:' AVALUE(2)=REAL(DLOWGC) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=43 IVALUE(1)=' Upper 95% (simulation) Confidence Limit:' AVALUE(2)=REAL(DHIGGC) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: Generalized CI Best Usage:' NCHAR(1)=35 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' Any Number of Labs' NCHAR(1)=27 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('9. Method: Generalized Confidence Intervals') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XGCI 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4003)SEGCI 4003 FORMAT(' Standard Uncertainty (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4004)2.0*SEGCI 4004 FORMAT(' Expanded Uncertainty (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4022)REAL(DLOWGC) 4022 FORMAT(' Lower 95% (Simulation) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DHIGGC) 4023 FORMAT(' Upper 95% (Simulation) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: Generalized Confidence Interval ', 1 'Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' Any Number of Labs, but no ', 1 'Between Lab Variance') 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.'PGCI')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGCI--') 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)XGCI 9014 FORMAT('XGCI = ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWGC,DHIGGC 9015 FORMAT('DLOWGC,DHIGGC = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPGCL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR GREEK COMPLEX LOWER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) 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 NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.9)GOTO1010 GOTO1019 1010 CONTINUE CALL DGCL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(10.LE.ICHARN.AND.ICHARN.LE.20)GOTO1020 GOTO1029 1020 CONTINUE CALL DGCL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IF(ICHARN.GE.21)GOTO1030 GOTO1039 1030 CONTINUE CALL DGCL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1039 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGCL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPGCU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) C C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES C FOR GREEK COMPLEX UPPER CASE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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/4 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. C UPDATED --MAY 1982. C UPDATED --MARCH 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICHAR2 CHARACTER*4 IOP CHARACTER*4 IBUGD2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IOP(*) DIMENSION X(*) DIMENSION Y(*) 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 NUMCO=1 ISTART=1 ISTOP=1 NC=1 C C ****************************************** C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** C ** HERSHEY CHARACTER SET CASE ** C ****************************************** C C IF(IBUGD2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ICHAR2 52 FORMAT('ICHAR2 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** SEARCH FOR THE INPUT CHARACTER(S). ** C ** MAP THE CHARACTER(S) INTO A NUMERIC VALUE. ** C ************************************************** C CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND) IF(IFOUND.EQ.'NO')GOTO9000 C IF(ICHARN.LE.14)GOTO1010 GOTO1019 1010 CONTINUE CALL DGCU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1019 CONTINUE C IF(ICHARN.GE.15)GOTO1020 GOTO1029 1020 CONTINUE CALL DGCU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 1IBUGD2,IFOUND,IERROR) GOTO9000 1029 CONTINUE C IFOUND='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGD2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGCU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)ICHAR2,ICHARN 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) CALL DPWRST('XXX','BUG ') IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 DO9015I=1,NUMCO WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPGENS(INCASE,IBUGA3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE SPECIALIZED MATHEMATICAL NUMBER SEQUENCES-- C 1) PRIME NUMBERS C 2) FIBONACCI SEQUENCES C 3) LOGISTIC NUMBERS C 4) BERNOULI NUMBERS C 5) EULER NUMBERS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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/10 C ORIGINAL VERSION--SEPTEMBER 1987. C UPDATED --APRIL 1989. LOGISTIC SEQUENCE (CHAOS THEORY) C UPDATED --APRIL 1989. CANTOR SET (CHAOS THEORY) C UPDATED --JULY 1993. CANTOR SET (NO ERROR IF P NOT C PREVIOUSLY DEFINED) C UPDATED --FEBRUARY 1994. EQUIVALENCE C UPDATED --SEPTEMBER 1997. BERNOULI NUMBERS C UPDATED --SEPTEMBER 1997. EULER NUMBERS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 INCASE CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 NEWNAM CHARACTER*4 NEWCOL CHARACTER*4 ICASEQ CHARACTER*4 ILEFT CHARACTER*4 ILEFT2 C CCCCC THE FOLLOWING 4 LINES WERE ADDED FOR LOGISTIC APRIL 1989 CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C CCCCC THE FOLLOWING LINE WAS ADDED FOR CANTOR SET APRIL 1989 DIMENSION TEMP(MAXOBV) DOUBLE PRECISION TEMP2(MAXOBV/2) CCCCC FOLLOWING LINES ADDED FEBRUARY, 1994 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),TEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),TEMP2(1)) CCCCC END CHANGE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='DPGE' ISUBN2='NS ' 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 IFOUND='YES' C NS2=0 C C *********************************************** C ** TREAT THE MATH NUMBER GENERATION CASE ** C ** 1) FOR A FULL VARIABLE, OR ** C ** 2) FOR PART OF A VARIABLE. ** C *********************************************** C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)INCASE,IBUGA3,IBUGQ 52 FORMAT('INCASE,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NEWNAM='NO' NEWCOL='NO' C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************************************** C ** STEP 3-- * C ** EXAMINE THE LEFT-HAND SIDE-- * C ** IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN * C ** ALREADY IN THE NAME LIST? * C ** NOTE THAT ILEFT IS THE NAME OF THE VARIABLE * C ** ON THE LEFT. * C ** NOTE THAT ILISTL IS THE LINE IN THE TABLE * C ** OF THE NAME ON THE LEFT. * C ** NOTE THAT ICOLL IS THE DATA COLUMN (1 TO 12) * C ** FOR THE NAME OF THE LEFT. * C **************************************************************** C ISTEPN='3' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC ILEFT=IHOL(2) CCCCC ILEFT2=IHOL2(2) ILEFT=IHARG(1) ILEFT2=IHARG2(1) DO310I=1,NUMNAM I2=I IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'P')GOTO329 IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND. 1IUSE(I).EQ.'V')GOTO380 310 CONTINUE NEWNAM='YES' ILISTL=NUMNAM+1 IF(ILISTL.GT.MAXNAM)GOTO320 GOTO330 C 320 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('***** ERROR IN DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322) 322 FORMAT(' THE NUMBER OF VARIABLE AND/OR PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)MAXNAM 323 FORMAT(' NAMES HAS JUST EXCEEDED THE MAX ALLOWABLE ', 1I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324) 324 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325) 325 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326) 326 FORMAT(' TO FIND OUT THE FULL LIST OF USED NAMES,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327) 327 FORMAT(' AND THEN REDEFINE (REUSE) SOME OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,328) 328 FORMAT(' ALREADY-USED NAMES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 329 CONTINUE ILISTL=I2 GOTO330 C 330 CONTINUE NLEFT=0 ICOLL=NUMCOL+1 IF(ICOLL.GT.MAXCOL)GOTO340 GOTO390 C 340 CONTINUE WRITE(ICOUT,341) 341 FORMAT('***** ERROR IN DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,342) 342 FORMAT(' THE NUMBER OF DATA COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,343)MAXCOL 343 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,344) 344 FORMAT(' SUGGESTED ACTION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,345) 345 FORMAT(' ENTER STAT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,346) 346 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,347) 347 FORMAT(' AND THEN OVERWRITE SOME COLUMNS. EXAMPLE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,348) 348 FORMAT(' IF LET X(I) = 3.14 FAILED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,349) 349 FORMAT(' THEN ONE MIGHT ENTER NAME X 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,350) 350 FORMAT(' (THEREBY EQUATING THE NAME X WITH COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,351) 351 FORMAT(' FOLLOWED BY LET X = 3.14') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,352) 352 FORMAT(' (WHICH WILL ACTUALLY OVERWRITE COLUMN 7') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,353) 353 FORMAT(' WITH THE NUMERIC CONSTANTS 3.14)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 380 CONTINUE ILISTL=I2 ICOLL=IVALUE(ILISTL) NLEFT=IN(ILISTL) C 390 CONTINUE C C ***************************************** C ** STEP 6-- ** 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='6' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO670 DO610J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO620 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO620 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO630 610 CONTINUE GOTO680 C 620 CONTINUE ICASEQ='SUBS' ILOCQ=J1 GOTO680 C 630 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO680 C 670 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,671) 671 FORMAT('***** INTERNAL ERROR IN DPGENS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,672) 672 FORMAT(' AT BRANCH POINT 5081--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,673) 673 FORMAT(' NUMARG LESS THAN 1 EVEN THOUGH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,674) 674 FORMAT(' NUMARG HAD PREVIOUSLY PASSED THIS TEST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,675)NUMARG 675 FORMAT(' ONCE ALREADY. VALUE OF NUMARG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,676) 676 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,677)(IANS(I),I=1,IWIDTH) 677 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 680 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO690 WRITE(ICOUT,681)NUMARG,ILOCQ,ICASEQ 681 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') C 690 CONTINUE C C ****************************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ** (BASED ON THE QUALIFIER); ** C ** DETERMINE THE NUMBER (= NUMNUM) ** C ** OF NUMBERS TO BE GENERATED. ** C ** NOTE THAT THE VARIABLE NIISUB ** C ** IS THE LENGTH OF THE RESULTING ** C ** VARIABLE ISUB(.). ** C ** NOTE THAT DPFOR AUTOMATICALLY EXTENDS ** C ** THE INPUT LENGTH OF ISUB(.) IF NECESSARY. ** C ** (HENCE THE REDEFINITION OF NIISUB TO NINEW ** C ** AFTER THE CALL TO DPFOR. ** C ****************************************************** C ISTEPN='7' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL')GOTO710 IF(ICASEQ.EQ.'SUBS')GOTO720 IF(ICASEQ.EQ.'FOR')GOTO730 C 710 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN DO715I=1,NIISUB ISUB(I)=1 715 CONTINUE NUMNUM=NIISUB GOTO750 C 720 CONTINUE NIISUB=MAXN CALL DPSUBS(NIISUB,ILOCS,NS,IBUGQ,IERROR) NUMNUM=NS GOTO750 C 730 CONTINUE IF(NEWNAM.EQ.'NO')NIISUB=NLEFT IF(NEWNAM.EQ.'YES')NIISUB=MAXN CALL DPFOR(NIISUB,NINEW,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NIISUB=NINEW NUMNUM=NS GOTO750 C 750 CONTINUE C CCCCC THE ENTIRE SECTION 8 WAS REVAMPED IN ADDING LOGISTIC AND CANTOR APRIL 198 C ******************************************* C ** STEP 8-- ** C ** GENERATE NUMNUM NUMBERS ** C ** STORE THEM TEMPORARILY IN ** C ** THE VECTOR Y(.). ** C ******************************************* C ISTEPN='8' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(INCASE.EQ.'PRIM')GOTO1100 IF(INCASE.EQ.'FIBO')GOTO1200 IF(INCASE.EQ.'LOGI')GOTO1300 IF(INCASE.EQ.'CANT')GOTO1400 IF(INCASE.EQ.'BERN')GOTO1500 IF(INCASE.EQ.'EULE')GOTO1600 IFOUND='NO' GOTO9000 C 1100 CONTINUE CALL PRIMES(NUMNUM,Y,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1200 CONTINUE CALL FIBONN(NUMNUM,Y,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1300 CONTINUE IHP='X0 ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 Y0=VALUE(ILOCP) C IF(Y0.GE.0.0.AND.Y0.LE.1.0)GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE STARTING POINT X0') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' FOR THE LOGISTIC SEQUENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' X(N+1) = K * X(N) * (1 - X(N))') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' MUST BE BETWEEN 0 AND 1 INCLUSIVE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1317)Y0 1317 FORMAT(' THE CURRENT VALUE OF X0 IS ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1319 CONTINUE C IHP='K ' IHP2=' ' IHWUSE='P' MESSAG='YES' CALL CHECKN(IHP,IHP2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AK=VALUE(ILOCP) C IF(AK.GE.0.0.AND.AK.LE.4.0)GOTO1329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT('***** ERROR IN DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1322) 1322 FORMAT(' THE MULTIPLICATION FACTOR K') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1323) 1323 FORMAT(' FOR THE LOGISTIC SEQUENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1324) 1324 FORMAT(' X(N+1) = K * X(N) * (1 - X(N))') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT(' MUST BE BETWEEN 0 AND 4 INCLUSIVE;.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326) 1326 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1327)AK 1327 FORMAT(' THE CURRENT VALUE OF K IS ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1329 CONTINUE C CALL LOGIST(NUMNUM,Y,Y0,AK,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1400 CONTINUE CCCCC JULY 1993. SET P TO 0.33333 IF NOT PROVIDED. CCCCC DON'T CALL CHECKN (AVOID ERROR MESSAGE) IHP='P ' IHP2=' ' IHWUSE='P' MESSAG='YES' CCCCC CALL CHECKN(IHP,IHP2,IHWUSE, CCCCC1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, CCCCC1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR) CCCCC IF(IERROR.EQ.'YES')GOTO9000 CCCCC P=VALUE(ILOCP) P=0.333333 C IF(P.GE.0.0.AND.AK.LE.1.0)GOTO1419 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' THE FRACTIONAL HOLE SIZE P') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' FOR THE CANTOR SET') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' MUST BE BETWEEN 0 AND 1 INCLUSIVE;.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416)P 1416 FORMAT(' THE CURRENT VALUE OF P IS ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1419 CONTINUE C CALL CANTOR(NUMNUM,Y,P,TEMP,IERROR) IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1500 CONTINUE CALL BERNOB(NUMNUM,TEMP2(1)) DO1510I=1,NUMNUM IF(TEMP2(I).GE.DBLE(CPUMAX))THEN Y(I)=CPUMAX WRITE(ICOUT,1515) CALL DPWRST('XXX','BUG') 1515 FORMAT('**** ERROR: COMPUTED BERNOULLI NUMBER RESULTS ', 1 'IN OVERFLOW, SET TO MACHINE MAXIMUM.') ELSE Y(I)=SNGL(TEMP2(I)) ENDIF 1510 CONTINUE IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1600 CONTINUE CALL EULERB(NUMNUM,TEMP2(1)) DO1610I=1,NUMNUM IF(TEMP2(I).GE.DBLE(CPUMAX))THEN Y(I)=CPUMAX WRITE(ICOUT,1615) CALL DPWRST('XXX','BUG') 1615 FORMAT('**** ERROR: COMPUTED EULER NUMBER RESULTS ', 1 'IN OVERFLOW, SET TO MACHINE MAXIMUM.') ELSE Y(I)=SNGL(TEMP2(I)) ENDIF 1610 CONTINUE IF(IERROR.EQ.'YES')GOTO9000 GOTO1900 C 1900 CONTINUE C C *********************************************************** C ** STEP 8-- ** C ** IF CALLED FOR (THAT IS, IF IBUGA3 IS ON), ** C ** PRINT OUT THE INTERMEDIATE VARIABLE Y(.). ** C ** THIS IS USEFUL FOR DIAGNOSTIC PURPOSES ** C ** IN REVIEWING THE OUTPUT FROM THIS SUBROUTINE. ** C *********************************************************** C ISTEPN='9' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA3.EQ.'OFF')GOTO2090 WRITE(ICOUT,2051) 2051 FORMAT('OUTPUT FROM MIDDLE OF DPGENS AFTER INDIVIDUAL ', 1'GENERATORS HAVE BEEN CALLED--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2052)NUMNUM 2052 FORMAT('NUMNUM = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMNUM.LE.0)GOTO2090 DO2054I=1,NUMNUM WRITE(ICOUT,2055)I,Y(I) 2055 FORMAT('I,Y(I) = ',I8,F12.5) CALL DPWRST('XXX','BUG ') 2054 CONTINUE C 2090 CONTINUE C C ****************************************************** C ** STEP 9-- ** C ** COPY THE GENERATED NUMBERS ** C ** FROM THE INTERMEDIATE VECTOR Y(.) ** C ** TO THE APPROPRIATE COLUMN ** C ** (BASED ON THE QUALIFIER--FULL, SUBSET, OR FOR) ** C ** IN THE INTERNAL DATAPLOT DATA TABLE. ** C ****************************************************** C ISTEPN='10' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NS2=0 DO2100I=1,NIISUB IJ=MAXN*(ICOLL-1)+I IF(ISUB(I).EQ.0)GOTO2100 NS2=NS2+1 IF(ICOLL.LE.MAXCOL)V(IJ)=Y(NS2) IF(ICOLL.EQ.MAXCP1)PRED(I)=Y(NS2) IF(ICOLL.EQ.MAXCP2)RES(I)=Y(NS2) IF(ICOLL.EQ.MAXCP3)YPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP4)XPLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=Y(NS2) IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=Y(NS2) IF(NS2.EQ.1)IROW1=I IROWN=I 2100 CONTINUE C C ******************************************* C ** STEP 10-- ** C ** CARRY OUT THE LIST UPDATING AND ** C ** GENERATE THE INFORMATIVE PRINTING. ** C ******************************************* C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'NO')NINEW=NLEFT IF(ICASEQ.EQ.'FULL'.AND.NEWNAM.EQ.'YES')NINEW=MAXN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'SUBS'.AND.NEWNAM.EQ.'YES')NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.GE.IROWN)NINEW=NLEFT IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'NO'.AND. 1NLEFT.LT.IROWN)NINEW=IROWN IF(ICASEQ.EQ.'FOR'.AND.NEWNAM.EQ.'YES')NINEW=IROWN C IHNAME(ILISTL)=ILEFT IHNAM2(ILISTL)=ILEFT2 IUSE(ILISTL)='V' IVALUE(ILISTL)=ICOLL VALUE(ILISTL)=ICOLL IN(ILISTL)=NINEW C CCCCC IUSE(ICOLL)='V' CCCCC IVALUE(ICOLL)=ICOLL CCCCC VALUE(ICOLL)=ICOLL CCCCC IN(ICOLL)=NINEW C IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1 IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1 C DO4100J4=1,NUMNAM IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO4105 GOTO4100 4105 CONTINUE IUSE(J4)='V' IVALUE(J4)=ICOLL VALUE(J4)=ICOLL IN(J4)=NINEW 4100 CONTINUE C IF(IPRINT.EQ.'OFF')GOTO4059 IF(IFEEDB.EQ.'OFF')GOTO4059 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4011)ILEFT,ILEFT2,NS2 4011 FORMAT('THE NUMBER OF VALUES GENERATED FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IJ=MAXN*(ICOLL-1)+IROW1 IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,4021)ILEFT,ILEFT2,V(IJ),IROW1 IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,4021)ILEFT,ILEFT2,PRED(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,4021)ILEFT,ILEFT2,RES(IROW1),IROW1 IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3)WRITE(ICOUT,4021)ILEFT,ILEFT2,YPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP3)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4)WRITE(ICOUT,4021)ILEFT,ILEFT2,XPLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP4)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5)WRITE(ICOUT,4021)ILEFT,ILEFT2,X2PLOT(IROW1), 1IROW1 IF(ICOLL.EQ.MAXCP5)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6)WRITE(ICOUT,4021)ILEFT,ILEFT2,TAGPLO(IROW1), 1IROW1 4021 FORMAT('THE FIRST COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.EQ.MAXCP6)CALL DPWRST('XXX','BUG ') IJ=MAXN*(ICOLL-1)+IROWN IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,V(IJ),IROWN 4031 FORMAT('THE LAST (',I5,'-TH) COMPUTED VALUE OF ',A4,A4, 1' = ',E15.7,' (ROW ',I6,')') IF(ICOLL.LE.MAXCOL.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,PRED(IROWN),IROWN IF(ICOLL.EQ.MAXCP1.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,RES(IROWN),IROWN IF(ICOLL.EQ.MAXCP2.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,YPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP3.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,XPLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP4.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,X2PLOT(IROWN),IROWN IF(ICOLL.EQ.MAXCP5.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)WRITE(ICOUT,4031)NS2,ILEFT,ILEFT2,TAGPLO(IROWN),IROWN IF(ICOLL.EQ.MAXCP6.AND. 1NS2.NE.1)CALL DPWRST('XXX','BUG ') IF(NS2.NE.1)GOTO4090 WRITE(ICOUT,4041) 4041 FORMAT('SINCE THE GENERATED SAMPLE SIZE WAS ONLY 1,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4042) 4042 FORMAT('THE ABOVE VALUE WAS THE SOLE VALUE COMPUTED.') CALL DPWRST('XXX','BUG ') 4090 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4112)ILEFT,ILEFT2,ICOLL 4112 FORMAT('THE CURRENT COLUMN FOR ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4113)ILEFT,ILEFT2,NINEW 4113 FORMAT('THE CURRENT LENGTH OF ', 1'THE VARIABLE ',A4,A4,' = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 4059 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGENS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)INCASE,IBUGA3,IBUGQ 9013 FORMAT('INCASE,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NS2 9015 FORMAT('NS2 = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)NS,NIISUB,NUMNUM 9016 FORMAT('NS,NIISUB,NUMNUM = ',I8,I8,I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPGETC(IOUNI0,MAXWID,ITERCH,ICONCH,IANS,IANSLC,IWIDTH, 1IANSV,IWIDSV, 1IREPST,IREPPO,IANSSV,IREPMX,IPOINT, CCCCC ADD FOLLOWING LINE DECEMBER 1997. 1IPLTST,IPLTPO,IPLTSV, 1IPROSW, CCCCC THE FOLLOWING LINE WAS AUGMENTED AUGUST 1994 CCCCC1IMACRO,IMACNU,IMACCS, 1IMACRO,IMACNU,IMACCS,IMACL1,IMACL2,IMACLR,IMALEV, 1IPROGR, 1ICONCL, 1IEOF, 1IIFSW, 1ICAPSW,IPRDEF, 1IATXSW, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,IVARLB, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,ILOOST, 1IBUGS2,ISUBRO,IFOUND,IERROR) CCCCC THE ICAPSW AND IPRDEF ARGUMENTS ABOVE WERE ADDED JUNE 1989 C C PURPOSE--GET A COMMAND TO BE PROCESSED. C SUCH A COMMAND IS GOTTEN IN 2 WAYS-- C 1) TO READ FROM THE STANDARD C INPUT UNIT (THIS IS DONE C ONLY WHEN NO PREVIOUS COMMANDS C HAVE BEEN SAVED IN A BUFFER); C 2) TO EXTRACT THE NEXT COMMAND C STATEMENT IN THE SAVED BUFFER C (THIS IS DONE ONLY WHEN PREVIOUS C COMMANDS HAVE IN FACT BEEN SAVED C IN A BUFFER). C C INPUT ARGUMENTS--MAXWID (AN INTEGER VARIABLE WHICH C CONTAINS THE MAXIMUM NUMBER C OF CHARACTERS PER LINE C THAT MAY BE READ. C --ITERCH (A HOLLARITH VARIABLE C CONTAINING THE SEPARATOR CHARACTOR C WHICH MAY BE USED FOR SEPARATING C MULTIPLE COMMAND STATEMENTS PER LINE. C --ICONCH (A HOLLERITH VARIABLE C CONTAINING THE CONTINUE CHARACTER C WHICH MAY BE USED FOR EXTENDING COMMANDS C ONTO A SECOND LINE C --IANSV (A HOLLARITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C SAVED COMMAND LINE. C --IWIDSV (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE SAVED COMMAND LINE. C --IPOINT THE CURRENT POINTER POSITION C IN THE SAVE ARRAY WHERE THE CURRENT COMMAND C LINE WILL BE SAVED. C --ISAVPO IF IN REPEAT MODE EXECUTION, C THE CURRENT POINTER POSITION C IN THE SAVE ARRAY WOF THE COMMAND CURRENTLY C BEING EXECUTED. C OUTPUT ARGUMENTS--IANS (A HOLLARITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C CURRENT COMMAND STATEMENT C (BUT TRANSLATED TO UPPER CASE). C --IANSLC (A HOLLARITH VECTOR WHOSE C I-TH ELEMENT CONTAINS THE C I-TH CHARACTER OF THE C CURRENT COMMAND STATEMENT (UNCONVERTED, C AND SO MAY BE LOWER CASE). C --IWIDTH (AN INTEGER VARIABLE WHICH C CONTAINS THE NUMBER OF CHARACTERS C IN THE CURRENT COMMAND STATEMENT. C --IBUGS2 (A HOLLARITH VARIABLE C FOR DEBUGGING C --IERROR ('YES' OR 'NO' ) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 (AS A SEPARATE SUBROUTINE)--NOVEMBER 1980. C UPDATED--MAY 1982. C UPDATED--JANUARY 1983. C UPDATED--DECEMBER 1985. C UPDATED--DECEMBER 1988. SUPPRESS ERROR MESSAGE FOR \ IN FALSE IF C UPDATED--FEBRUARY 1989. CONTINUE CHARACTER (ALAN) C UPDATED--JUNE 1989. SUPPRESS ERROR MESSAGE FOR \ IN COMMENT C UPDATED--JUNE 1989. ADD ARGS AND ADJUST PROMPT FOR CAPTURE C UPDATED--JUNE 1991. READ FROM TURBO-C GUI MENU JJF C UPDATED--JUNE 1991. CHANGE NUMBERING (15XX TO 16XX) JJF C UPDATED--APRIL 1992. COMMENT OUT IOFILE C UPDATED--FEBRUARY 1993. POINTER PROBLEMS WITH / C UPDATED--FEBRUARY 1993. POINTER PROBLEMS WITH EOF C UPDATED--OCTOBER 1993. CONVERT NON-PRINTING TO SPACES C UPDATED--AUGUST 1994. EXECUTE SUBSET OF MACRO C UPDATED--NOVEMBER 1994. PROMPT FOR VAX C UPDATED--JANUARY 1995. ALLOW LIST TO BE SAVED C UPDATED--JULY 1996. FIX PROMPT FOR LAHEY PC IMPLEMENTATION C UPDATED--OCTOBER 1996. FIX PROMPT FOR MICROSOFT PC IMPLEMENTATION C UPDATED--NOVEMBER 1997. DON'T STORE COMMANDS STARTING WITH C "GUI" C UPDATED--DECEMBER 1997. REPLOT COMMAND C UPDATED--OCTOBER 1998. PROMPT FOR LAHEY GUI C UPDATED--JANUARY 2000. CALL LIST TO DPREP2 C UPDATED--AUGUST 2002. IATXSW (IF ON, PREPEND C "TEXT" TO COMMAND LINE) C UPDATED--DECEMBER 2004. DO NOT ALLOW CONTINUATION LINES WHILE C RUNNING THE GUI C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C INCLUDE 'DPCOPA.INC' C CHARACTER*4 ITERCH CHARACTER*4 IANS CHARACTER*4 IANSLC CHARACTER*4 IANSV CHARACTER*4 IPROSW CHARACTER*4 IMACRO CHARACTER*12 IMACCS C CHARACTER*4 IPROGR CHARACTER*4 ICONCL CHARACTER*4 IEOF CHARACTER*4 IIFSW CHARACTER*4 IATXSW C CHARACTER*4 IREPST CHARACTER*1 IANSSV CCCCC FOLLOWING 2 LINES ADDED DECEMBER 1997. CHARACTER*4 IPLTST CHARACTER*1 IPLTSV C CHARACTER*4 ILOOST C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFUNC CHARACTER*40 IVARLB(*) C CHARACTER*1 IREPCH C CHARACTER*1 IC1 CHARACTER*4 IC4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN 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 IREWIN CHARACTER*4 IENDFI CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CCCCC CHARACTER*1 IA CCCCC CHARACTER*4 IA4I CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994 CCCCC OCTOBER 1994. FOLLOWING LINE CAUSES ERROR ON SOME MACHINES CCCCC (IA IS DECLARED IN DPCOFO INCLUDE FILE). CCCCC CHARACTER*4 IA C CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1991 CHARACTER*80 IB C CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1989 CHARACTER*4 ICAPSW C CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1992 CHARACTER*80 STRING C CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1993 CCCCC CHARACTER*5 IANS5 C DIMENSION IANS(*) DIMENSION IANSLC(*) DIMENSION IANSV(*) C DIMENSION IANSSV(MAXLIS,MAXCIS) CCCCC ADD FOLLOWING LINE DECEMBER 1997. DIMENSION IPLTSV(MAXLIP,MAXCIS) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IFUNC(*) C CCCCC DIMENSION IA(132) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOFO.INC' INCLUDE 'DPCOF2.INC' CCCCC THE FOLLOWING 2 LINES WERE ADDED JUNE 1991 JJF INCLUDE 'DPCOWI.INC' INCLUDE 'DPCODV.INC' CCCCC THE FOLLOWING LINE WAS ADDED OCTOBER 1998 INCLUDE 'DPCONP.INC' CCCCC THE FOLLOWING LINE WAS ADDED DECEMBER 2004 INCLUDE 'DPCOST.INC' C CCCCC BEGIN FIX CCCCC ADD A CONTINUE CHARACTER (DEFAULT = ...) (AUGUST 1987 & FEBRUARY 1989) CHARACTER*4 ICONCH CHARACTER*1 IATEMP CCCCC END FIX CCCCC ADD FOLLOWING LINES FEBRUARY 1998. CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT DIMENSION IHARG(1) DIMENSION IHARG2(1) DIMENSION IARGT(1) DIMENSION IARG(1) DIMENSION ARG(1) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C CCCCC IBUGS2='ON' ISUBN1='DPGE' ISUBN2='TC ' C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGETC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IOUNI0,MAXWID,ITERCH 52 FORMAT('IOUNI0,MAXWID,ITERCH = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IHOST1,TCMENU 53 FORMAT('IHOST1,TCMENU = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IWIDSV 54 FORMAT('IWIDSV = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDSV.GE.1)WRITE(ICOUT,56)(IANSV(I),I=1,IWIDSV) 56 FORMAT('(IANSV(I),I=1,IWIDSV) = ',100A1) IF(IWIDSV.GE.1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)IREPST,IREPPO,IREPMX,IPOINT 60 FORMAT('IREPST,IREPPO,IREPMX,IPOINT = ',A4,3I8) CALL DPWRST('XXX','BUG ') DO62J=1,IREPMX WRITE(ICOUT,63)J,(IANSSV(J,I),I=1,80) 63 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) CALL DPWRST('XXX','BUG ') 62 CONTINUE WRITE(ICOUT,64)ICAPSW,IPR,IPRDEF 64 FORMAT('ICAPSW,IPR,IPRDEF = ',A4,2I8) CALL DPWRST('XXX','BUG ') C WRITE(ICOUT,69)IBUGS2,IFOUND,IERROR 69 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IOUNI0,IPROGR 71 FORMAT(',IOUNI0,IPROGR = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,76)NUMCHA 76 FORMAT('NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,77)(IA(I),I=1,10) 77 FORMAT('IA(.) = ',10A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,78)IWIDTH 78 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,79)(IANS(I),I=1,IWIDTH) 79 FORMAT('IANS(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,80)(IANSLC(I),I=1,IWIDTH) 80 FORMAT('IANSLC(.) = ',120A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,81)IMACRO,IMACNU,IMACCS 81 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,82)IMACL1,IMACL2,IMACLR 82 FORMAT(1H ,'IMACL1,IMACL2,IMACLR = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,83)IPROSW 83 FORMAT('IPROSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,84)IPRONU,IPRONA 84 FORMAT('IPRONU,IPRONA = ',I8,2X,A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,85)ICRENU,ICRENA 85 FORMAT('ICRENU,IPRONA = ',I8,2X,A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,86)IPROGR,IPRONU 86 FORMAT('IPROGR,IPRONU = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,87)ICONCL,ICONNU 87 FORMAT('ICONCL,ICONNU = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,88)IEOF,IIFSW 88 FORMAT('IEOF,IIFSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,89)IREPCH 89 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,90)ILOOST 90 FORMAT('ILOOST = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C AUGUST, 1987: DETERMINE THE NUMBER OF CHARACTERS C USED IN CONTINUE CHARACTER NCCNT=0 DO91I=4,1,-1 NCCNT=I IF(ICONCH(I:I).NE.' ')GOTO92 91 CONTINUE NCCNT=0 92 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN WRITE(ICOUT,93)NCCNT CALL DPWRST('XXX','BUG ') WRITE(ICOUT,94)(ICONCH(J:J),J=1,4) 93 FORMAT('NUMBER OF CHARACTERS IN CONTINUE CHARACTER = ',I4) CALL DPWRST('XXX','BUG ') 94 FORMAT('ICONCH(1:1)=',A1,'ICONCH(2:2)=',A1,'ICONCH(3:3)=',A1, 1 'ICONCH(4:4)=',A1) ENDIF C END PATCH C C ************************************** C ** STEP 1-- ** C ** COPY THE INPUT VARIABLE IOUNI0 ** C ** INTO THE LOCAL VARIABLE IOUNIT ** C ************************************** C ISTEPN='1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=IOUNI0 C C ************************************************************ C ** STEP 10-- ** C ** GET A NEW FULL COMMAND LINE INTO IANSLC(.) AND C ** BY EITHER USING THE SAVED LINE (IF ANY) IN IANSV(.), ** C ** OR BY READING IN A COMPLETELY NEW LINE ** C ** FROM THE STANDARD INPUT UNIT. ** C ************************************************************ C ISTEPN='10' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1010I=1,MAXSTR IANS(I)=' ' IANSLC(I)=' ' 1010 CONTINUE C IF(IWIDSV.GT.0)THEN DO1020I=1,IWIDSV IANSLC(I)=IANSV(I) 1020 CONTINUE IWIDTH=IWIDSV CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) GOTO2100 ENDIF C C ******************************************* C ** STEP 11-- ** C ** CHECK TO SEE IF REPEATING A COMMAND ** C ******************************************* C IF(IREPST.EQ.'OFF')GOTO1190 C ISTEPN='11' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,MAXWID IANS(I)=' ' IANSLC(I)=' ' IC1=IANSSV(IREPPO,I) IANSLC(I)=IC1 1110 CONTINUE C CCCCC BEGIN FIX CCCCC CHECK FOR CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) IWIDTH=MAXWID IF(NCCNT.EQ.0)GOTO1180 DO1120I=1,MAXWID-NCCNT+1 DO1125J=1,NCCNT K=I+J-1 IATEMP=IANSLC(K) IF(IATEMP.NE.ICONCH(J:J))GOTO1120 1125 CONTINUE C C GET NEXT LINE C IF(IGUIFL.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT('****** ERROR: CONTINUATION LINES NOT SUPPORTED ', 1 'IN GUI.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127) 1127 FORMAT(' CURRENT LINE IGNORED.') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IREPPO=IREPPO+1 IF(IREPPO.GT.MAXLIS)IREPPO=1 K=0 IFIRST=I IWIDTH=IFIRST+MAXWID-1 IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR DO1130J=IFIRST,IWIDTH K=K+1 IANSLC(J)=' ' IC1=IANSSV(IREPPO,K) IANSLC(J)=IC1 1130 CONTINUE GOTO1180 C 1120 CONTINUE C 1180 CONTINUE DO1185I=MAXSTR,1,-1 IWIDTH=I IF(IANSLC(I).NE.' ')GOTO1189 1185 CONTINUE 1189 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN WRITE(ICOUT,1181)IWIDTH,IANSLC(IWIDTH) 1181 FORMAT('FROM 1180, IWIDTH,IANSLC(IWIDTH)=',I4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF CCCCC END FIX C CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) GOTO2100 1190 CONTINUE C C ******************************************* C ** STEP 11B- ** C ** CHECK TO SEE IF HAVE REPLOT COMMAND ** C ******************************************* C IF(IPLTST.EQ.'OFF')GOTO1290 C ISTEPN='11B' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1210I=1,MAXWID IANS(I)=' ' IANSLC(I)=' ' IC1=IPLTSV(IPLTPO,I) IANSLC(I)=IC1 1210 CONTINUE C CCCCC DON'T SUPPORT CONTINUATION CHARACTER FOR THIS COMMAND CCCCC AT THIS POINT. C 1280 CONTINUE DO1285I=MAXSTR,1,-1 IWIDTH=I IF(IANSLC(I).NE.' ')GOTO1289 1285 CONTINUE 1289 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1WRITE(ICOUT,1281)IWIDTH,IANSLC(IWIDTH) 1281 FORMAT('FROM 1180, IWIDTH,IANSLC(IWIDTH)=',I4,2X,A4) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL DPWRST('XXX','BUG ') C CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) GOTO2100 1290 CONTINUE C C ***************************************************** C ** STEP 13-- ** C ** CHECK TO SEE IF READING FROM THE PROGRAM FILE ** C ***************************************************** C IF(IPROGR.EQ.'EXEC')GOTO1310 GOTO1390 C 1310 CONTINUE ISTEPN='13' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC IOUNIT=IPRONU CCCCC IFILE=IPRONA CCCCC ISTAT=IPROST CCCCC IFORM=IPROFO CCCCC IACCES=IPROAC CCCCC IPROT=IPROPR CCCCC ICURST=IPROCS C ISUBN0='GETC' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'GETC')GOTO1329 WRITE(ICOUT,1323)IOUNIT 1323 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1324)IFILE 1324 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325)ISTAT,IFORM,IACCES,IPROT,ICURST 1325 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326)ISUBN0,IERRFI 1326 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1329 CONTINUE C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1WRITE(ICOUT,1371) 1371 FORMAT('***** A LINE FROM THE PROGRAM FILE SHOULD BE ', 1'READ IN AT THIS TIME.') IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL DPWRST('XXX','BUG ') C CCCCC THE FOLLOWING SECTION WAS UPDATED AUGUST 1994 CCCCC WRITE(6,777)IMACL1,IMACL2,IMACLR CC777 FORMAT(1H ,'IMACL1,IMACL2,IMACLR = ',3I8) C IF(IMACLR.LT.IMACL2)THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IMACLR=IMACLR+1 IF(IERROR.EQ.'YES')GOTO9000 ELSE IA(1)='E' IA(2)='O' IA(3)='F' NUMCHA=3 ENDIF C IF(NUMCHA.EQ.3.AND. 1IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')GOTO1370 GOTO1379 1370 CONTINUE IF(IOUNIT.EQ.IPRONU)IPROGR='EOF' IF(IOUNIT.EQ.ICONNU)ICONCL='EOF' IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF' IEOF='YES' 1379 CONTINUE C IWIDTH=NUMCHA DO1380I=1,NUMCHA CCCCC IA4I=' ' CCCCC IA4I(1:1)=IA(I) CCCCC IANS(I)=IA4I IANSLC(I)=IA(I) 1380 CONTINUE C CCCCC BEGIN FIX CCCCC CHECK FOR CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) IF(NCCNT.EQ.0)GOTO1389 DO1381I=1,IWIDTH-NCCNT+1 DO1382J=1,NCCNT K=I+J-1 IATEMP=IANSLC(K) IF(IATEMP.NE.ICONCH(J:J))GOTO1381 1382 CONTINUE C C GET NEXT LINE C NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IA,NUMCHA, 1ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(NUMCHA.EQ.3.AND. 1IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')GOTO1375 GOTO1378 1375 CONTINUE IF(IOUNIT.EQ.IPRONU)IPROGR='EOF' IF(IOUNIT.EQ.ICONNU)ICONCL='EOF' IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF' IEOF='YES' 1378 CONTINUE C IFIRST=I NTEMP=0 DO1388J=NUMCHA,1,-1 NTEMP=J IF(IA(J).NE.' ')GOTO1387 1388 CONTINUE 1387 CONTINUE IWIDTH=IFIRST+NTEMP-1 C NOTE: IANSLC DIMENSIONED TO 200 IN INCLUDE FILE DPCOHK IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR K=0 DO1383J=IFIRST,IWIDTH K=K+1 IANSLC(J)=IA(K) 1383 CONTINUE GOTO1389 1381 CONTINUE C 1389 CONTINUE CCCCC END FIX C CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) GOTO2100 C 1390 CONTINUE C C ***************************************************** C ** STEP 14-- ** C ** CHECK TO SEE IF READING FROM A MACRO FILE ** C ***************************************************** C IF(IMACRO.EQ.'EXEC')GOTO1410 GOTO1490 C 1410 CONTINUE ISTEPN='14' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC IOUNIT=ICRENU CCCCC IFILE=ICRENA CCCCC ISTAT=ICREST CCCCC IFORM=ICREFO CCCCC IACCES=ICREAC CCCCC IPROT=ICREPR CCCCC ICURST=ICRECS C ISUBN0='GETC' IERRFI='NO' C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'GETC')GOTO1429 WRITE(ICOUT,1423)IOUNIT 1423 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1424)IFILE 1424 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1425)ISTAT,IFORM,IACCES,IPROT,ICURST 1425 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ', 1A12,2X,A12,2X,A12,2X,A12,2X,A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1426)ISUBN0,IERRFI 1426 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 1429 CONTINUE C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1WRITE(ICOUT,1451)IOUNIT 1451 FORMAT('***** A LINE FROM MACRO FILE ',I8,' SHOULD BE ', 1'READ IN AT THIS TIME.') IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL DPWRST('XXX','BUG ') C CCCCC THE FOLLOWING SECTION WAS UPDATED AUGUST 1994 CCCCC WRITE(6,777)IMACL1,IMACL2,IMACLR IF(IMACLR.LT.IMACL2)THEN NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IA,NUMCHA, 1 ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IMACLR=IMACLR+1 IF(IERROR.EQ.'YES')GOTO9000 ELSE IA(1)='E' IA(2)='O' IA(3)='F' NUMCHA=3 ENDIF C IF(NUMCHA.EQ.3.AND. 1IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')GOTO1470 GOTO1479 1470 CONTINUE IF(IOUNIT.EQ.IPRONU)IPROGR='EOF' IF(IOUNIT.EQ.ICONNU)ICONCL='EOF' IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF' IEOF='YES' 1479 CONTINUE C IWIDTH=NUMCHA DO1480I=1,NUMCHA CCCCC IA4I=' ' CCCCC IA4I(1:1)=IA(I) CCCCC IANS(I)=IA4I IANSLC(I)=IA(I) 1480 CONTINUE C CCCCC BEGIN FIX CCCCC CHECK FOR CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) IF(NCCNT.EQ.0)GOTO1489 DO1481I=1,IWIDTH-NCCNT+1 DO1482J=1,NCCNT K=I+J-1 IATEMP=IANSLC(K) IF(IATEMP.NE.ICONCH(J:J))GOTO1481 1482 CONTINUE C C GET NEXT LINE C NUMCHA=-1 CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IA,NUMCHA, 1ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C IF(NUMCHA.EQ.3.AND. 1IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F')GOTO1475 GOTO1478 1475 CONTINUE IF(IOUNIT.EQ.IPRONU)IPROGR='EOF' IF(IOUNIT.EQ.ICONNU)ICONCL='EOF' IF(IOUNIT.NE.IPRONU.AND.IOUNIT.NE.ICONNU)IMACRO='EOF' IEOF='YES' 1478 CONTINUE C IFIRST=I NTEMP=0 DO1488J=NUMCHA,1,-1 NTEMP=J IF(IA(J).NE.' ')GOTO1487 1488 CONTINUE 1487 CONTINUE IWIDTH=IFIRST+NTEMP-1 C NOTE: IANSLC DIMENSIONED TO 200 IN INCLUDE FILE DPCOHK IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR K=0 DO1483J=IFIRST,IWIDTH K=K+1 IANSLC(J)=IA(K) 1483 CONTINUE GOTO1489 1481 CONTINUE C 1489 CONTINUE CCCCC END FIX C CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) GOTO2100 C 1490 CONTINUE C CCCCC THE FOLLOWING SECTION IS NEW JUNE 1991 JJF C ***************************************************** C ** STEP 15-- ** C ** CHECK TO SEE IF READING FROM THE ** C ** FRONT-END GRAPHICAL USER INTERFACE MENU ** C ***************************************************** C IF(IHOST1.EQ.'IBM-'.AND.TCMENU.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE ISTEPN='15' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISTEPN='15.1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL TCGECO(IB,NUMCHA,IBUGS2,ISUBRO) C IF(NUMCHA.LE.0)GOTO1590 ISTEPN='15.2' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWIDTH=NUMCHA DO1580I=1,NUMCHA CCCCC IANSLC(I)=IA(I) IC4=' ' IC4(1:1)=IB(I:I) IANSLC(I)=IC4 1580 CONTINUE C CCCCC CHECK FOR CONTINUATION CHARACTER C IF(NCCNT.EQ.0)GOTO1589 DO1581I=1,IWIDTH-NCCNT+1 DO1582J=1,NCCNT K=I+J-1 IATEMP=IANSLC(K) IF(IATEMP.NE.ICONCH(J:J))GOTO1581 1582 CONTINUE C CCCCC IF HAVE CONTINUATION, THEN GET NEXT LINE. C ISTEPN='15.3' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL TCGECO(IB,NUMCHA,IBUGS2,ISUBRO) C ISTEPN='15.4' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFIRST=I NTEMP=0 DO1588J=NUMCHA,1,-1 NTEMP=J CCCCC IF(IA(J).NE.' ')GOTO1587 CCCCC IF(IB(J).NE.' ')GOTO1587 IF(IB(J:J).NE.' ')GOTO1587 1588 CONTINUE 1587 CONTINUE IWIDTH=IFIRST+NTEMP-15 C NOTE: IANSLC DIMENSIONED TO 200 IN INCLUDE FILE DPCOHK IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR K=0 DO1583J=IFIRST,IWIDTH K=K+1 CCCCC IANSLC(J)=IA(K) IC4=' ' IC4(1:1)=IB(K:K) IANSLC(J)=IC4 1583 CONTINUE GOTO1589 1581 CONTINUE C 1589 CONTINUE C ISTEPN='15.5' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) ISTEPN='15.6' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) GOTO2100 C 1590 CONTINUE C CCCCC THE FOLLOWING SECTION HAD NUMBERS CHANGED JUNE 1991 CCCCC (15XX TO 16XX) JUNE 1991 C ***************************************************** C ** STEP 16-- ** C ** IF NOT READING FROM THE PROGRAM FILE, AND ** C ** IF NOT READING FROM A MACRO FILE, AND ** C ** IF NOT READING FROM A FRONT-END GUI MENU, ** C ** THEN READ FROM THE STANDARD INPUT FILE. ** C ** (IF CALLED FOR, WRITE OUT A PROMPT (>) FIRST. ** C ***************************************************** C CCCCC FEBRUARY 1998 UPDATE. FOR TCL/TK GUI, WINDOWS 95 VERSION CCCCC NEEDS SPECIAL HANDLING. THIS IS CONTROLLED BY ENVIRONMENT CCCCC VARIABLE "DATAPLOT_GUI_IO". IF EQUAL TO PIPE, DO STANDARD CCCCC READ AS BEFORE. HOWEVER, IF "FILE", THEN SPECIAL CODE. 1600 CONTINUE C ISTEPN='16' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING LINE WAS FIXED JUNE 1989 CCCCC IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(ICOUT,1611) CCCCC IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)CALL DPWRST('XXX','BUG ') CCCCC FOR VAX, NEED 1X ON FORMAT. NOVEMBER 1994. CCCCC IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(IPRDEF,1611) CCCCC ADD SUPPORT FOR IBM/PC LAHEY COMPILER. JULY 1996. CCCCC ADD SUPPORT FOR IBM/PC MICROSOFT COMPILER. OCTOBER 1996. CCCCC IF(IHOST1.NE.'VAX')THEN IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'LAHE')THEN IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(IPRDEF,1612) 1 ICRC,ILFC ELSEIF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')THEN IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(IPRDEF,1613) ELSEIF(IHOST1.NE.'VAX')THEN IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(IPRDEF,1611) ELSE IF(IPROSW.EQ.'ON'.AND.IOUNIT.EQ.IRD)WRITE(IPRDEF,1616) ENDIF 1611 FORMAT('>') 1612 FORMAT(1X,'>',A1,A1) 1613 FORMAT(1X,'>') CQWIN 1613 FORMAT(1X,'>',\ ) 1616 FORMAT(1X,'>') C CCCCC IOUNIT=IRD CCCCC JANUARY 1998. FOR TCL/TK FRONTEND, FLUSH STANDARD OUTPUT. CALL DPFLSH(IPR,IBUGS2,ISUBRO,IFOUND,IERROR) C IF(IGUIIO.EQ.'FILE')GOTO16200 C CCCCC STANDARD CASE READ(IOUNIT,1621,END=1630)(IANSLC(I),I=1,MAXWID) 1621 FORMAT(80A1) IWIDTH=MAXWID C CCCCC BEGIN FIX CCCCC CHECK FOR CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) IF(NCCNT.EQ.0)GOTO1640 DO1641I=1,MAXWID-NCCNT+1 DO1642J=1,NCCNT K=I+J-1 IATEMP=IANSLC(K) IF(IATEMP.NE.ICONCH(J:J))GOTO1641 1642 CONTINUE C C GET NEXT LINE C IFIRST=I IWIDTH=IFIRST+MAXWID-1 IF(IWIDTH.GT.MAXSTR)IWIDTH=MAXSTR READ(IOUNIT,1621,END=1630)(IANSLC(J),J=IFIRST,IWIDTH) GOTO1640 1641 CONTINUE C 1640 CONTINUE GOTO16900 C CCCCC SPECIAL CODE FOR WINDOWS 95 VERSION. 16200 CONTINUE IOTEMP=10 DO16210KK=1,1 16290 CONTINUE OPEN(UNIT=IOTEMP,FILE='fort.10',FORM='FORMATTED', 1 STATUS='OLD',ERR=16291) REWIND(IOTEMP) READ(IOTEMP,1621,END=16210)(IANSLC(I),I=1,MAXWID) CLOSE(IOTEMP,STATUS='DELETE') IWIDTH=MAXWID C GOTO16210 16291 CONTINUE IHARG(1)='1.0' IHARG2(1)=' ' IARGT(1)='NUMB' ARG(1)=1.0 IARG(1)=1 NUMARG=1 CALL DPSLEE(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1 IBUGS2,ISUBRO,IFOUND,IERROR) GOTO16290 C 16210 CONTINUE GOTO16900 C 16900 CONTINUE C CCCCC CALL DPUPPE(IANSLC,MAXWID,IANS,IBUGS2,IERROR) ISTEPN='16.1' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) ISTEPN='16.2' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) CCCCC END FIX C GOTO1690 C 1630 CONTINUE IF(IHOST1.EQ.'CDC')GOTO1631 GOTO1690 C 1631 CONTINUE CCCCC CLOSE(IRD) ICURST='OPEN' IENDFI='OFF' IREWIN='OFF' ISUBN0='GETC' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) CCCCC OPEN(IRD,FILE='INPUT') ICURST='CLOSED' IREWIN='OFF' ISUBN0='GETC' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR) GOTO1690 C 1690 CONTINUE CCCCC IWIDTH=MAXWID GOTO2100 C C ****************************************************** C ** STEP 21-- ** C ** DETERMINE IF IANSLC(.) CONSISTS OF MULTIPLE COMMAND ** C ** STATEMENTS (AS IS POSSIBLE BY THE ** C ** USE OF SEPARATOR CHARACTERS IN THE TEXT), ** C ** IF SO, THEN UPDATE IANSLC(.), IWIDTH, ** C ** IANSV(.), AND IWIDSV BY TRUNCATING ** C ** IANSLC(.) AT THE FIRST SEPARATION CHARACTER, ** C ** AND COPYING THE REST OF IANSLC(.) INTO IANSV(.). ** C ****************************************************** C 2100 CONTINUE C ISTEPN='21' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPSPLC(IANSLC,IWIDTH,ITERCH, 1IANSV,IWIDSV,IBUGS2,IERROR) C CCCCC ******************************************************* CCCCC ** STEP 22-- ** CCCCC ** CONVERT EACH CHARACTER IN IANS(.) TO UPPER CASE ** CCCCC ** (UNLESS ALREADY IN UPPER CASE). ** CCCCC ******************************************************* CCCCC CCCCC ISTEPN='22.2' CCCCC IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') CCCCC1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) CCCCC CCCCC CALL DPUPPE(IANS,IWIDTH,IANS,IBUGS2,IERROR) CCCCC C ******************************************************* C ** STEP 23-- ** C ** SCAN THE ENTIRE STRING-- ** C ** SEARCH FOR THE SUBSTITUTION-VALUE CHARACTER. ** C ** IF FOUND (AND IF WE ARE NOT IN THE MIDDLE OF ** C ** STORING THE BODY OF A LOOP), C ** THEN FORM A NEW STRING BY SUBSTITUTING ** C ** THE VALUE OF THE IMMEDIATELY SUCCEEDING VARIABLE ** C ** IF NOT FOUND (OR IF WE ARE IN THE MIDDLE OF ** C ** STORING THE BODY OF A LOOP), ** C ** THEN DO NOTHING. ** C ** FINALLY (AND IN ALL CASES) CONVERT TO UPPER CASE ** C ******************************************************* C ISTEPN='23' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC CALL DPREP2(IANS,IWIDTH, NOVEMBER 4, 1986 IF(ILOOST.EQ.'STOR')GOTO2310 CCCCC THE FOLLOWING IF STATEMENT WAS ADDED DECEMBER 1988 CCCCC TO SUPPRESS AN EXTRANEOUS ERROR MESSAGE DECEMBER 1988 CCCCC WHEN HAVE A BACKSLASH IN A FALSE IF DECEMBER 1988 CCCCC CALL DPREP2(IANSLC,IWIDTH, DECEMBER 1988 CCCCC IF(IIFSW.EQ.'TRUE') CCCCC THE FOLLOWING IF STATEMENT WAS ADDED JUNE 1989 CCCCC TO CORRECT THE PROBLEM OF ATTEMPTING TO SUBSTITUTE JUNE 1989 CCCCC WITHIN A COMMENT LINE (UNNEEDED) JUNE 1989 IF(IIFSW.EQ.'TRUE'.AND.IANSLC(1).NE.'.') 1CALL DPREP2(IANSLC,IWIDTH, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVARLB, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1IMALEV, 1IBUGS2,IERROR) 2310 CONTINUE CALL DPNONP(IANSLC,IWIDTH,IANSLC,IBUGS2,IERROR) CALL DPUPPE(IANSLC,IWIDTH,IANS,IBUGS2,IERROR) CCCCC AUGUST 2002. IF AUTO TEXT ON, THE PREPEND "TEXT" TO COMMAND CCCCC LINE. BUT CHECK TO SEE IF "AUTO TEXT" COMMAND IS BEING CCCCC ENTERED. IF(IATXSW.EQ.'ON')THEN IF(IANS(1).EQ.'A'.AND.IANS(2).EQ.'U'.AND.IANS(3).EQ.'T'.AND. 1 IANS(4).EQ.'O'.AND.IANS(5).EQ.' '.AND.IANS(6).EQ.'T'.AND. 1 IANS(7).EQ.'E'.AND.IANS(8).EQ.'X'.AND.IANS(9).EQ.'T') 1 GOTO2109 DO2105I=MIN(IWIDTH,MAXWID-4),1,-1 IANSLC(I+5)=IANSLC(I) IANS(I+5)=IANS(I) 2105 CONTINUE IANSLC(1)='T' IANSLC(2)='E' IANSLC(3)='X' IANSLC(4)='T' IANSLC(5)=' ' IANS(1)='T' IANS(2)='E' IANS(3)='X' IANS(4)='T' IANS(5)=' ' IWIDTH=MIN(MAXWID,IWIDTH+5) 2109 CONTINUE ENDIF C C C ********************************** C ** STEP 80-- ** C ** STORE THE LINE ** C ** IN THE SAVE TABLE, ** C ** FOR FUTURE USE BY THE ** C ** REPEAT COMMAND. ** C ** NOTE-- ** C ** CERTAIN COMMANDS ARE NOT TO ** C ** BE STORED, NAMELY-- ** C ** LIST (AND L AND RECALL) ** C ** REPEAT (AND R) ** C ** SAVE (AND S) ** C ** SPACE BAR COMMAND (CHANGED TO / TEMPORARILY) ** C ** CARRIAGE RETURN ONLY (= NO-OP COMMAND) ** C ** NOVEMBER 1997: ** C ** GUI STATUS ** C ** GUI WRITE/PRINT ** C ** BASICALLY, ANY COMMAND ** C ** STARTING WITH "GUI" ** C ********************************** C 8000 CONTINUE C ISTEPN='80' IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1WRITE(ICOUT,8001)IANS(1),IANS(2),IWIDTH 8001 FORMAT('IANS(1),IANS(2),IWIDTH = ',A4,2X,A4,I8) IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC') 1CALL DPWRST('XXX','BUG ') C IF(IREPST.EQ.'ON')GOTO8190 C CCCCC THE FOLLOWING 2 LINES WERE ADJUSTED JANUARY 1995 CCCCC TO ALLOW LIST TO BE SAVED JANUARY 1995 CCCCC IF(IANS(1).EQ.'L'.AND.IANS(2).EQ.'I'.AND. CCCCC1IANS(3).EQ.'S'.AND.IANS(4).EQ.'T')GOTO8190 IF(IANS(1).EQ.'L'.AND.IANS(2).EQ.'I'.AND. 1IANS(3).EQ.'S'.AND.IANS(4).EQ.'T'.AND.IWIDTH.LE.5)GOTO8190 IF(IANS(1).EQ.'L'.AND.IANS(2).EQ.' ')GOTO8190 IF(IANS(1).EQ.'L'.AND.IWIDTH.LE.1)GOTO8190 IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.'E'.AND. 1IANS(3).EQ.'C'.AND.IANS(4).EQ.'A')GOTO8190 C IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.'E'.AND. 1IANS(3).EQ.'P'.AND.IANS(4).EQ.'E')GOTO8190 IF(IANS(1).EQ.'R'.AND.IANS(2).EQ.' ')GOTO8190 IF(IANS(1).EQ.'R'.AND.IWIDTH.LE.1)GOTO8190 C IF(IANS(1).EQ.'S'.AND.IANS(2).EQ.'A'.AND. 1IANS(3).EQ.'V'.AND.IANS(4).EQ.'E')GOTO8190 IF(IANS(1).EQ.'S'.AND.IANS(2).EQ.' ')GOTO8190 IF(IANS(1).EQ.'S'.AND.IWIDTH.LE.1)GOTO8190 C CCCCC FOLLOWING LINE TO CHECK FOR "GUI" ADDED. NOVEMBER 1997. IF(IANS(1).EQ.'G'.AND.IANS(2).EQ.'U'.AND. 1IANS(3).EQ.'I'.AND.IANS(4).EQ.' ')GOTO8190 CCCCC IF(IANS(1).EQ.' '.AND.IWIDTH.LE.1)GOTO8190 CCCCC THE FOLLOWING LINE WAS FIXED FEBRUARY 1993 CCCCC IF(IANS(1).EQ.'/'.AND.IWIDTH.LE.1)GOTO8190 IF(IANS(1).EQ.'/'.AND.IWIDTH.LE.1)THEN IPOINT=IPOINT-1 IF(IPOINT.LE.0)IPOINT=IREPMX GOTO8190 ENDIF CCCCC THE FOLLOWING 6 LINES WERE ADDED FEBRUARY 1993 IF(IANS(1).EQ.'E'.AND.IANS(2).EQ.'O'.AND. 1IANS(3).EQ.'F')THEN IPOINT=IPOINT-1 IF(IPOINT.LE.0)IPOINT=IREPMX GOTO8190 ENDIF C IF(IWIDTH.LE.0)GOTO8190 C CCCCC DO8100I=1,IWIDTH APRIL 22, 1987 C CCCCC BEGIN FIX CCCCC CHECK FOR CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) CCCCC HANDLE CASE WHERE CONTINUE CHARACTER (AUGUST 1987 & FEBRUARY 1989) CCCCC MAKES LINE EXCEED 80 CHARACTERS. (AUGUST 1987 & FEBRUARY 1989) CCCCC CURRENTLY ASSUME MAXIMUM OF 2 LINES. (AUGUST 1987 & FEBRUARY 1989) C C FOLLOWING 5 LINES CAUSED BUG WITH "LET K=3; READ X1 TO X\K" CCCCC DO8010I=MAXSTR,1,-1 CCCCC IWIDTH=I CCCCC IF(IANSLC(I).NE.' ')GOTO8020 C8010 CONTINUE CC020 CONTINUE C DO8110I=1,MAXCIS IANSSV(IPOINT,I)=' ' 8110 CONTINUE C IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'GETC')GOTO8025 WRITE(ICOUT,8030)MAXSTR,IWIDTH,IPOINT 8030 FORMAT('MAXSTR,IWIDTH,IPOINT=',I4,2X,I4,2X,I4) CALL DPWRST('XXX','BUG ') 8025 CONTINUE C IMAX=IWIDTH IF(IWIDTH.GT.MAXCIS)IMAX=MAXCIS-4 DO8100I=1,IMAX IC4=IANSLC(I) IANSSV(IPOINT,I)=IC4(1:1) 8100 CONTINUE C C CASE FOR MORE THAN 80 CHARACTER LINE C IF(IWIDTH.LE.MAXCIS)GOTO8190 ITEMP=MAXCIS-4 DO8200I=ITEMP+1,MAXCIS IANSSV(IPOINT,I)=ICONCH(I-ITEMP:I-ITEMP) 8200 CONTINUE C IPOINT=IPOINT+1 IF(IPOINT.GT.IREPMX)IPOINT=1 ISTART=IMAX IMAX=IWIDTH-IMAX IF(IMAX.GT.MAXCIS)IMAX=MAXCIS C DO8210I=1,MAXCIS IANSSV(IPOINT,I)=' ' 8210 CONTINUE C DO8220I=1,IMAX J=ISTART+I IC4=IANSLC(J) IANSSV(IPOINT,I)=IC4(1:1) 8220 CONTINUE C 8190 CONTINUE CCCCC END FIX C CCCCC THE FOLLOWING 6 LINES WERE ADDED JUNE 1992 (JJF) CCCCC TO ALLOW SCROLLING OF COMPLETE COMMAND LOG JUNE 1992 CCCCC ON THE C MENU SIDE JUNE 1992 IF(IHOST1.EQ.'IBM-'.AND.TCMENU.EQ.'ON')THEN DO8230I=1,80 STRING(I:I)=IANSSV(IPOINT,I) 8230 CONTINUE C CALL TCWRCO(STRING,ISUBRO) C ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'GETC')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGETC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IOUNI0,MAXWID,ITERCH 9012 FORMAT('IOUNI0,MAXWID,ITERCH = ',I8,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IHOST1,TCMENU,IWIDTH 9013 FORMAT('IHOST1,TCMENU,IWIDTH = ',A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(IANS(I),I=1,IWIDTH) 9014 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)(IANSLC(I),I=1,IWIDTH) 9015 FORMAT('(IANSLC(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IWIDSV 9016 FORMAT('IWIDSV = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)(IANSV(I),I=1,IWIDSV) 9017 FORMAT('(IANSV(I),I=1,IWIDSV) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)NUMCHA 9018 FORMAT('NUMCHA = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IREPST,IREPPO,IREPMX,IPOINT 9020 FORMAT('IREPST,IREPPO,IREPMX,IPOINT = ',A4,3I8) CALL DPWRST('XXX','BUG ') DO9022J=1,20 WRITE(ICOUT,9023)J,(IANSSV(J,I),I=1,80) 9023 FORMAT('J,(IANSSV(J,I),I=1,80) = ',I8,2X,80A1) CALL DPWRST('XXX','BUG ') 9022 CONTINUE CCCCC THE FOLLOWING 3 LINES WERE ADDED JUNE 1989 WRITE(ICOUT,9024)ICAPSW,IPR,IPRDEF 9024 FORMAT('ICAPSW,IPR,IPRDEF = ',A4,2I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 3 LINES WERE ADDED AUGUST 1994 WRITE(ICOUT,9030)(IA(I),I=1,10) 9030 FORMAT('IA(.) = ',10A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)IMACRO,IMACNU,IMACCS 9031 FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 3 LINES WERE ADDED AUGUST 1994 CCCCC AND OTHER FORMAT NUMBERS CHANGED BEYOND IT AUGUST 1994 WRITE(ICOUT,9032)IMACL1,IMACL2,IMACLR 9032 FORMAT(1H ,'IMACL1,IMACL2,IMACLR = ',3I8) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1992 CCCCC WRITE(ICOUT,9032)IOFILE,IOUNIT C9032 FORMAT('IOFILE,IOUNIT = ',A4,2X,I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IOUNIT 9033 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)IPROGR 9034 FORMAT('IPROGR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)IPROSW 9035 FORMAT('IPROSW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)IBUGS2,IFOUND,IERROR 9039 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)IOUNIT 9041 FORMAT('IOUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9042)IFILE 9042 FORMAT('IFILE = ',A80) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9043)ISTAT 9043 FORMAT('ISTAT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9044)IFORM 9044 FORMAT('IFORM = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9045)IACCES 9045 FORMAT('IACCES = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9046)IPROT 9046 FORMAT('IPROT = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9047)ICURST 9047 FORMAT('ICURST = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9048)IENDFI 9048 FORMAT('IENDFI = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9049)IREWIN 9049 FORMAT('IREWIN = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)ISUBN0 9051 FORMAT('ISUBN0 = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)IERRFI 9052 FORMAT('IERRFI = ',A12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IPROGR,IPRONU 9061 FORMAT('IPROGR,IPRONU = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9062)ICONCL,ICONNU 9062 FORMAT('ICONCL,ICONNU = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9063)IEOF,IIFSW 9063 FORMAT('IEOF,IIFSW = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9064)IREPCH 9064 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9065)ILOOST 9065 FORMAT('ILOOST = ',A4) CALL DPWRST('XXX','BUG ') CCCCC THE FOLLOWING 6 LINES WERE ADDED FEBRUARY 1993 WRITE(ICOUT,9066)IPOINT 9066 FORMAT('IPOINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9067)IPOINT,(IANSSV(IPOINT,I),I=1,80) 9067 FORMAT('IPOINT,(IANSSV(IPOINT,I),I=1,80) = ',I8,2X,80A1) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9068)IANS5 C9068 FORMAT('IANS5 = ',A5) CCCCC CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPGMEA(NPTS,NLAB, 1XGRAND,SDGRAN,SET1,SET1K1,SET1K2, 1DLOWT2,DHIGT2, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT GRAND MEAN APPROACH TO CONSENSUS MEANS 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 UPDATED --OCTOBER 2006. CALL LIST TO TPPF 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 XGRAND REAL SDGRAN REAL SET1 REAL SET1K1 REAL SET1K2 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='DPGM' ISUBN2='EA ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GMEA')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB,XGRAND,SDGRAN 52 FORMAT('NPTS,NLAB,XGRAND,SDGRAN = ',2I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C IDF=NPTS-1 CCCC CALL TPPF(0.975,IDF,APPF) CALL TPPF(0.975,REAL(IDF),APPF) DLOWT2=DBLE(XGRAND - APPF*SDGRAN/SQRT(REAL(NPTS))) DHIGT2=DBLE(XGRAND + APPF*SDGRAN/SQRT(REAL(NPTS))) SET1=SDGRAN/SQRT(REAL(NPTS)) SET1K1=SET1 SET1K2=2.0*SET1 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(' 8. Method: Grand Mean (no lab effect)') 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 'Mean of All Data') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XGRAND 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 All Data') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)SDGRAN 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,5174) 5174 FORMAT('      ', 1 'Standard Deviaton of Consensus Mean (sd/sqrt(n)):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)SET1 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,5177) 5177 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)SET1 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 '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)2.0*SET1 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)APPF 5179 FORMAT('      ', 1 'Expanded Uncertainty (k = ',F10.7,'):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)APPF*SET1 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,5151)IDF 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 't Percent Point Value (alpha = 0.05):') 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,5182) 5182 FORMAT('      ', 1 'Lower 95% (t-value) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWT2) 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 'Upper 95% (t-value) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGT2) 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 'Note: Grand Mean 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,5185) 5185 FORMAT('      ', 1 '         ', 1 'Any Number of Labs, but no
') 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,5186) 5186 FORMAT('      ', 1 '         ', 1 'Lab-to-Lab Differences') 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 8. Method: Grand Mean ', 1 '(No Lab Effect):} & ', 1 2X,A1,A1) 8012 FORMAT(5X,'Mean of All Data: & ', 1 F15.7,2X,A1,A1) 8013 FORMAT(5X,'Standard Deviation of All Data: & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XGRAND,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8013)SDGRAN,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8019 FORMAT(5X,'Standard Deviation of Consensus ', 1 'Mean (sd/sqrt(n)): & ',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) 8022 FORMAT(5X,'Expanded Uncertainty (k = ',F10.7,'): & ', 1 F15.7,2X,A1,A1) WRITE(ICOUT,8019)SET1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8020)SET1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)2.0*SET1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8022)APPF,APPF*SET1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8024 FORMAT(5X,'Degrees of Freedom: & ', 1 I8,2X,A1,A1) 8025 FORMAT(5X,'t Percent Point Value (alpha = 0.05): & ', 1 F10.7,2X,A1,A1) 8026 FORMAT(5X,'Lower 95',A1,'% (t-value) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (t-value) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: Mean of Means Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' Any Number of Labs, but no Lab-to-Lab ', 1 'Differences & ',2X,A1,A1) WRITE(ICOUT,8024)IDF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8025)APPF,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8026)IBASLC,REAL(DLOWT2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGT2),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 8. Method: Grand Mean (No Lab Effect)' IVALUE(1)(1:1)=IBASLC NCHAR(1)=39 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IFLAG1=.FALSE. NHEAD=1 C NCHAR(1)=19 IVALUE(1)=' Mean of All Data' AVALUE(2)=XGRAND CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=34 IVALUE(1)=' Standard Deviation of All Data:' AVALUE(2)=SDGRAN CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=37 IVALUE(1)=' SD of Consensus Mean (sd/sqrt(n)):' AVALUE(2)=SET1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=SET1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=2.0*SET1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=41 IVALUE(1)(1:29)=' Expanded Uncertainty (k = ' WRITE(IVALUE(1)(30:39),'(F10.7)')APPF IVALUE(1)(40:41)='):' AVALUE(2)=APPF*SET1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=22 IVALUE(1)=' Degrees of Freedom:' AVALUE(2)=REAL(IDF) NJUNK=NUMDI2(2) NUMDI2(2)=0 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) NUMDI2(2)=NJUNK C NCHAR(1)=34 IVALUE(1)=' t Percent Point Value of 0.975:' AVALUE(2)=APPF CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=40 IVALUE(1)=' Lower 95% (t-value) Confidence Limit:' AVALUE(2)=REAL(DLOWT2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=40 IVALUE(1)=' Upper 95% (t-value) Confidence Limit:' AVALUE(2)=REAL(DHIGT2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: Grand Mean Best Usage:' NCHAR(1)=31 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' Any Number of Labs,' NCHAR(1)=28 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' but no Lab-to-Lab Differences' NCHAR(1)=38 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('8. Method: Grand Mean (No Lab Effect)') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XGRAND 4002 FORMAT(' Mean of All Data: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4003)SDGRAN 4003 FORMAT(' Standard Deviation of All Data: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4012)SET1 4012 FORMAT(' SD of Consensus Mean (sd/sqrt(n)): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4013)SET1 4013 FORMAT(' Standard Uncertainty (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4014)2.0*SET1 4014 FORMAT(' Expanded Uncertainty (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4015)APPF,APPF*SET1 4015 FORMAT(' Expanded Uncertainty (k = ',F10.7,'): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4020)IDF 4020 FORMAT(' Degrees of Freedom: ', 1 I8) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4021)APPF 4021 FORMAT(' t Percent Point Value (alpha = 0.05): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4022)REAL(DLOWT2) 4022 FORMAT(' Lower 95% (t-value) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DHIGT2) 4023 FORMAT(' Upper 95% (t-value) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: Grand Mean Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' Any Number of Labs, but no Lab-to-Lab ', 1 'Differences') 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.'GMEA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGMEA--') 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)SET1 9014 FORMAT('SET1 = ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWT2,DHIGT2 9015 FORMAT('DLOWT2,DHIGT2 = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,NUMHPP, 1XMATN,YMATN,XMITN,YMITN, 1ISQUAR, 1IVGMSW,IHGMSW, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1YPLOT,XPLOT,X2PLOT,TAGPLO, 1IMPSW,IMPNR,IMPNC,IMPCO, CCCCC ADD FOLLOWING LINE AUGUST 1999. 1IMPARG, 1PMXMIN,PMXMAX,PMYMIN,PMYMAX, 1MAXCOL, CCCCC AUGUST 1992. ADD FOLLOWING LINE 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO, 1IERROR) C C PURPOSE--GENERATE A PLOT ON ONE OF THE FOLLOWING-- C 1) CONTINUOUS DISPLAY TERMINAL C 2) NARROW-WIDTH DISCRETE TERMINAL C 3) WIDE-CARRIAGE DISCRETE TERMINAL/HIGH-SPEED PRINTER C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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--FEBRUARY 1981. C UPDATED --MARCH 1981. C UPDATED --AUGUST 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --DECEMBER 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1987. C UPDATED --MARCH 1988. TURN OFF FRAME FOR 3D PLOT C UPDATED --FEBRUARY 1989. YSAVE (ALAN) C UPDATED --FEBRUARY 1989. DELETE 5 ARRAYS (ALAN) C UPDATED --FEBRUARY 1989. INITIAL REWRITE FOR NEW 3D C UPDATED --NOVEMBER 1991. ADJUST FOR MULTIPLOT FREEZE C UPDATED --AUGUST 1992. ADD PARAMETERS TO PLOTGE C ADD PARAMETERS TO DPGRAP C UPDATED --SEPTEMBER 1998. ADD IMPSW2 C UPDATED --AUGUST 1999. MULTIPLOT FIX C UPDATED --AUGUST 2001. PPCC PLOTS WITH 2 SHAPE C PARAMETERS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C CHARACTER*4 ISQUAR C CHARACTER*4 ICAPSW C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C CHARACTER*4 IMPSW CCCCC CHARACTER*4 IERASV CCCCC CHARACTER*4 IX1TSV CCCCC CHARACTER*4 IX2TSV CCCCC CHARACTER*4 IY1TSV CCCCC CHARACTER*4 IY2TSV C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IFUNC C CHARACTER*1 IREPCH C CHARACTER*4 ICASPL CHARACTER*4 ICONT CHARACTER*4 IBUGUG CHARACTER*4 IBUGU2 CHARACTER*4 IBUGU3 CHARACTER*4 IBUGU4 C CHARACTER*4 ISUBRO C CHARACTER*4 IERROR C CHARACTER*4 IMORE CHARACTER*4 ICAS3D CHARACTER*4 IFIRST CHARACTER*4 ILAST C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION X3D(*) DIMENSION D(*) CCCCC AUGUST 1992. ADD FOLLOWING BLOCK OF CODE DIMENSION DSIZE(*) DIMENSION DSYMB(*) DIMENSION DCOLOR(*) DIMENSION DFILL(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IFUNC(*) C C DIMENSION YPLOT(*) DIMENSION XPLOT(*) DIMENSION X2PLOT(*) DIMENSION TAGPLO(*) C DIMENSION XIDC(100) C CCCCC THE FOLLOWING 5 ARRAYS WERE COMMENTED OUT (ALAN) (FEBRUARY 1989) CCCCC DIMENSION XSAVE(5000) CCCCC DIMENSION YSAVE(5000) CCCCC DIMENSION XOUT(5000) CCCCC DIMENSION YOUT(5000) CCCCC DIMENSION TAGOUT(5000) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCO3D.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='DPGR' ISUBN2='AP ' C CCCCC THE FOLLOWING LINE WAS INSERTED BY ALAN. FEBRUARY 1989 YSAVE=0.0 C CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. IMPSW2=IMPSW C ICONT=IDCONT(1) NUMHPP=IDNHPP(1) C IF(IBUGUG.EQ.'OFF'.AND.ISUBRO.NE.'GRAP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGRAP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N,NPLOTP,ICASPL,INEGSW 52 FORMAT('N,NPLOTP,ICASPL,INEGSW = ',2I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)ICONT,MAXCHA,NUMDEV,MAXDEV 53 FORMAT('ICONT,MAXCHA,NUMDEV,MAXDEV = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)ISQUAR 54 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') IF(NPLOTP.LE.0)GOTO90 DO55I=1,NPLOTP WRITE(ICOUT,56)I,Y(I),X(I),X3D(I),D(I) 56 FORMAT('I,Y(I),X(I),X3D(I),D(I) = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,61)XMATN,YMATN,XMITN,YMITN 61 FORMAT('XMATN,YMATN,XMITN,YMITN = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)IMPSW,IMPNR,IMPNC,IMPCO 71 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72)PMXMIN,PMXMAX,PMYMIN,PMYMAX 72 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,73)IERASW 73 FORMAT('IERASW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,74)PWXMIN,PWXMAX,PWYMIN,PWYMAX 74 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,75)PXMIN,PXMAX,PYMIN,PYMAX 75 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') C 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** COPY PLOT COORDINATES ** C ** OUT TO VARIABLES YPLOT, XPLOT, ** C ** X2PLOT, AND TAGPLOT ** C **************************************** C DO100I=1,NPLOTP YPLOT(I)=Y(I) XPLOT(I)=X(I) X2PLOT(I)=X3D(I) TAGPLO(I)=D(I) 100 CONTINUE J4=5 IN(J4)=NPLOTP J4=6 IN(J4)=NPLOTP J4=7 IN(J4)=NPLOTP J4=8 IN(J4)=NPLOTP C C **************************************** C ** STEP 12-- ** C ** IF THE RESPONSE IS TO BE NEGATED ** C ** (AS IN HANGING HISTOGRAMS), ** C ** THEN DO SO HERE. ** C **************************************** C IF(INEGSW.EQ.'OFF')GOTO290 IF(NPLOTP.LE.0)GOTO290 DO200I=1,NPLOTP Y(I)=-Y(I) 200 CONTINUE 290 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** IF THE MULTIPLOTTING SWITCH IS ON, ** C ** THEN SET THE FRAME CORNER COORDINATES ** C ** BEFORE THE PLOT IS DRAWN. ** C ********************************************* C IF(IMPSW.EQ.'OFF')GOTO390 C IF(IMPCO.GE.2)IERASW='OFF' CCCCC DO NOT ERASE SCREEN FOR 3 AND 4 ARGUMENT FORMS OF MULTIPLOT IF(IMPCO.EQ.1.AND.IMPARG.GE.3)IERASW='OFF' C IPROD=IMPNR*IMPNC IMPCO2=MOD(IMPCO,IPROD) IF(IMPCO2.LE.0)IMPCO2=IPROD ICOL=MOD(IMPCO2,IMPNC) IF(ICOL.LE.0)ICOL=IMPNC IROW=((IMPCO2-ICOL)/IMPNC)+1 AIROW=IROW AICOL=ICOL C AMPNR=IMPNR AMPNC=IMPNC C XDEL=(PMXMAX-PMXMIN)/AMPNC YDEL=(PMYMAX-PMYMIN)/AMPNR C X1C=PMXMIN+(AICOL-1.0)*XDEL X2C=X1C+XDEL Y1C=PMYMAX-AIROW*YDEL Y2C=Y1C+YDEL C PWXMIN=X1C PWXMAX=X2C PWYMIN=Y1C PWYMAX=Y2C C IF(IBUGUG.EQ.'OFF'.AND.ISUBRO.NE.'GRAP')GOTO329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321) 321 FORMAT('AT END OF STEP 13--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,322)IMPSW,IMPNR,IMPNC,IMPCO 322 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)IPROD,IMPCO2,IROW,ICOL 323 FORMAT('IPROD,IMPCO2,IROW,ICOL = ',4I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,324)PMXMIN,PMXMAX,PMYMIN,PMYMAX 324 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,325)XDEL,YDEL 325 FORMAT('XDEL,YDEL = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,326)X1C,X2C,Y1C,Y2C 326 FORMAT('X1C,X2C,Y1C,Y2C = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,327)PWXMIN,PWXMAX,PWYMIN,PWYMAX 327 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 329 CONTINUE C 390 CONTINUE C C ************************************************************* C ** STEP 21-- ** C ** MONITOR NUMSET = THE NUMBER OF SUBSETS. ** C ** IF NUMSET EXCEEDS MAXCHA ** C ** (THE MAXIMUM NUMBER OF PLOT CHARACTERS), ** C ** THEN THE ANALYSIS WILL BE SEQUENTIALLY ** C ** PARTITIONED INTO NUMSET=MAXCHA SUBSETS AT A TIME ** C ** (THAT IS, LOWER LEVEL SUBROUTINES WILL BE FED ** C ** ONLY NUMSET=MAXCHA SUBSETS AT A TIME). ** C ** IMIN IS THAT ELEMENT NUMBER (1 THROUGH NPLOTP) ** C ** IN THE DATA SET WHERE THE NEXT PARTITION IS TO BEGIN. ** C ** THE FOLLOWING LARGE LOOP ** C ** (STARTING WITH 1000 CONTINUE) ** C ** WILL BE ENTERED ONLY IF MORE PARTITIONS EXIST. ** C ** IF IMORE = 'YES', THEN MORE PARTITIONS EXIST; ** C ** IF IMORE = 'NO' , THEN NO MORE PARTITIONS EXIST ** C ** AND THEREFORE WE ARE DONE. ** C ************************************************************* C ISTEPN='21' IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IMORE='YES' IPASS=0 IMIN=1 C 1000 CONTINUE IMORE='NO' IPASS=IPASS+1 NUMSET=0 C C ****************************************** C ** STEP 22-- ** C ** IF A PLOT OF NO DATA IS CALLED FOR ** C ** (AS IN THE GENERATION OF ** C ** DIAGRAMS, EQUATIONS, AND SLIDES), ** C ** THEN SKIP IMMEDIATELY ** C ** TO THE PLOTTING. ** C ****************************************** C ISTEPN='22' IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASPL.EQ.'NODA')GOTO1300 C C ************************************************** C ** STEP 23-- ** C ** DETERMINE IF A 3DPLOT IS BEING GENERATED ** C ************************************************** C ISTEPN='23' IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICAS3D='OFF' IF(ICASPL.EQ.'3DNO')GOTO1210 IF(ICASPL.EQ.'3DEF')GOTO1210 IF(ICASPL.EQ.'3DVS')GOTO1210 IF(ICASPL.EQ.'3DFR')GOTO1210 IF(ICASPL.EQ.'3DHI')GOTO1210 IF(ICASPL.EQ.'YCUB')GOTO1210 IF(ICASPL.EQ.'BECP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'LDCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'EWCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'GGCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'GOCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'EPCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'SBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'SUCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'JBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'JUCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'ALCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'PLCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'TSCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'IGCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'RICP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'FNCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'FCCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'FCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'STCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'LZCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'GHCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'NTCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'NCCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'PECP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'NBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'HYCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'BBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'PZCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'TECP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'IBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'HECP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'GALP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'GMCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'HBCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'BNCP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'G4CP' .AND. IPPCFO.EQ.'3D')GOTO1210 IF(ICASPL.EQ.'AXCP' .AND. IPPCFO.EQ.'3D')GOTO1210 GOTO1290 1210 CONTINUE ICAS3D='ON' 1290 CONTINUE C C **************************************************************** C ** STEP 24-- ** C ** DETERMINE THE NUMBER OF DISTINCT SUBSETS ** C ** TO BE PLOTTED (ON THE BASIS OF THE NUMBER ** C ** OF DISTINCT LEVELS OF THE SUBSET DEFINITION VARIABLE). ** C ** EACH SUBSET DEFINES A POTENTIAL CURVE ON THE FINAL PLOT. ** C ** COPY EACH SUBSET IDENTIFIER INTO XIDC(.) ** C ** AND THEN SORT (AN ASCENDING SORT) XIDC(.). ** C **************************************************************** C ISTEPN='24' IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1110J=1,MAXCHA XIDC(J)=0.0 1110 CONTINUE C DO1120I=IMIN,NPLOTP I2=I IF(NUMSET.LE.0)GOTO1125 DO1130J=1,NUMSET IF(D(I).EQ.XIDC(J))GOTO1120 1130 CONTINUE 1125 CONTINUE NUMSET=NUMSET+1 IF(NUMSET.GT.MAXCHA)GOTO1135 XIDC(NUMSET)=D(I) 1120 CONTINUE IMORE='NO' GOTO1139 1135 CONTINUE IMORE='YES' IMIN=I2 NUMSET=MAXCHA GOTO1139 1139 CONTINUE IF(NUMSET.GE.2)CALL SORT(XIDC,NUMSET,XIDC) C C ************************* C ** STEP 31-- ** C ** GENERATE THE PLOT ** C ************************* C 1300 CONTINUE C ISTEPN='31' IF(IBUGUG.EQ.'ON'.OR.ISUBRO.EQ.'GRAP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFIRST='NO' ILAST='NO' IF(IPASS.EQ.1)IFIRST='YES' IF(IMORE.EQ.'NO')ILAST='YES' C IF(IBUGUG.EQ.'OFF'.AND.ISUBRO.NE.'GRAP')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1301) 1301 FORMAT('***** FROM THE MIDDLE OF DPGRAP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1302) 1302 FORMAT(' (IMMEDIATELY BEFORE A PLOT IS GENERATED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1303)ICONT,NUMHPP,MAXCHA 1303 FORMAT('ICONT,NUMHPP,MAXCHA = ',A4,I8,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1304)N,NPLOTP,NUMSET,IMIN,IMORE,IPASS, 1ICASPL,IFIRST,ILAST 1304 FORMAT('N,NPLOTP,NUMSET,IMIN,IMORE,IPASS,', 1'ICASPL,IFIRST,ILAST = ',4I8,2X,A4,I8,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') DO1305I=1,NUMSET WRITE(ICOUT,1306)I,XIDC(I),ICHAPA(I),ILINPA(I) 1306 FORMAT('I,XIDC(I),ICHAPA(I),ILINPA(I) =',I6,F15.7,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 1305 CONTINUE WRITE(ICOUT,1307)Y(1),X(1),D(1) 1307 FORMAT('Y(1),X(1),D(1) = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1308)Y(NPLOTP),X(NPLOTP),D(NPLOTP) 1308 FORMAT('Y(NPLOTP),X(NPLOTP),D(NPLOTP) = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('A PLOT IS GENERATED AT THIS TIME') CALL DPWRST('XXX','BUG ') 1319 CONTINUE C CCCCC IF(ICONT.EQ.'ON') CCCCC1CALL TPLOT(Y,X,D,NPLOTP,NUMSET,ICASPL,ICAS3D,IFIRST,ILAST, CCCCC1IBARPA,BARSPA,IFENCE,NUMHPP,NUMVPP, CCCCC1XMATN,YMATN,XMITN,YMITN, CCCCC1IBUGP,IBUGP1,IBUGP2,IBUGP3,IERROR) C IF(ICONT.EQ.'ON') 1CALL PLOTGE(Y,X,X3D,D,NPLOTP,XIDC,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1YSAVE, 1IVGMSW,IHGMSW, 1IFIRST,ILAST, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, CCCCC AUGUST 1992. ADD FOLLOWING LINE 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGU2,IBUGU3,IBUGU4,ISUBRO,IERROR) C IF(ICONT.EQ.'OFF'.AND.NUMHPP.LE.130.AND.NUMSET.LE.1) 1CALL PLOTN(Y,X,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C IF(ICONT.EQ.'OFF'.AND.NUMHPP.LE.130.AND.NUMSET.GE.2) 1CALL PLOTCN(Y,X,D,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C IF(ICONT.EQ.'OFF'.AND.NUMHPP.GT.130.AND.NUMSET.LE.1) 1CALL PLOTW(Y,X,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C IF(ICONT.EQ.'OFF'.AND.NUMHPP.GT.130.AND.NUMSET.GE.2) 1CALL PLOTCW(Y,X,D,NPLOTP,ICHAPA,MAXCHA,ICASPL,ICAS3D, 1ITITTE,NCTITL, 1IX1LTE,NCX1LA, 1IX2LTE,NCX2LA, 1IX3LTE,NCX3LA, 1IY1LTE,NCY1LA, 1IY2LTE,NCY2LA, 1GX1MIN,GX1MAX,GY1MIN,GY1MAX, 1IERASW,IBUGU2,IERROR) C IF(ICONT.EQ.'OFF'.AND.NUMDEV.GE.2) 1CALL PLOTGE(Y,X,X3D,D,NPLOTP,XIDC,NUMSET, 1ICASPL,ICAS3D, 1ISQUAR, 1YSAVE, 1IVGMSW,IHGMSW, 1IFIRST,ILAST, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, CCCCC AUGUST 1992. ADD FOLLOWING LINE 1DSIZE,DSYMB,DCOLOR,DFILL, 1ICAPSW, 1IBUGU2,IBUGU3,IBUGU4,ISUBRO,IERROR) C IF(IMORE.EQ.'YES')GOTO1000 C C ********************************************* C ** STEP 32-- ** C ** IF THE MULTIPLOTTING SWITCH IS ON, ** C ** AND IF THE LAST PLOT ON THE PAGE ** C ** HAS JUST BEEN GENERATED, ** C ** THEN REVERT THE FRAME COORDINATE ** C ** AND PRE-ERASE SETTINGS BACK TO THEIR ** C ** PRIOR SETTINGS. ** C ********************************************* C IF(IMPSW.EQ.'OFF')GOTO2190 CCCCC THE FOLLOWING LINE WAS FIXED NOVEMBER 1991 CCCCC IMPCO=IMPCO+1 IF(IMPSW.EQ.'ON')IMPCO=IMPCO+1 CCCCC IPROD=IMPNR*IMPNC CCCCC IF(IMPCO.GT.IPROD)GOTO2110 CCCCC GOTO2190 C2110 CONTINUE CCCCC IMPCO=1 CCCCC IERASW=IERASV CCCCC IX1TSW=IX1TSV CCCCC IX2TSW=IX2TSV CCCCC IY1TSW=IY1TSV CCCCC IY2TSW=IY2TSV CCCCC PXMIN=PXMISV CCCCC PXMAX=PXMASV CCCCC PYMIN=PYMISV CCCCC PYMAX=PYMASV 2190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGUG.EQ.'OFF'.AND.ISUBRO.NE.'GRAP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGRAP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IERROR,ICAS3D,I3DPRO 9012 FORMAT('IERROR,ICAS3D,I3DPRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NPLOTP,ICASPL,INEGSW 9013 FORMAT('N,NPLOTP,ICASPL,INEGSW = ',2I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICONT,MAXCHA,NUMDEV,MAXDEV 9014 FORMAT('ICONT,MAXCHA,NUMDEV,MAXDEV = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)ISQUAR 9015 FORMAT('ISQUAR = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)XMATN,YMATN,XMITN,YMITN 9021 FORMAT('XMATN,YMATN,XMITN,YMITN = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)IMPSW,IMPNR,IMPNC,IMPCO 9031 FORMAT('IMPSW,IMPNR,IMPNC,IMPCO = ',A4,3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)PMXMIN,PMXMAX,PMYMIN,PMYMAX 9032 FORMAT('PMXMIN,PMXMAX,PMYMIN,PMYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9033)IERASW 9033 FORMAT('IERASW = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9034)PWXMIN,PWXMAX,PWYMIN,PWYMAX 9034 FORMAT('PWXMIN,PWXMAX,PWYMIN,PWYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9035)PXMIN,PXMAX,PYMIN,PYMAX 9035 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPGRAY(NPTS,NLAB, 1AMEAN,ASD,N, 1XGD,XGDS2,SEGDK1,SEGDK2, 1DLOWGD,DHIGGD, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--IMPLEMENT GRAYBILL-DEAL APPROACH TO CONSENSUS MEANS C PRINTING--YES C SUBROUTINES NEEDED--NONE C REFERENCES--SINHA (1985). "UNBIASED ESTIMATION OF THE C VARIANCE OF THE GRAYBILL-DEAL ESTIMATOR OF THE C COMMON MEAN OF SEVERAL POPULATIONS", CANADIAN C JOURNAL OF STATISTICS, 13, PP. 243-247. C --ZHANG (2006). "THE UNCERTAINTY ASSOCIATED WITH C THE WEIGHTED MEAN OF MEASUREMENT DATA", C METROLOGIA, 43, PP. 195-204. 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 UPDATD --OCTOBER 2006. CALL LIST TO TPPF 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 AMEAN(*) REAL ASD(*) C REAL APPF REAL XGD REAL XGDS2 REAL SEGDK1 REAL SEGDK2 C LOGICAL IFLAG9 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='DPGR' ISUBN2='AY ' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GRAY')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGRAY--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NLAB 52 FORMAT('NPTS,NLAB = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C STEP 1: COMPUTE THE GRAYBILL-DEAL CONSENSUS MEAN C IFLAG9=.TRUE. DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DO910I=1,NLAB DNI=DBLE(N(I)) DMEAN=DBLE(AMEAN(I)) DVARI=DBLE(ASD(I))**2 DWI=DNI/DVARI DSUM1=DSUM1 + DWI*DMEAN DSUM2=DSUM2 + DWI IF(N(I).GT.3)THEN DSUM3=DSUM3 + ((DNI-3.0D0)/(DNI-1.0D0))*DWI ELSE IFLAG9=.FALSE. ENDIF 910 CONTINUE XGD=REAL(DSUM1/DSUM2) DTERM3=DSUM2 DTERM4=DSUM3 C C STEP 2: COMPUTE THE GRAYBILL-DEAL VARIANCE. FOUR METHODS C FOR COMPUTING THE VARIANCE ARE USED: C C 1) SIMPLE: 1/SUM[i=1 to nlab][1/s(i)'**2] C 2) METHOD PROPOSED BY SINH C 3) METHOD 1 PROPOSED BY ZHANG C 4) METHOD 2 PROPOSED BY ZHANG C DSUM1=0.0D0 DSUM2=0.0D0 DSUM3=0.0D0 DSUM4=0.0D0 C DO920I=1,NLAB DNI=DBLE(N(I)) DMEAN=DBLE(AMEAN(I)) DVARI=DBLE(ASD(I))**2 DWI=DNI/DVARI DWI3=DWI/DTERM3 DSUM1=DSUM1 + DWI3*(1.0D0 - DWI3)/(DNI - 1.0D0) DSUM2=DSUM2 + DWI IF(N(I).GT.3)THEN DTERM5=((DNI-3.0D0)/(DNI-1.0D0))*DWI DWI2=DTERM5/DTERM4 DSUM3=DSUM3 + DTERM5 DSUM4=DSUM4 + DWI2*(1.0D0-DWI2)/(DNI-1.0D0) ELSE IFLAG9=.FALSE. ENDIF 920 CONTINUE DTERM1=(1.0D0 + DSUM1)/DTERM3 XGDS2=REAL((1.0D0/DTERM3)*(1.0D0 + 4.0D0*DSUM1)) SEGDK1=SQRT(XGDS2) SEGDK2=2.0*SQRT(XGDS2) XGDS20=REAL(1.0D0/DSUM2) IF(IFLAG9)THEN XGDSZ1=REAL(1.0D0/DSUM3) XGDSZ2=REAL((1.0D0/DSUM3)*(1.0D0 + 2.0D0*DSUM4)) ELSE XGDSZ1=0.0 XGDSZ2=0.0 ENDIF C C COMPUTE THE RUKHIN CONFIDENCE INTERVALS C DP=DBLE(NLAB) DPP=1.0D0/DBLE(NLAB-1) DRR=DP**(DP*DPP/2.0D0) IDF=NLAB-1 ALPHA=0.975 CALL TPPF(REAL(ALPHA),REAL(IDF),APPF) DPH=DBLE(APPF)/DRR/(DSQRT(DP-1.0D0)) C DSUM1=0.0D0 DPROD1=1.0D0 DO930I=1,NLAB DNI=DBLE(N(I)) DMEAN=DBLE(AMEAN(I)) DVARI=DBLE(ASD(I))**2 DWI=DNI/DVARI DSUM1=DSUM1 + DWI*(DMEAN - DBLE(XGD))**2 DPROD1=DPROD1*DWI 930 CONTINUE DPROD1=DPROD1**DPP DRI=DPH*DSQRT(DSUM1)/DSQRT(DPROD1) DLOWGD=DBLE(XGD) - DRI DHIGGD=DBLE(XGD) + DRI 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(' 7. Method: Graybill-Deal') 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)XGD 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 'Estimate of Variance (Sinha):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XGDS2 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 'Estimate of Variance (naive):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XGDS20 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') C IF(IFLAG9)THEN WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5174) 5174 FORMAT('      ', 1 'Estimate of Variance (Zhang 1):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XGDSZ1 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,5175) 5175 FORMAT('      ', 1 'Estimate of Variance (Zhang 2):') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)XGDSZ2 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5128) CALL DPWRST('XXX','WRIT') ENDIF C WRITE(ICOUT,5121) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5123) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5177) 5177 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)SQRT(XGDS2) 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 '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)2.0*SQRT(XGDS2) 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 'Lower 95% (Rukhin) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DLOWGD) 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 'Upper 95% (Rukhin) Confidence Limit:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5127) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5126) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5152)REAL(DHIGGD) 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 'Note: Graybill-Deal 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,5185) 5185 FORMAT('      ', 1 '         ', 1 'Any Number of Labs, but no
') 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,5186) 5186 FORMAT('      ', 1 '         ', 1 'Between Lab Variance') 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 7. Method: Graybill-Deal:} & ', 1 2X,A1,A1) 8012 FORMAT(5X,'Estimate of Consensus Mean: & ', 1 F15.7,2X,A1,A1) 8013 FORMAT(5X,'Estimate of Variance (Sinha): & ', 1 F15.7,2X,A1,A1) 8014 FORMAT(5X,'Estimate of Variance (naive): & ', 1 F15.7,2X,A1,A1) 8015 FORMAT(5X,'Estimate of Variance (Zhang 1): & ', 1 F15.7,2X,A1,A1) 8016 FORMAT(5X,'Estimate of Variance (Zhang 2): & ', 1 F15.7,2X,A1,A1) C WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8012)XGD,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8013)XGDS2,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8014)XGDS20,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') IF(IFLAG9)THEN WRITE(ICOUT,8015)XGDSZ1,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8016)XGDSZ2,IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF C 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,8020)SQRT(XGDS2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)2.0*SQRT(XGDS2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') C 8026 FORMAT(5X,'Lower 95',A1,'% (Rukhin) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8027 FORMAT(5X,'Upper 95',A1,'% (Rukhin) Confidence Interval: & ', 1 F15.7,2X,A1,A1) 8028 FORMAT(5X,'Note: Graybill-Deal Best Usage: & ', 1 2X,A1,A1) 8029 FORMAT(5X,' Any Number of Labs, but no ', 1 'Between Lab Variance & ',2X,A1,A1) WRITE(ICOUT,8026)IBASLC,REAL(DLOWGD),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8027)IBASLC,REAL(DHIGGD),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 7. Method: Graybill-Deal' IVALUE(1)(1:1)=IBASLC NCHAR(1)=27 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)=XGD CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Estimate of Variance (Sinha):' AVALUE(2)=XGDS2 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Estimate of Variance (naive):' AVALUE(2)=XGDS20 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IF(IFLAG9)THEN NCHAR(1)=34 IVALUE(1)=' Estimate of Variance (Zhang 1):' AVALUE(2)=XGDSZ1 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=34 IVALUE(1)=' Estimate of Variance (Zhang 2):' AVALUE(2)=XGDSZ2 CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) ENDIF C NCHAR(1)=32 IVALUE(1)=' Standard Uncertainty (k = 1):' AVALUE(2)=SQRT(XGDS2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=32 IVALUE(1)=' Expanded Uncertainty (k = 2):' AVALUE(2)=2.0*SQRT(XGDS2) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=23 IVALUE(1)=' Normal PPF of 0.975:' AVALUE(2)=APPF CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Lower 95% (Rukhin) Confidence Limit:' AVALUE(2)=REAL(DLOWGD) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C NCHAR(1)=39 IVALUE(1)=' Upper 95% (Rukhin) Confidence Limit:' AVALUE(2)=REAL(DHIGGD) CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1) C IVALUE(1)=' Note: Graybill-Deal Best Usage:' NCHAR(1)=34 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' Any Number of Labs,' NCHAR(1)=28 IVALUE(2)=' ' NCHAR(2)=0 CALL DPRTF4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2) C IVALUE(1)=' but no Between Lab Variance' NCHAR(1)=36 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('7. Method: Graybill-Deal') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4002)XGD 4002 FORMAT(' Estimate of Consensus Mean: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4003)XGDS2 4003 FORMAT(' Estimate of Variance (Sinha): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4004)XGDS20 4004 FORMAT(' Estimate of Variance (Naive): ', 1 F15.7) CALL DPWRST('XXX','WRIT') IF(IFLAG9)THEN WRITE(ICOUT,4005)XGDSZ1 4005 FORMAT(' Estimate of Variance (Zhang 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4006)XGDSZ2 4006 FORMAT(' Estimate of Variance (Zhang 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') ENDIF C WRITE(ICOUT,4013)SQRT(XGDS2) 4013 FORMAT(' Standard Uncertainty (Sinha) (k = 1): ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4014)2.0*SQRT(XGDS2) 4014 FORMAT(' Expanded Uncertainty (Sinha) (k = 2): ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4022)REAL(DLOWGD) 4022 FORMAT(' Lower 95% (Rukhin) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4023)REAL(DHIGGD) 4023 FORMAT(' Upper 95% (Rukhin) Confidence Limit: ', 1 F15.7) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,4031) 4031 FORMAT(' Note: Graybill-Deal Best Usage:') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,4032) 4032 FORMAT(' Any Number of Labs, but no ', 1 'Between Lab Variance') 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.'GRAY')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGRAY--') 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)XGD,XGDS2 9014 FORMAT('XGD,XGDS2 = ',2G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)DLOWGD,DHIGGD 9015 FORMAT('DLOWGD,DHIGGD = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPGRCL(ICOM,IHARG,NUMARG, 1IDEFCO, 1IVGRCO,IHGRCO, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 GRID COLOR SWITCHES CONTAINED IN THE C VARIABLES IVGRCO AND IHGRCO. C SUCH GRID COLOR SWITCHES DEFINE THE COLOR OF C THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL) C OF GRID LINES ON A PLOT. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C OUTPUT ARGUMENTS--IVGRCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE VERTICAL GRID LINES C --IHGRCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE HORIZONTAL GRID LINES C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 ICOM CHARACTER*4 IHARG CHARACTER*4 IDEFCO C CHARACTER*4 IVGRCO CHARACTER*4 IHGRCO C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD 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.0)GOTO1900 C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE VERTICAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XGRI')GOTO1100 GOTO1199 C 1100 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 IF(IHARG(NUMARG).EQ.'COLO')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFCO GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IVGRCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE GRID COLOR (FOR VERTICAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'YGRI')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'COLO')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFCO GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IHGRCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE GRID COLOR (FOR HORIZONTAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ******************************************************* C ** TREAT THE CASE WHEN ** C ** GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED ** C ******************************************************* C IF(ICOM.EQ.'GRID')GOTO1300 IF(ICOM.EQ.'XYGR')GOTO1300 IF(ICOM.EQ.'YXGR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'COLO')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFCO GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IHGRCO=IHOLD IVGRCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE GRID COLOR (FOR GRID LINES IN ', 1'BOTH DIRECTIONS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPGRID(ICOM,IHARG,NUMARG,IVGRSW,IHGRSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 GRID SWITCHES CONTAINED IN THE C VARIABLES IVGRSW AND IHGRSW. C SUCH GRID SWITCHES TURN ON OR OFF C THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL) C OF GRID LINES ON A PLOT. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IVGRSW (A HOLLERITH VARIABLE C DENOTING WHETHER THE VERTICAL GRID LINES ARE C ON OR OFF) C --IHGRSW (A HOLLERITH VARIABLE C DENOTING WHETHER THE HORIZONTAL GRID LINES ARE C ON OR OFF) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 ICOM CHARACTER*4 IHARG C CHARACTER*4 IVGRSW CHARACTER*4 IHGRSW C 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 C ******************************************* C ** TREAT THE CASE WHEN ** C ** THE VERTICAL GRID LINES ARE DEFINED ** C ******************************************* C IF(ICOM.EQ.'XGRI')GOTO1100 GOTO1199 C 1100 CONTINUE IF(NUMARG.LE.0)GOTO1110 IF(IHARG(1).EQ.'ON')GOTO1110 IF(IHARG(1).EQ.'OFF')GOTO1120 IF(IHARG(1).EQ.'AUTO')GOTO1110 IF(IHARG(1).EQ.'DEFA')GOTO1120 IERROR='YES' GOTO1900 C 1110 CONTINUE IFOUND='YES' IVGRSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT('THE XGRID SWITCH (FOR VERTICAL GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT('HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1900 C 1120 CONTINUE IFOUND='YES' IVGRSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT('THE XGRID SWITCH (FOR VERTICAL GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT('HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1900 C 1199 CONTINUE C C ********************************************* C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL GRID LINES ARE DEFINED ** C ********************************************* C IF(ICOM.EQ.'YGRI')GOTO1200 GOTO1299 C 1200 CONTINUE IF(NUMARG.LE.0)GOTO1210 IF(IHARG(1).EQ.'ON')GOTO1210 IF(IHARG(1).EQ.'OFF')GOTO1220 IF(IHARG(1).EQ.'AUTO')GOTO1210 IF(IHARG(1).EQ.'DEFA')GOTO1220 IERROR='YES' GOTO1900 C 1210 CONTINUE IFOUND='YES' IHGRSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT('THE YGRID SWITCH (FOR HORIZONTAL GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT('HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1219 CONTINUE GOTO1900 C 1220 CONTINUE IFOUND='YES' IHGRSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1225) 1225 FORMAT('THE YGRID SWITCH (FOR HORIZONTAL GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1226) 1226 FORMAT('HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1229 CONTINUE GOTO1900 C 1299 CONTINUE C C *********************************** C ** TREAT THE CASE WHEN ** C ** BOTH GRID LINES ARE DEFINED ** C *********************************** C IF(ICOM.EQ.'XYGR')GOTO1300 IF(ICOM.EQ.'YXGR')GOTO1300 IF(ICOM.EQ.'GRID')GOTO1300 IFOUND='NO' GOTO1900 C 1300 CONTINUE IF(NUMARG.LE.0)GOTO1310 IF(IHARG(1).EQ.'ON')GOTO1310 IF(IHARG(1).EQ.'OFF')GOTO1320 IF(IHARG(1).EQ.'AUTO')GOTO1310 IF(IHARG(1).EQ.'DEFA')GOTO1320 IERROR='YES' GOTO1399 C 1310 CONTINUE IFOUND='YES' IVGRSW='ON' IHGRSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT('THE GRID SWITCH (FOR BOTH HORIZONTAL AND VERTICAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT('HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1319 CONTINUE GOTO1900 C 1320 CONTINUE IFOUND='YES' IVGRSW='OFF' IHGRSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT('THE GRID SWITCH (FOR BOTH HORIZONTAL AND VERTICAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326) 1326 FORMAT('HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1329 CONTINUE GOTO1900 C 1399 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPGRMN(ICOM,IHARG,NUMARG,IVGMSW,IHGMSW,IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 MINOR GRID SWITCHES CONTAINED IN THE C VARIABLES IVGMSW AND IHGMSW. C SUCH MINOR GRID SWITCHES TURN ON OR OFF C THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL) C OF GRID LINES (AT THE MINOR TIC MARKS) ON A PLOT. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C OUTPUT ARGUMENTS--IVGMSW (A HOLLERITH VARIABLE C DENOTING WHETHER THE VERTICAL GRID LINES ARE C ON OR OFF) C --IHGMSW (A HOLLERITH VARIABLE C DENOTING WHETHER THE HORIZONTAL GRID LINES ARE C ON OR OFF) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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--NOVEMBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --JUNE 1987. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IVGMSW CHARACTER*4 IHGMSW C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 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 ISUBN1='DPGR' ISUBN2='MN ' C C ******************************************* C ** TREAT THE CASE WHEN ** C ** THE VERTICAL GRID LINES ARE DEFINED ** C ******************************************* C IF(ICOM.EQ.'XGMI')GOTO1100 IF(ICOM.EQ.'MINO'.AND. 1NUMARG.GE.1.AND.IHARG(1).EQ.'XGRI')GOTO1105 GOTO1199 C 1100 CONTINUE IF(NUMARG.LE.0)GOTO1110 IF(IHARG(1).EQ.'ON')GOTO1110 IF(IHARG(1).EQ.'OFF')GOTO1120 IF(IHARG(1).EQ.'AUTO')GOTO1110 IF(IHARG(1).EQ.'DEFA')GOTO1120 IERROR='YES' GOTO1900 C 1105 CONTINUE IF(NUMARG.LE.1)GOTO1110 IF(IHARG(2).EQ.'ON')GOTO1110 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1110 IF(IHARG(2).EQ.'DEFA')GOTO1120 IERROR='YES' GOTO1900 C 1110 CONTINUE IFOUND='YES' IVGMSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1119 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT('THE MINOR XGRID SWITCH (FOR VERTICAL GRID LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1119 CONTINUE GOTO1900 C 1120 CONTINUE IFOUND='YES' IVGMSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT('THE MINOR XGRID SWITCH (FOR VERTICAL GRID LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1129 CONTINUE GOTO1900 C 1199 CONTINUE C C ********************************************* C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL GRID LINES ARE DEFINED ** C ********************************************* C IF(ICOM.EQ.'YGMI')GOTO1200 IF(ICOM.EQ.'MINO'.AND. 1NUMARG.GE.1.AND.IHARG(1).EQ.'YGRI')GOTO1205 GOTO1299 C 1200 CONTINUE IF(NUMARG.LE.0)GOTO1210 IF(IHARG(1).EQ.'ON')GOTO1210 IF(IHARG(1).EQ.'OFF')GOTO1220 IF(IHARG(1).EQ.'AUTO')GOTO1210 IF(IHARG(1).EQ.'DEFA')GOTO1220 IERROR='YES' GOTO1900 C 1205 CONTINUE IF(NUMARG.LE.1)GOTO1210 IF(IHARG(2).EQ.'ON')GOTO1210 IF(IHARG(2).EQ.'OFF')GOTO1220 IF(IHARG(2).EQ.'AUTO')GOTO1210 IF(IHARG(2).EQ.'DEFA')GOTO1220 IERROR='YES' GOTO1900 C 1210 CONTINUE IFOUND='YES' IHGMSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1219 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1215) 1215 FORMAT('THE MINOR YGRID SWITCH (FOR HORIZONTAL GRID LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1216) 1216 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1219 CONTINUE GOTO1900 C 1220 CONTINUE IFOUND='YES' IHGMSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1229 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1225) 1225 FORMAT('THE MINOR YGRID SWITCH (FOR HORIZONTAL GRID LINES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1226) 1226 FORMAT('AT MINOR TICS) HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1229 CONTINUE GOTO1900 C 1299 CONTINUE C C *********************************** C ** TREAT THE CASE WHEN ** C ** BOTH GRID LINES ARE DEFINED ** C *********************************** C IF(ICOM.EQ.'XYGM')GOTO1300 IF(ICOM.EQ.'YXGM')GOTO1300 IF(ICOM.EQ.'GMIN')GOTO1300 IF(ICOM.EQ.'MINO'.AND. 1NUMARG.GE.1.AND.IHARG(1).EQ.'XYGR')GOTO1305 IF(ICOM.EQ.'MINO'.AND. 1NUMARG.GE.1.AND.IHARG(1).EQ.'YXGR')GOTO1305 IF(ICOM.EQ.'MINO'.AND. 1NUMARG.GE.1.AND.IHARG(1).EQ.'GRID')GOTO1305 IFOUND='NO' GOTO1900 C 1300 CONTINUE IF(NUMARG.LE.0)GOTO1310 IF(IHARG(1).EQ.'ON')GOTO1310 IF(IHARG(1).EQ.'OFF')GOTO1320 IF(IHARG(1).EQ.'AUTO')GOTO1310 IF(IHARG(1).EQ.'DEFA')GOTO1320 IERROR='YES' GOTO1399 C 1305 CONTINUE IF(NUMARG.LE.1)GOTO1310 IF(IHARG(2).EQ.'ON')GOTO1310 IF(IHARG(2).EQ.'OFF')GOTO1320 IF(IHARG(2).EQ.'AUTO')GOTO1310 IF(IHARG(2).EQ.'DEFA')GOTO1320 IERROR='YES' GOTO1399 C 1310 CONTINUE IFOUND='YES' IVGMSW='ON' IHGMSW='ON' C IF(IFEEDB.EQ.'OFF')GOTO1319 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT('THE MINOR XYGRID SWITCH (FOR BOTH HORIZ. AND VERT. ', 1'GRID LINES AT MINOR TICS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316) 1316 FORMAT('HAS JUST BEEN TURNED ON') CALL DPWRST('XXX','BUG ') 1319 CONTINUE GOTO1900 C 1320 CONTINUE IFOUND='YES' IVGMSW='OFF' IHGMSW='OFF' C IF(IFEEDB.EQ.'OFF')GOTO1329 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1325) 1325 FORMAT('THE MINOR XYGRID SWITCH (FOR BOTH HORIZ. AND VERT. ', 1'GRID LINE AT MINOR TICS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1326) 1326 FORMAT('HAS JUST BEEN TURNED OFF') CALL DPWRST('XXX','BUG ') 1329 CONTINUE GOTO1900 C 1399 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPGROL(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IWRITE, 1IBUGA3,ISUBRO,IERROR) C C PURPOSE--THIS SUBROUTINE READS THE CHARCTER DATA STORED IN C FILE "DPZCHF.DAT" AND STORES IT IN A GROUP LABEL. C EXAMPLE: C C LET GRPLAB = GROUP LABEL IX C C IN ADDITION, SUPPORT THE FOLLOWING: C C LET GRPLAB = GROUP LABEL ST1 ST2 ... C C WITH ST1, ST2, ... DENOTING PREVIOUSLY DEFINED C STRINGS. THE "TO" SYNTAX IS SUPPORTED FOR THIS C CASE (E.G., ST1 TO ST10). C C LET GRPLAB = GROUP LABEL "label 1" "label 2" ... C C I.E., YOU CAN SPECIFY A NUMBER OF LITERAL STRINGS. C NOTE THAT THESE TWO FORMATS CANNOT BE MIXED (I.E., C YOU CAN EITHER SPECIFY A LIST OF PREVIOUSLY DEFINED C STRING NAMES OR A LIST OF LITERAL STRINGS (ENCLOSED C IN QUOTES), BUT NOT BOTH TOGETHER. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM NUMBER OF ROWS FOR A GROUP LABEL IS C MAXOBV/100. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--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 TECHNOOGY. 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/1 C ORIGINAL VERSION--JANUARY 2004. C UPDATED --JANUARY 2006. CREATE GROUP LABELS FROM C PREVIOUSLY DEFINED STRINGS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ICASEL CHARACTER*4 IFOUND CHARACTER*4 MESSAG C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 C CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IANGLU CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV C DIMENSION ITYPEH(*) DIMENSION IW21HO(*) DIMENSION IW22HO(*) DIMENSION W2HOLD(*) C DIMENSION IA(*) DIMENSION PARAM(*) DIMENSION IPARN(*) DIMENSION IPARN2(*) C C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOF2.INC' 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*500 IATEMP CHARACTER*6 IFRMT CHARACTER*4 IHTEMP(200) CHARACTER*130 ISTRIN CHARACTER*130 ISTRI2 C PARAMETER(MAXIND=100) C CHARACTER*4 ISTRN1(MAXIND) CHARACTER*4 ISTRN2(MAXIND) 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='DPGR' ISUBN2='OL ' C IERROR='NO' IOPFLG=0 C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGROL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)MAXGRP,MAXGLA 53 FORMAT('MAXGRP,MAXGLA = ',2I6) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************** C ** STEP 1-- * C ** DETERMINE IF ANY MORE GROUP LABEL VARIABLES * C ** ARE AVAILABLE (DETERMINED BY MAXGRP). * C ** FIRST CHECK IF NAME IS ALREADY DEFINED GROUP * C ** LABEL (OVERWRITE IF IT IS). * C ************************************************** C ISTEPN='1' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHLEFT=IHARG(1) IHLEF2=IHARG2(1) C C DETERMINE IF NAME OF GROUP LABEL ALREADY DEFINED C DO1005I=1,MAXGRP IF(IGRPVN(I)(1:4).EQ.IHLEFT .AND. 1 IGRPVN(I)(5:8).EQ.IHLEF2)THEN IGRP=I IGRPVN(IGRP)(1:4)=IHLEFT IGRPVN(IGRP)(5:8)=IHLEF2 DO1008J=1,MAXGLA IGRPLA(J,I)=' ' 1008 CONTINUE GOTO1099 ENDIF 1005 CONTINUE C ISTEPN='1B' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C CREATE A NEW NAME C DO1010I=1,MAXGRP IF(IGRPVN(I)(1:8).EQ.' ')THEN IGRP=I IGRPVN(IGRP)(1:4)=IHLEFT IGRPVN(IGRP)(5:8)=IHLEF2 GOTO1099 ENDIF 1010 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** ERROR IN LET .. = GROUP LABELS ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013)MAXGRP 1013 FORMAT(' MAXIMUM NUMBER OF GROUP LABEL VARIABLES (',I6, 1 ') EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1015) 1015 FORMAT(' NO GROUP LABELS ASSIGNED.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1099 CONTINUE C ISTEPN='1C' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C C ******************************************** C ** STEP 2-- ** C ** OPEN THE DPZCHF.DAT FILE. ** C ******************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IHRIGH=IHARG(5) IHRIG2=IHARG2(5) C IOUNIT=IZCHNU IFILE=IZCHNA ISTAT=IZCHST IFORM=IZCHFO IACCES=IZCHAC IPROT=IZCHPR ICURST=IZCHCS C ISUBN0='READ' IERRFI='NO' CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT, 1 ICURST, 1 IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IOPFLG=1 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,1091) 1091 FORMAT('THE dpzchf.tex FILE OPENED.') CALL DPWRST('XXX','BUG ') ENDIF IF(IERRFI.EQ.'YES')GOTO4000 C CCCCC IF(IERRFI.EQ.'YES')THEN CCCCC IERROR='YES' CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1011) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1018) C1018 FORMAT(' UNABLE TO OPEN THE CHARACTER DATA FILE:') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1019)IFILE C1019 FORMAT(' ',A80) CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO8000 CCCCC ENDIF C READ(IOUNIT,'(I8)',END=4000,ERR=4000)NUMVAR IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,1093)NUMVAR 1093 FORMAT('NUMVAR = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C IFOUND='NO' DO1130I=1,NUMVAR READ(IOUNIT,'(A4,A4)',END=4000,ERR=4000)IH,IH2 IF(IHRIGH.EQ.IH .AND. IHRIG2.EQ.IH2)THEN IVAR=I IFOUND='YES' GOTO1199 ENDIF 1130 CONTINUE C C 1/2006: IF VARIABLE NOT FOUND, THEN C 1) SEE IF IT IS A PREVIOUSLY DEFINED STRING C 2) IF NOT A PREVIOUSLY DEFINED CHARACTER VARIABLE C OR A PREVIOUSLY DEFINED STRING, THEN TREAT AS C A LITERAL STRING C GOTO4000 C CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1011) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,131)IHRIGH,IHRIG2 CC131 FORMAT('***** VARIABLE ',A4,A4,' NOT FOUND IN THE CHARACTER ', CCCCC1 'DATA FILE:') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,119)IFILE CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO8000 C CC171 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,173) CC173 FORMAT(' ERROR READING THE NUMBER OF CHARACTER VARIABLES ', CCCCC1 'IN THE CHARACTER DATA FILE:') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,119)IFILE CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO8000 C CC181 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,183) CC183 FORMAT(' ERROR READING THE VARIABLE NAMES ', CCCCC1 'IN THE CHARACTER DATA FILE:') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,119)IFILE CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO8000 C 1199 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,1193)IVAR 1193 FORMAT('IVAR = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C C ************************************************* C ** STEP 3-- ** C ** DEFINE THE GRPOUP LABELS. ** C ** STORE UNIQUE VALUES IN IGRPLA. ** C ************************************************* C C 1/2006: THIS IS CASE WHERE WE READ GROUP LABELS FROM C CHARACTER DATA FILE (DPZCHF.DAT). C ISTEPN='3' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IATEMP=' ' IFRMT='(A )' WRITE(IFRMT(3:5),'(I3)')25*IVAR N=1 IROW=1 READ(IOUNIT,IFRMT,END=2491,ERR=2491)IATEMP IFRST=(IVAR-1)*25 + 1 ILAST=IVAR*25 - 1 IGRPLA(1,IGRP)=' ' IGRPLA(1,IGRP)=IATEMP(IFRST:ILAST) C DO2210I=2,MAXOBV IROW=I IATEMP=' ' READ(IOUNIT,IFRMT,END=2499,ERR=2491)IATEMP DO2220J=1,N IF(IATEMP(IFRST:ILAST).EQ.IGRPLA(J,IGRP)(1:24))GOTO2210 2220 CONTINUE N=N+1 C IF(N.GT.MAXGLA)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2261) 2261 FORMAT('***** WARNING IN LET ... = GROUP LABELS ...') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2263)MAXGLA 2263 FORMAT(' MAXIMUM NUMBER OF ROWS FOR GROUP LABELS (', 1 I6,') ','EXCEEDED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2265) 2265 FORMAT(' NO ADDITIONAL GROUP LABELS ASSIGNED.') CALL DPWRST('XXX','BUG ') GOTO8000 ENDIF C IGRPLA(N,IGRP)=' ' IGRPLA(N,IGRP)=IATEMP(IFRST:ILAST) 2210 CONTINUE GOTO2499 C 2491 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2493)IROW 2493 FORMAT(' ERROR READING ROW ',I8,' OF THE CHARACTER ', 1 'VARIABLES IN THE CHARACTER DATA FILE:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2495)IFILE 2495 FORMAT(' ',A80) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C C ************************************************* C ** STEP 4-- ** C ** DETERMINE IF VARIABLE IS A PREVIOUSLY ** C ** DEFINED STRING. IF NOT, TREAT AS A ** C ** LITERAL STRING. ** C ************************************************* C C 1/2006: THIS IS CASE WHERE WE READ GROUP LABELS FROM C 4000 CONTINUE ISTEPN='4' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C JMIN=5 JMAX=NUMARG C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,4001)JMIN,JMAX,MAXIND 4001 FORMAT('JMIN,JMAX,MAXIND = ',3I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(JMAX.LT.JMIN)GOTO8000 IWRITE='OFF' IERROR='NO' C CALL EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND, 1IHNAME,IHNAM2,IUSE,NUMNAM, 1ISTRN1,ISTRN2,NUMSTR, 1IWRITE,IBUGA3,ISUBRO,IERROR) C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,4003)NUMSTR 4003 FORMAT('NUMSTR = ',I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(IERROR.EQ.'NO')THEN C C CASE WHERE WE ARE EXTRACTING STRINGS C NUMSTR=MIN(NUMSTR,MAXGLA) N=NUMSTR DO4005I=1,MAXGLA IGRPLA(I,IGRP)=' ' 4005 CONTINUE C DO4010I2=1,NUMSTR DO4015I=1,NUMNAM II=I IF(ISTRN1(I2).EQ.IHNAME(I) .AND. ISTRN2(I2).EQ.IHNAM2(I)) 1 GOTO4019 4015 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4021) 4021 FORMAT('****** ERROR FROM DPGROL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4023)ISTRN1(I2),ISTRN2(I2) 4023 FORMAT(' STRING ',A4,A4,' NOT MATCHED IN NAME ', 1 'TABLE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO8000 C 4019 CONTINUE IVAL=IVALUE(II) VAL=VALUE(II) IL1=IVSTAR(II) IL2=IVSTOP(II) C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,4011)IL1,IL2 4011 FORMAT('II,IL1,IL2 = ',3I8) CALL DPWRST('XXX','BUG ') ENDIF C CALL DPCOFH(IL1,IL2,IFUNC,NUMCHF,IHTEMP,NH,IBUGA3,IERROR) ILAST=MIN(24,NH) C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,4013)NH,ILAST 4013 FORMAT('NH,ILAST = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(ILAST.GT.0)THEN DO4020J=1,ILAST IGRPLA(I2,IGRP)(J:J)=IHTEMP(J)(1:1) 4020 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,4014)I2,IGRPLA(I2,IGRP) 4014 FORMAT('I2,IGRPLA(I2,IGRP) = ',I8,A24) CALL DPWRST('XXX','BUG ') ENDIF ENDIF 4010 CONTINUE ELSE C C CASE WHERE WE ARE EXTRACTING LITERALS C ICNT=0 IFRST=5 MESSAG='OFF' DO4105I=1,MAXGLA IGRPLA(I,IGRP)=' ' 4105 CONTINUE DO4108I=1,130 ISTRIN(I:I)=IANSLC(I)(1:1) 4108 CONTINUE C 4100 CONTINUE IFRST=IFRST+1 ICNT=ICNT+1 ISTART=1 ISTOP=130 IERROR='NO' ICOL1=1 ICOL2=130 CALL DPEXS1(ISTRIN,ISTART,ISTOP,IFRST,MESSAG, 1 ICOL1,ICOL2,ISTRI2,NCSTR2, 1 IBUGA3,ISUBRO,IERROR) IF(NCSTR2.GT.0 .AND. IERROR.NE.'YES')THEN ILAST=MIN(24,NCSTR2) DO4120J=1,ILAST IGRPLA(ICNT,IGRP)(J:J)=ISTRI2(J:J) 4120 CONTINUE GOTO4100 ENDIF N=ICNT-1 ENDIF C GOTO2499 C C ****************************** C ** STEP 3-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C 2499 CONTINUE C IF(IFEEDB.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2811)N 2811 FORMAT('NUMBER OF DISTINCT FACTORS DETECTED = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IF(N.GT.1)THEN WRITE(ICOUT,2821)MIN(N,20) 2821 FORMAT('THE FIRST ',I4,' GROUP LABELS:') CALL DPWRST('XXX','BUG ') DO2820I=1,MIN(N,20) WRITE(ICOUT,2822)I,IGRPLA(I,IGRP) 2822 FORMAT('GROUP LABEL ',I2,' IS: ',A24) CALL DPWRST('XXX','BUG ') 2820 CONTINUE ENDIF ENDIF GOTO8000 C C *************************************** C ** STEP 88-- ** C ** CLOSE THE DPZCHF.DAT FILE. ** C *************************************** C 8000 CONTINUE C IF(IOPFLG.EQ.1)THEN IENDFI='OFF' IREWIN='ON' CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST, 1 IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR) IZCHCS='CLOSED' ENDIF GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GROL')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGROL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,IGRP 9013 FORMAT('N,IIGRP = ',2I8) CALL DPWRST('XXX','BUG ') IF(N.GT.0)THEN DO9015I=1,N WRITE(ICOUT,9016)I,IGRPLA(I,IGRP) 9016 FORMAT('I,IGRPLA(I,IGRP) = ',I8,A24) CALL DPWRST('XXX','BUG ') 9015 CONTINUE ENDIF ENDIF C RETURN END SUBROUTINE DPGRO2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A GROUND C WITH THE TOP AT (X1,Y1) C AND THE BOTTOM AT (X2,Y2). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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. CALL TO DPDRPL (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG C CHARACTER*4 ILINPA CHARACTER*4 ILINCO 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 CCCCC CHARACTER*4 ICOLF CCCCC 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 ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) 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.'GRO2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGRO2--') 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)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(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 GROUND ** C ********************************* C DELX=X2-X1 DELY=Y2-Y1 LEN=SQRT((X2-X1)**2+(Y2-Y1)**2) ALEN=LEN IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX) IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0 IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0 C K=0 C X=0 Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C X=ALEN Y=0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(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 K=0 C X=ALEN/3.0 Y=ALEN/2.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C X=ALEN/3.0 Y=-ALEN/2.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C 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 K=0 C X=ALEN*(2.0/3.0) Y=ALEN/4.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C X=ALEN*(2.0/3.0) Y=-ALEN/4.0 CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP) K=K+1 PX(K)=XP PY(K)=YP C NP=K C 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 C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'GRO2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGRO2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NP 9014 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 SUBROUTINE DPGROU(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 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 GROUNDS 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 TOP AND THE BOTTOM TIP C OF THE GROUND. 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 GROUND 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 GROUND 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 GROUND 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 --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 ILINPA CHARACTER*4 ILINCO 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 ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) DIMENSION IDPOWE(*) DIMENSION IDCONT(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDCOLO(*) 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.'GROU')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGROU--') 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)ILINPA(1),ILINCO(1),PLINTH(1) 61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(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='GROU' 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 DPGROU--') 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 GROUND ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH TOP AT THE POINT 20 20 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1137) 1137 FORMAT(' AND WITH THE BOTTOM AT THE POINT 20 15') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN THE ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' GROUND 20 20 20 15 ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' GROUND ABSOLUTE 20 20 20 15 ') 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 DPGRO2(X1,Y1,X2,Y2, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 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.'GROU')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGROU--') 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 DPGRPA(ICOM,IHARG,IHARG2,NUMARG, CCCCC AUGUST 1995. ADD IHARG2 FOR DASH2, ETC CCCCC SUBROUTINE DPGRPA(ICOM,IHARG,NUMARG, 1IDEFPA, 1IVGRPA,IHGRPA, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 GRID PATTERN SWITCHES CONTAINED IN THE C VARIABLES IVGRPA AND IHGRPA. C SUCH GRID PATTERN SWITCHES DEFINE THE PATTERN OF C THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL) C OF GRID LINES ON A PLOT. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFPA C OUTPUT ARGUMENTS--IVGRPA (A HOLLERITH VARIABLE C DENOTING THE PATTERN OF THE VERTICAL GRID LINES C --IHGRPA (A HOLLERITH VARIABLE C DENOTING THE PATTERN OF THE HORIZONTAL GRID LINES C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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 UPDATED --AUGUST 1995. DASH2 BUG C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IHARG2 CHARACTER*4 IDEFPA C CHARACTER*4 IVGRPA CHARACTER*4 IHGRPA C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) CCCCC AUGUST 1995. ADD FOLLOWING LINE 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)GOTO1900 C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE VERTICAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XGRI')GOTO1100 GOTO1199 C 1100 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 IF(IHARG(NUMARG).EQ.'PATT')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFPA GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5' GOTO1180 C 1180 CONTINUE IFOUND='YES' IVGRPA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE GRID PATTERN (FOR VERTICAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'YGRI')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'PATT')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFPA GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5' GOTO1280 C 1280 CONTINUE IFOUND='YES' IHGRPA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE GRID PATTERN (FOR HORIZONTAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ******************************************************* C ** TREAT THE CASE WHEN ** C ** GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED ** C ******************************************************* C IF(ICOM.EQ.'GRID')GOTO1300 IF(ICOM.EQ.'XYGR')GOTO1300 IF(ICOM.EQ.'YXGR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'PATT')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFPA GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'2')IHOLD='DA2' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'3')IHOLD='DA3' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'4')IHOLD='DA4' IF(IHOLD.EQ.'DASH'.AND.IHARG2(NUMARG).EQ.'5')IHOLD='DA5' GOTO1380 C 1380 CONTINUE IFOUND='YES' IHGRPA=IHOLD IVGRPA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE GRID PATTERN (FOR GRID LINES IN ', 1'BOTH DIRECTIONS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPGRTH(ICOM,IHARG,ARG,NUMARG, 1PDEFTH, 1PVGRTH,PHGRTH, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE 2 GRID THICKNESS SWITCHES CONTAINED IN THE C VARIABLES PVGRTH AND PHGRTH. C SUCH GRID THICKNESS SWITCHES DEFINE THE THICKNESS OF C THE 2 SETS (ONE VERTICAL AND ONE HORIZONTAL) C OF GRID LINES ON A PLOT. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFTH C OUTPUT ARGUMENTS--PVGRTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE VERTICAL GRID LINES C --PHGRTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE HORIZONTAL GRID LINES C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY 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 TECHNOOGY. 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 ICOM CHARACTER*4 IHARG REAL PDEFTH C REAL PVGRTH REAL PHGRTH C CHARACTER*4 IFOUND CHARACTER*4 IERROR C REAL PHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) 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 IF(NUMARG.LE.0)GOTO1900 C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE VERTICAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XGRI')GOTO1100 GOTO1199 C 1100 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 IF(IHARG(NUMARG).EQ.'THIC')GOTO1150 GOTO1160 C 1150 CONTINUE PHOLD=PDEFTH GOTO1180 C 1160 CONTINUE PHOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PVGRTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE GRID THICKNESS (FOR VERTICAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)PHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ** C ** THE HORIZONTAL GRID LINES ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'YGRI')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'THIC')GOTO1250 GOTO1260 C 1250 CONTINUE PHOLD=PDEFTH GOTO1280 C 1260 CONTINUE PHOLD=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PHGRTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE GRID THICKNESS (FOR HORIZONTAL ', 1'GRID LINES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)PHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ******************************************************* C ** TREAT THE CASE WHEN ** C ** GRID LINES IN BOTH DIRECTIONS ARE TO BE CHANGED ** C ******************************************************* C IF(ICOM.EQ.'GRID')GOTO1300 IF(ICOM.EQ.'XYGR')GOTO1300 IF(ICOM.EQ.'YXGR')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'THIC')GOTO1350 GOTO1360 C 1350 CONTINUE PHOLD=PDEFTH GOTO1380 C 1360 CONTINUE PHOLD=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PHGRTH=PHOLD PVGRTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE GRID THICKNESS (FOR GRID LINES IN ', 1'BOTH DIRECTIONS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)PHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPGRUB(XTEMP1,MAXNXT, 1ICAPSW,ICASAN, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT GRUBB TEST FOR C OUTLIERS C EXAMPLE--GRUBB TEST Y C REFERENCE--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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--97/9 C ORIGINAL VERSION--SEPTEMBER 1997. C UPDATED --JANUARY 2004. C UPDATED --FEBRUARY 2006. DISTINCT CASES FOR MINIMUM C AND MAXIMUM 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 CHARACTER*4 ICAPSW CHARACTER*4 ICASAN C CHARACTER*4 MESSAG CHARACTER*4 ICASEQ C CHARACTER*4 IHWUSE CHARACTER*4 IH11 CHARACTER*4 IH12 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IUSE1 CHARACTER*4 IUSE2 C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHOST1 CHARACTER*4 ISUBN0 C C--------------------------------------------------------------------- C DIMENSION XTEMP1(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.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 ISUBN1='DPGR' ISUBN2='UB ' 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 GRUBB TEST CASE ** C ******************************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'GRUB')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPGRUB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGQ 53 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)MAXNXT 55 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=1 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C **************************************** C ** STEP 11-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS 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 DPGRUB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' FOR THE GRUBB TEST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1145) 1145 FORMAT(' THE ARGUMENT 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,MIN(IWIDTH,80)) 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 DPGRUB--') 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 THE GRUBB 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,MIN(80,IWIDTH)) 1220 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1290 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 DPGRUB--') 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 THE GRUBB 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,MIN(80,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 52-- ** C ** DO THE GRUBB 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 DPGRUB, AS WE ARE ABOUT TO CALL DPGRU2--') 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 WRITE(ICOUT,5231)IBUGA3 5231 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') 5290 CONTINUE C CALL DPGRU2(Y,NS1, 1XTEMP1,MAXNXT, 1ICAPSW,ICAPTY,IGRU1S,ICASAN, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100, 1ISUBRO,IBUGA3,IERROR) C C *************************************** C ** STEP 61-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='61' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ISUBN0='DPGR' 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='CDF ' VALUE0=STATCD CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF50' VALUE0=CUT50 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF75' VALUE0=CUT75 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF90' VALUE0=CUT90 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF95' VALUE0=CUT95 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='F975' VALUE0=CUT975 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='FF99' VALUE0=CUT99 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='CUTO' IH2='F100' VALUE0=CUT100 CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'GRUB')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPGRUB--') 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 DPGRU2(Y,N, 1XTEMP,MAXNXT, 1ICAPSW,ICAPTY,IGRU1S,ICASAN, 1STATVA,STATCD,CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT100, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE CARRIES OUT THE GRUBB TEST C FOR EQUALITY TO A DISTRIBUTION C EXAMPLE--GRUBB TEST Y C REFERENCE--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY. 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--97/9 C ORIGINAL VERSION--SEPTEMBER 1997. C UPDATED --JANUARY 2004. SUPPORT FOR HTML, LATEX OUTPUT C UPDATED --MAY 2005. CORRECT CRITICAL VALUES C (REALLY 2 TESTS - ONE FOR C POSITIVE OUTLIERS AND ONE FOR C NEGATIVE OUTLIERS). NEED TO C DIVIDE CRITICAL VALUES BY 2. C IN ADDITION, GENERATE THE C ONE TAILED VERSIONS. C UPDATED --FEBRUARY 2006. SEPARATE SYNTAX FOR MINIMUM C AND MAXIMUM TESTS C UPDATED --OCTOBER 2006. CALL LIST TO TCDF AND TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR CHARACTER*4 ICAPSW CHARACTER*4 ICAPTY CHARACTER*4 IGRU1S CHARACTER*4 ICASAN C CHARACTER*4 IWRITE CHARACTER*4 IBASLC C CHARACTER*6 ICONC1 CHARACTER*6 ICONC2 CHARACTER*6 ICONC3 CHARACTER*6 ICONC4 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION XTEMP(*) 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='DPGR' ISUBN2='UB ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GRU2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF DPGRU2--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,52)IBUGA3,ICASAN 52 FORMAT('IBUGA3,ICASAN = ',2A4) 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 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 DPGRU2--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 DPGRU2--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 DPGRU2--VARIABLE 1 ', 1'HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','WRIT') GOTO9000 1139 CONTINUE C 1290 CONTINUE C C ****************************** C ** STEP 41-- ** C ** CARRY OUT CALCULATIONS ** C ** FOR GRUBB's TEST ** C ****************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IWRITE='OFF' NM2=N-2 CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR) CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR) CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR) CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR) RATIO1=(YMEAN-YMIN)/YSD RATIO2=(YMAX-YMEAN)/YSD STATV0=MAX(RATIO1,RATIO2) STATV1=RATIO1 STATV2=RATIO2 C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')THEN WRITE(ICOUT,4109)YMEAN,YSD,YMIN,YMAX CALL DPWRST('XXX','BUG') ENDIF 4109 FORMAT('YMEAN,YSD,YMIN,YMAX=',4E15.7) C C 3 CASES: C C 1) TEST BOTH MIN AND MAX C 2) TEST MIN C 3) TEST MAX C CCCCC IPASS=0 C C4199 CONTINUE C CCCCC IPASS=IPASS+1 CCCCC IF(IPASS.GT.3)GOTO9000 CCCCC IF(IGRU1S.EQ.'OFF'.AND.IPASS.GT.1)GOTO9000 C IF(ICASAN.EQ.'GTES')THEN STATVA=STATV0 AFACT=2.0 APOSS=YMIN IF(RATIO2.GT.RATIO1)APOSS=YMAX ELSEIF(ICASAN.EQ.'GTMI')THEN STATVA=STATV1 AFACT=1.0 APOSS=YMIN ELSEIF(ICASAN.EQ.'GTMA')THEN STATVA=STATV2 AFACT=1.0 APOSS=YMAX ENDIF Q=(STATVA*SQRT(REAL(N))/REAL(N-1))**2 IF(Q.GE.1.0)THEN STATCD=1.0 ELSE T=SQRT((Q/(1.0-Q))*REAL(NM2)) T2=-T CALL TCDF(T2,REAL(NM2),CDF) ALPHA=2.0*REAL(N)*CDF STATCD=1.0-ALPHA ENDIF C CUT0=0. C C MAY 2005. DIVIDE CRITICAL VALUES BY 2. C ALPHA=.5 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT50=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=.25 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT75=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=.10 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT90=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=.05 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT95=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=.025 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT975=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=.01 P2=1.0 - (ALPHA/REAL(N))/AFACT CALL TPPF(P2,REAL(NM2),T) CUT99=(REAL(N-1)/SQRT(REAL(N)))*SQRT(T*T/(REAL(NM2)+T*T)) C ALPHA=0.0 CUT100=REAL(N-1)/SQRT(REAL(N)) C ICONC1='REJECT' ICONC2='REJECT' ICONC3='REJECT' ICONC4='REJECT' C C ********************************* C ** STEP 42-- ** C ** WRITE OUT EVERYTHING ** C ** FOR GRUBB TEST ** C ********************************* C ISTEPN='42' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'HTML')THEN C C STEP 1: WRITE HEADER C WRITE(ICOUT,5001) 5001 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5002) 5002 FORMAT('
') CALL DPWRST('XXX','WRIT') IF(ICASAN.EQ.'GTES')THEN WRITE(ICOUT,5003) 5003 FORMAT('GRUBBS TEST FOR OUTLIERS (TEST MAX AND MIN)
') ELSEIF(ICASAN.EQ.'GTMI')THEN WRITE(ICOUT,5006) 5006 FORMAT('GRUBBS TEST FOR OUTLIERS (TEST MIN ONLY)
') ELSEIF(ICASAN.EQ.'GTMA')THEN WRITE(ICOUT,5008) 5008 FORMAT('GRUBBS TEST FOR OUTLIERS (TEST MAX ONLY)
') ENDIF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5004) 5004 FORMAT('(ASSUMPTION: NORMALITY)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5005) 5005 FORMAT('


') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C C STEP 2: START LIST C WRITE(ICOUT,5010) 5010 FORMAT('
    ') CALL DPWRST('XXX','WRIT') C C STEP 2A: LIST ITEM 1 C 5007 FORMAT('
  1. Statistics:') 5009 FORMAT('

    ') 5011 FORMAT(' ') 5021 FORMAT(' ') 5023 FORMAT(' ') 5026 FORMAT(' ') 5051 FORMAT(' ',G15.7) 5052 FORMAT('  ') WRITE(ICOUT,5007) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5009) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') C 5025 FORMAT(' Number of Observations:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5025) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5029)N CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5041 FORMAT(' Minimum:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5041) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)YMIN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5042 FORMAT(' Mean:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5042) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)YMEAN CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5043 FORMAT(' Maximum:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5043) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)YMAX CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5044 FORMAT(' Standard Deviation:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5044) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)YSD CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5045 FORMAT(' Grubbs Test Statistic') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5045) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)STATVA CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5052) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5091) 5091 FORMAT('
    ') 5027 FORMAT(' ') 5029 FORMAT(' ',I8) 5028 FORMAT('
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5009) CALL DPWRST('XXX','WRIT') C C STEP 2B: LIST ITEM 2 C WRITE(ICOUT,5066) 5066 FORMAT('

  2. Percent Points of the Reference ', 1 'Distribution
    ') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5067) 5067 FORMAT(' for the Grubbs Test Statistic:') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5009) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') C 5071 FORMAT(' 0 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5071) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT0 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5072 FORMAT(' 50 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5072) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT50 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5073 FORMAT(' 75 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5073) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT75 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5074 FORMAT(' 90 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5074) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT90 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5075 FORMAT(' 95 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5075) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT95 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5078 FORMAT(' 97.55 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5075) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT975 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') 5076 FORMAT(' 99 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5076) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT99 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') C 5077 FORMAT(' 100 Percent Point:') WRITE(ICOUT,5021) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5023) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5077) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5026) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5051)CUT100 CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5027) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5028) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5091) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5009) CALL DPWRST('XXX','WRIT') C C STEP 2C: LIST ITEM 3 C WRITE(ICOUT,5081) 5081 FORMAT('
  3. Conclusion (at the 5% level):') CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5009) CALL DPWRST('XXX','WRIT') IF(STATVA.LE.CUT95)THEN WRITE(ICOUT,5087) 5087 FORMAT(' There are no outliers.') CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,5088)APOSS 5088 FORMAT(' The value, ',G15.7,', is an outlier') CALL DPWRST('XXX','WRIT') ENDIF CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5093) 5093 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5095) 5095 FORMAT('
')
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'LATE')THEN
 8000   FORMAT('{',A1,'bf GRUBBS TEST FOR OUTLIERS ',
     1         '(TEST BOTH MIN AND MAX}',2X,A1,A1)
 8013   FORMAT('{',A1,'bf GRUBBS TEST FOR OUTLIERS ',
     1         '(TEST MIN ONLY}',2X,A1,A1)
 8014   FORMAT('{',A1,'bf GRUBBS TEST FOR OUTLIERS ',
     1         '(TEST MAX ONLY}',2X,A1,A1)
 8001   FORMAT('{',A1,'bf (ASSUMPTION: NORMALITY}')
 8002   FORMAT(A1,'begin{table}')
 8003   FORMAT(A1,'end{table}')
 8004   FORMAT(A1,'begin{center}')
 8005   FORMAT(A1,'end{center}')
 8006   FORMAT(A1,'end{verbatim}')
 8007   FORMAT(5X,'$ ',A1,1X,A1,' $ ',A1,A1)
 8011   FORMAT(A1,'begin{enumerate}')
 8012   FORMAT(A1,'end{enumerate}')
C
        CALL DPCONA(92,IBASLC)
C
        WRITE(ICOUT,8006)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8004)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8002)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(ICASAN.EQ.'GTES')THEN
          WRITE(ICOUT,8000)IBASLC,IBASLC,IBASLC
        ELSEIF(ICASAN.EQ.'GTMI')THEN
          WRITE(ICOUT,8013)IBASLC,IBASLC,IBASLC
        ELSEIF(ICASAN.EQ.'GTMA')THEN
          WRITE(ICOUT,8014)IBASLC,IBASLC,IBASLC
        ENDIF
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8001)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,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8011)IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8020   FORMAT(11X,A1,'newline')
 8021   FORMAT(5X,A1,'item Statistics:')
 8022   FORMAT(5X,A1,'item Percent Points of the Reference ',
     1         'Distribution for Grubbs Test Statistic:')
 8023   FORMAT(5X,A1,'item Conclusion (at the 5',A1,'% level):')
 8030   FORMAT(11X,A1,'begin{tabular} {lr}')
 8031   FORMAT(11X,'Number of Observations: & ',I8,2X,A1,A1)
 8032   FORMAT(11X,'Minimum: & ',G15.7,2X,A1,A1)
 8033   FORMAT(11X,'Mean: & ',G15.7,2X,A1,A1)
 8034   FORMAT(11X,'Maximum: & ',G15.7,2X,A1,A1)
 8035   FORMAT(11X,'Standard Deviation: & ',G15.7,2X,A1,A1)
 8036   FORMAT(11X,'Grubbs Test Statistic: & ',G15.7,2X,A1,A1)
 8040   FORMAT(11X,A1,'end{tabular}')
 8042   FORMAT(11X,'There are no outliers.',2X,A1,A1)
 8043   FORMAT(11X,'The value, ',G15.7,', is an outlier.',2X,A1,A1)
 8044   FORMAT(11X,'0      Percent Point: & ',G15.7,2X,A1,A1)
 8045   FORMAT(11X,'50     Percent Point: & ',G15.7,2X,A1,A1)
 8046   FORMAT(11X,'90     Percent Point: & ',G15.7,2X,A1,A1)
 8047   FORMAT(11X,'95     Percent Point: & ',G15.7,2X,A1,A1)
 8048   FORMAT(11X,'99     Percent Point: & ',G15.7,2X,A1,A1)
 8049   FORMAT(11X,'99.5   Percent Point: & ',G15.7,2X,A1,A1)
 8050   FORMAT(11X,'100    Percent Point: & ',G15.7,2X,A1,A1)
 8058   FORMAT(11X,'97.5   Percent Point: & ',G15.7,2X,A1,A1)
C
        WRITE(ICOUT,8021)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8031)N,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8032)YMIN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8033)YMIN,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8034)YMAX,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8035)YSD,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8036)STATVA,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8022)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8030)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8044)CUT0,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8045)CUT50,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8046)CUT90,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8047)CUT95,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8058)CUT975,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8048)CUT99,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8050)CUT100,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8040)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,8023)IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8020)IBASLC
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LE.CUT95)THEN
          WRITE(ICOUT,8042)IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,8043)APOSS,IBASLC,IBASLC
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
 8051   FORMAT(A1,'end{enumerate}')
 8052   FORMAT(A1,'begin{verbatim}')
        WRITE(ICOUT,8051)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8003)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8005)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8052)IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON'.AND.ICAPTY.EQ.'RTF')THEN
C
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        IF(ICASAN.EQ.'GTES')THEN
          WRITE(ICOUT,4211)
 4211     FORMAT('              GRUBBS TEST FOR OUTLIERS ',
     1           '(TEST FOR BOTH MIN AND MAX)')
        ELSEIF(ICASAN.EQ.'GTMI')THEN
          WRITE(ICOUT,4213)
 4213     FORMAT('              GRUBBS TEST FOR OUTLIERS ',
     1           '(TEST FOR MIN ONLY)')
        ELSEIF(ICASAN.EQ.'GTMA')THEN
          WRITE(ICOUT,4214)
 4214     FORMAT('              GRUBBS TEST FOR OUTLIERS ',
     1           '(TEST FOR MAX ONLY)')
        ENDIF
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4212)
 4212   FORMAT('              (ASSUMPTION: NORMALITY)')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4241)
 4241   FORMAT('1. STATISTICS:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4242)N
 4242   FORMAT(6X,'NUMBER OF OBSERVATIONS      = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4343)YMIN
 4343   FORMAT(6X,'MINIMUM                     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4243)YMEAN
 4243   FORMAT(6X,'MEAN                        = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4443)YMAX
 4443   FORMAT(6X,'MAXIMUM                     = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4244)YSD
 4244   FORMAT(6X,'STANDARD DEVIATION          = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4344)STATVA
 4344   FORMAT(6X,'GRUBBS TEST STATISTIC       = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4341)
 4341   FORMAT('2. PERCENT POINTS OF THE REFERENCE DISTRIBUTION')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4441)
 4441   FORMAT(3X,'FOR GRUBBS TEST STATISTIC')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4245)CUT0
 4245   FORMAT(6X,'0          % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4246)CUT50
 4246   FORMAT(6X,'50         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4247)CUT75
 4247   FORMAT(6X,'75         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4248)CUT90
 4248   FORMAT(6X,'90         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4249)CUT95
 4249   FORMAT(6X,'95         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4253)CUT975
 4253   FORMAT(6X,'97.5       % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4250)CUT99
 4250   FORMAT(6X,'99         % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4251)CUT100
 4251   FORMAT(6X,'100        % POINT    = ',G15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        CDF2=100.0*STATCD
CCCCC   WRITE(ICOUT,4259)CDF2,STATVA
C4259   FORMAT(6X,G15.7,'  % POINT:     ',G15.7)
CCCCC   CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4261)
 4261   FORMAT('3. CONCLUSION (AT THE 5% LEVEL):')
        CALL DPWRST('XXX','WRIT')
        IF(STATVA.LT.CUT95)THEN
          WRITE(ICOUT,4263)
 4263     FORMAT(6X,'THERE ARE NO OUTLIERS.')
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,4265)APOSS
 4265     FORMAT(6X,'THE VALUE, ',G15.7,', IS AN OUTLIER.')
          CALL DPWRST('XXX','WRIT')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
      ENDIF
      ENDIF
CCCCC GOTO4199
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GRU2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPGRU2--')
      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),XTEMP(I)
 9017 FORMAT('I,Y(I),XTEMP(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','WRIT')
 9016 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPGSL(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR GREEK SIMPLEX LOWER CASE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICHAR2
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
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
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPGSL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHAR2
   52 FORMAT('ICHAR2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **  STEP 1--                                    **
C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
C               **************************************************
C
      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
      IF(IFOUND.EQ.'NO')GOTO9000
C
      IF(ICHARN.LE.16)GOTO1010
      GOTO1019
 1010 CONTINUE
      CALL DGSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
      GOTO9000
 1019 CONTINUE
C
      IF(ICHARN.GE.17)GOTO1020
      GOTO1029
 1020 CONTINUE
      CALL DGSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
      GOTO9000
 1029 CONTINUE
C
      IFOUND='NO'
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPGSL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHAR2,ICHARN
 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPGSU(ICHAR2,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS,
     1IBUGD2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES
C              FOR GREEK SIMPLEX UPPER CASE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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/4
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MARCH     1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICHAR2
      CHARACTER*4 IOP
      CHARACTER*4 IBUGD2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
C
C---------------------------------------------------------------------
C
      DIMENSION IOP(*)
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION IOPERA(300)
      DIMENSION IX(300)
      DIMENSION IY(300)
C
      DIMENSION IXMIND(30)
      DIMENSION IXMAXD(30)
      DIMENSION IXDELD(30)
      DIMENSION ISTARD(30)
      DIMENSION NUMCOO(30)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----DATA STATEMENTS-------------------------------------------------
C
C     DEFINE CHARACTER    527--UPPER CASE ALPH
C
      DATA IOPERA(   1),IX(   1),IY(   1)/'MOVE',   0,  12/
      DATA IOPERA(   2),IX(   2),IY(   2)/'DRAW',  -8,  -9/
      DATA IOPERA(   3),IX(   3),IY(   3)/'MOVE',   0,  12/
      DATA IOPERA(   4),IX(   4),IY(   4)/'DRAW',   8,  -9/
      DATA IOPERA(   5),IX(   5),IY(   5)/'MOVE',  -5,  -2/
      DATA IOPERA(   6),IX(   6),IY(   6)/'DRAW',   5,  -2/
C
      DATA IXMIND(   1)/  -9/
      DATA IXMAXD(   1)/   9/
      DATA IXDELD(   1)/  18/
      DATA ISTARD(   1)/   1/
      DATA NUMCOO(   1)/   6/
C
C     DEFINE CHARACTER    528--UPPER CASE BETA
C
      DATA IOPERA(   7),IX(   7),IY(   7)/'MOVE',  -7,  12/
      DATA IOPERA(   8),IX(   8),IY(   8)/'DRAW',  -7,  -9/
      DATA IOPERA(   9),IX(   9),IY(   9)/'MOVE',  -7,  12/
      DATA IOPERA(  10),IX(  10),IY(  10)/'DRAW',   2,  12/
      DATA IOPERA(  11),IX(  11),IY(  11)/'DRAW',   5,  11/
      DATA IOPERA(  12),IX(  12),IY(  12)/'DRAW',   6,  10/
      DATA IOPERA(  13),IX(  13),IY(  13)/'DRAW',   7,   8/
      DATA IOPERA(  14),IX(  14),IY(  14)/'DRAW',   7,   6/
      DATA IOPERA(  15),IX(  15),IY(  15)/'DRAW',   6,   4/
      DATA IOPERA(  16),IX(  16),IY(  16)/'DRAW',   5,   3/
      DATA IOPERA(  17),IX(  17),IY(  17)/'DRAW',   2,   2/
      DATA IOPERA(  18),IX(  18),IY(  18)/'MOVE',  -7,   2/
      DATA IOPERA(  19),IX(  19),IY(  19)/'DRAW',   2,   2/
      DATA IOPERA(  20),IX(  20),IY(  20)/'DRAW',   5,   1/
      DATA IOPERA(  21),IX(  21),IY(  21)/'DRAW',   6,   0/
      DATA IOPERA(  22),IX(  22),IY(  22)/'DRAW',   7,  -2/
      DATA IOPERA(  23),IX(  23),IY(  23)/'DRAW',   7,  -5/
      DATA IOPERA(  24),IX(  24),IY(  24)/'DRAW',   6,  -7/
      DATA IOPERA(  25),IX(  25),IY(  25)/'DRAW',   5,  -8/
      DATA IOPERA(  26),IX(  26),IY(  26)/'DRAW',   2,  -9/
      DATA IOPERA(  27),IX(  27),IY(  27)/'DRAW',  -7,  -9/
C
      DATA IXMIND(   2)/ -11/
      DATA IXMAXD(   2)/  10/
      DATA IXDELD(   2)/  21/
      DATA ISTARD(   2)/   7/
      DATA NUMCOO(   2)/  21/
C
C     DEFINE CHARACTER    529--UPPER CASE GAMM
C
      DATA IOPERA(  28),IX(  28),IY(  28)/'MOVE',  -6,  12/
      DATA IOPERA(  29),IX(  29),IY(  29)/'DRAW',  -6,  -9/
      DATA IOPERA(  30),IX(  30),IY(  30)/'MOVE',  -6,  12/
      DATA IOPERA(  31),IX(  31),IY(  31)/'DRAW',   6,  12/
C
      DATA IXMIND(   3)/ -10/
      DATA IXMAXD(   3)/   7/
      DATA IXDELD(   3)/  17/
      DATA ISTARD(   3)/  28/
      DATA NUMCOO(   3)/   4/
C
C     DEFINE CHARACTER    530--UPPER CASE DELT
C
      DATA IOPERA(  32),IX(  32),IY(  32)/'MOVE',   0,  12/
      DATA IOPERA(  33),IX(  33),IY(  33)/'DRAW',  -8,  -9/
      DATA IOPERA(  34),IX(  34),IY(  34)/'MOVE',   0,  12/
      DATA IOPERA(  35),IX(  35),IY(  35)/'DRAW',   8,  -9/
      DATA IOPERA(  36),IX(  36),IY(  36)/'MOVE',  -8,  -9/
      DATA IOPERA(  37),IX(  37),IY(  37)/'DRAW',   8,  -9/
C
      DATA IXMIND(   4)/  -9/
      DATA IXMAXD(   4)/   9/
      DATA IXDELD(   4)/  18/
      DATA ISTARD(   4)/  32/
      DATA NUMCOO(   4)/   6/
C
C     DEFINE CHARACTER    531--UPPER CASE EPSI
C
      DATA IOPERA(  38),IX(  38),IY(  38)/'MOVE',  -6,  12/
      DATA IOPERA(  39),IX(  39),IY(  39)/'DRAW',  -6,  -9/
      DATA IOPERA(  40),IX(  40),IY(  40)/'MOVE',  -6,  12/
      DATA IOPERA(  41),IX(  41),IY(  41)/'DRAW',   7,  12/
      DATA IOPERA(  42),IX(  42),IY(  42)/'MOVE',  -6,   2/
      DATA IOPERA(  43),IX(  43),IY(  43)/'DRAW',   2,   2/
      DATA IOPERA(  44),IX(  44),IY(  44)/'MOVE',  -6,  -9/
      DATA IOPERA(  45),IX(  45),IY(  45)/'DRAW',   7,  -9/
C
      DATA IXMIND(   5)/ -10/
      DATA IXMAXD(   5)/   9/
      DATA IXDELD(   5)/  19/
      DATA ISTARD(   5)/  38/
      DATA NUMCOO(   5)/   8/
C
C     DEFINE CHARACTER    532--UPPER CASE ZETA
C
      DATA IOPERA(  46),IX(  46),IY(  46)/'MOVE',   7,  12/
      DATA IOPERA(  47),IX(  47),IY(  47)/'DRAW',  -7,  -9/
      DATA IOPERA(  48),IX(  48),IY(  48)/'MOVE',  -7,  12/
      DATA IOPERA(  49),IX(  49),IY(  49)/'DRAW',   7,  12/
      DATA IOPERA(  50),IX(  50),IY(  50)/'MOVE',  -7,  -9/
      DATA IOPERA(  51),IX(  51),IY(  51)/'DRAW',   7,  -9/
C
      DATA IXMIND(   6)/ -10/
      DATA IXMAXD(   6)/  10/
      DATA IXDELD(   6)/  20/
      DATA ISTARD(   6)/  46/
      DATA NUMCOO(   6)/   6/
C
C     DEFINE CHARACTER    533--UPPER CASE ETA
C
      DATA IOPERA(  52),IX(  52),IY(  52)/'MOVE',  -7,  12/
      DATA IOPERA(  53),IX(  53),IY(  53)/'DRAW',  -7,  -9/
      DATA IOPERA(  54),IX(  54),IY(  54)/'MOVE',   7,  12/
      DATA IOPERA(  55),IX(  55),IY(  55)/'DRAW',   7,  -9/
      DATA IOPERA(  56),IX(  56),IY(  56)/'MOVE',  -7,   2/
      DATA IOPERA(  57),IX(  57),IY(  57)/'DRAW',   7,   2/
C
      DATA IXMIND(   7)/ -11/
      DATA IXMAXD(   7)/  11/
      DATA IXDELD(   7)/  22/
      DATA ISTARD(   7)/  52/
      DATA NUMCOO(   7)/   6/
C
C     DEFINE CHARACTER    534--UPPER CASE THET
C
      DATA IOPERA(  58),IX(  58),IY(  58)/'MOVE',  -2,  12/
      DATA IOPERA(  59),IX(  59),IY(  59)/'DRAW',  -4,  11/
      DATA IOPERA(  60),IX(  60),IY(  60)/'DRAW',  -6,   9/
      DATA IOPERA(  61),IX(  61),IY(  61)/'DRAW',  -7,   7/
      DATA IOPERA(  62),IX(  62),IY(  62)/'DRAW',  -8,   4/
      DATA IOPERA(  63),IX(  63),IY(  63)/'DRAW',  -8,  -1/
      DATA IOPERA(  64),IX(  64),IY(  64)/'DRAW',  -7,  -4/
      DATA IOPERA(  65),IX(  65),IY(  65)/'DRAW',  -6,  -6/
      DATA IOPERA(  66),IX(  66),IY(  66)/'DRAW',  -4,  -8/
      DATA IOPERA(  67),IX(  67),IY(  67)/'DRAW',  -2,  -9/
      DATA IOPERA(  68),IX(  68),IY(  68)/'DRAW',   2,  -9/
      DATA IOPERA(  69),IX(  69),IY(  69)/'DRAW',   4,  -8/
      DATA IOPERA(  70),IX(  70),IY(  70)/'DRAW',   6,  -6/
      DATA IOPERA(  71),IX(  71),IY(  71)/'DRAW',   7,  -4/
      DATA IOPERA(  72),IX(  72),IY(  72)/'DRAW',   8,  -1/
      DATA IOPERA(  73),IX(  73),IY(  73)/'DRAW',   8,   4/
      DATA IOPERA(  74),IX(  74),IY(  74)/'DRAW',   7,   7/
      DATA IOPERA(  75),IX(  75),IY(  75)/'DRAW',   6,   9/
      DATA IOPERA(  76),IX(  76),IY(  76)/'DRAW',   4,  11/
      DATA IOPERA(  77),IX(  77),IY(  77)/'DRAW',   2,  12/
      DATA IOPERA(  78),IX(  78),IY(  78)/'DRAW',  -2,  12/
      DATA IOPERA(  79),IX(  79),IY(  79)/'MOVE',  -3,   2/
      DATA IOPERA(  80),IX(  80),IY(  80)/'DRAW',   3,   2/
C
      DATA IXMIND(   8)/ -11/
      DATA IXMAXD(   8)/  11/
      DATA IXDELD(   8)/  22/
      DATA ISTARD(   8)/  58/
      DATA NUMCOO(   8)/  23/
C
C     DEFINE CHARACTER    535--UPPER CASE IOTA
C
      DATA IOPERA(  81),IX(  81),IY(  81)/'MOVE',   0,  12/
      DATA IOPERA(  82),IX(  82),IY(  82)/'DRAW',   0,  -9/
C
      DATA IXMIND(   9)/  -4/
      DATA IXMAXD(   9)/   4/
      DATA IXDELD(   9)/   8/
      DATA ISTARD(   9)/  81/
      DATA NUMCOO(   9)/   2/
C
C     DEFINE CHARACTER    536--UPPER CASE KAPP
C
      DATA IOPERA(  83),IX(  83),IY(  83)/'MOVE',  -7,  12/
      DATA IOPERA(  84),IX(  84),IY(  84)/'DRAW',  -7,  -9/
      DATA IOPERA(  85),IX(  85),IY(  85)/'MOVE',   7,  12/
      DATA IOPERA(  86),IX(  86),IY(  86)/'DRAW',  -7,  -2/
      DATA IOPERA(  87),IX(  87),IY(  87)/'MOVE',  -2,   3/
      DATA IOPERA(  88),IX(  88),IY(  88)/'DRAW',   7,  -9/
C
      DATA IXMIND(  10)/ -11/
      DATA IXMAXD(  10)/  10/
      DATA IXDELD(  10)/  21/
      DATA ISTARD(  10)/  83/
      DATA NUMCOO(  10)/   6/
C
C     DEFINE CHARACTER    537--UPPER CASE LAMB
C
      DATA IOPERA(  89),IX(  89),IY(  89)/'MOVE',   0,  12/
      DATA IOPERA(  90),IX(  90),IY(  90)/'DRAW',  -8,  -9/
      DATA IOPERA(  91),IX(  91),IY(  91)/'MOVE',   0,  12/
      DATA IOPERA(  92),IX(  92),IY(  92)/'DRAW',   8,  -9/
C
      DATA IXMIND(  11)/  -9/
      DATA IXMAXD(  11)/   9/
      DATA IXDELD(  11)/  18/
      DATA ISTARD(  11)/  89/
      DATA NUMCOO(  11)/   4/
C
C     DEFINE CHARACTER    538--UPPER CASE MU
C
      DATA IOPERA(  93),IX(  93),IY(  93)/'MOVE',  -8,  12/
      DATA IOPERA(  94),IX(  94),IY(  94)/'DRAW',  -8,  -9/
      DATA IOPERA(  95),IX(  95),IY(  95)/'MOVE',  -8,  12/
      DATA IOPERA(  96),IX(  96),IY(  96)/'DRAW',   0,  -9/
      DATA IOPERA(  97),IX(  97),IY(  97)/'MOVE',   8,  12/
      DATA IOPERA(  98),IX(  98),IY(  98)/'DRAW',   0,  -9/
      DATA IOPERA(  99),IX(  99),IY(  99)/'MOVE',   8,  12/
      DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW',   8,  -9/
C
      DATA IXMIND(  12)/ -12/
      DATA IXMAXD(  12)/  12/
      DATA IXDELD(  12)/  24/
      DATA ISTARD(  12)/  93/
      DATA NUMCOO(  12)/   8/
C
C     DEFINE CHARACTER    539--UPPER CASE NU
C
      DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE',  -7,  12/
      DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW',  -7,  -9/
      DATA IOPERA( 103),IX( 103),IY( 103)/'MOVE',  -7,  12/
      DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW',   7,  -9/
      DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE',   7,  12/
      DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW',   7,  -9/
C
      DATA IXMIND(  13)/ -11/
      DATA IXMAXD(  13)/  11/
      DATA IXDELD(  13)/  22/
      DATA ISTARD(  13)/ 101/
      DATA NUMCOO(  13)/   6/
C
C     DEFINE CHARACTER    540--UPPER CASE XI
C
      DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE',  -7,  12/
      DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW',   7,  12/
      DATA IOPERA( 109),IX( 109),IY( 109)/'MOVE',  -3,   2/
      DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW',   3,   2/
      DATA IOPERA( 111),IX( 111),IY( 111)/'MOVE',  -7,  -9/
      DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW',   7,  -9/
C
      DATA IXMIND(  14)/  -9/
      DATA IXMAXD(  14)/   9/
      DATA IXDELD(  14)/  18/
      DATA ISTARD(  14)/ 107/
      DATA NUMCOO(  14)/   6/
C
C     DEFINE CHARACTER    541--UPPER CASE OMIC
C
      DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE',  -2,  12/
      DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW',  -4,  11/
      DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW',  -6,   9/
      DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW',  -7,   7/
      DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW',  -8,   4/
      DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW',  -8,  -1/
      DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW',  -7,  -4/
      DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW',  -6,  -6/
      DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW',  -4,  -8/
      DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW',  -2,  -9/
      DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW',   2,  -9/
      DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW',   4,  -8/
      DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW',   6,  -6/
      DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW',   7,  -4/
      DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW',   8,  -1/
      DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW',   8,   4/
      DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW',   7,   7/
      DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW',   6,   9/
      DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW',   4,  11/
      DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW',   2,  12/
      DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW',  -2,  12/
C
      DATA IXMIND(  15)/ -11/
      DATA IXMAXD(  15)/  11/
      DATA IXDELD(  15)/  22/
      DATA ISTARD(  15)/ 113/
      DATA NUMCOO(  15)/  21/
C
C     DEFINE CHARACTER    542--UPPER CASE PI
C
      DATA IOPERA( 134),IX( 134),IY( 134)/'MOVE',  -7,  12/
      DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW',  -7,  -9/
      DATA IOPERA( 136),IX( 136),IY( 136)/'MOVE',   7,  12/
      DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW',   7,  -9/
      DATA IOPERA( 138),IX( 138),IY( 138)/'MOVE',  -7,  12/
      DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW',   7,  12/
C
      DATA IXMIND(  16)/ -11/
      DATA IXMAXD(  16)/  11/
      DATA IXDELD(  16)/  22/
      DATA ISTARD(  16)/ 134/
      DATA NUMCOO(  16)/   6/
C
C     DEFINE CHARACTER    543--UPPER CASE RHO
C
      DATA IOPERA( 140),IX( 140),IY( 140)/'MOVE',  -7,  12/
      DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW',  -7,  -9/
      DATA IOPERA( 142),IX( 142),IY( 142)/'MOVE',  -7,  12/
      DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW',   2,  12/
      DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW',   5,  11/
      DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW',   6,  10/
      DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW',   7,   8/
      DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW',   7,   5/
      DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW',   6,   3/
      DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW',   5,   2/
      DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW',   2,   1/
      DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW',  -7,   1/
C
      DATA IXMIND(  17)/ -11/
      DATA IXMAXD(  17)/  10/
      DATA IXDELD(  17)/  21/
      DATA ISTARD(  17)/ 140/
      DATA NUMCOO(  17)/  12/
C
C     DEFINE CHARACTER    544--UPPER CASE SIGM
C
      DATA IOPERA( 152),IX( 152),IY( 152)/'MOVE',  -7,  12/
      DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW',   0,   2/
      DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW',  -7,  -9/
      DATA IOPERA( 155),IX( 155),IY( 155)/'MOVE',  -7,  12/
      DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW',   7,  12/
      DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE',  -7,  -9/
      DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW',   7,  -9/
C
      DATA IXMIND(  18)/  -9/
      DATA IXMAXD(  18)/   9/
      DATA IXDELD(  18)/  18/
      DATA ISTARD(  18)/ 152/
      DATA NUMCOO(  18)/   7/
C
C     DEFINE CHARACTER    545--UPPER CASE TAU
C
      DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE',   0,  12/
      DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW',   0,  -9/
      DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE',  -7,  12/
      DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW',   7,  12/
C
      DATA IXMIND(  19)/  -8/
      DATA IXMAXD(  19)/   8/
      DATA IXDELD(  19)/  16/
      DATA ISTARD(  19)/ 159/
      DATA NUMCOO(  19)/   4/
C
C     DEFINE CHARACTER    546--UPPER CASE UPSI
C
      DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE',  -7,   7/
      DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW',  -7,   9/
      DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW',  -6,  11/
      DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW',  -5,  12/
      DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW',  -3,  12/
      DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW',  -2,  11/
      DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW',  -1,   9/
      DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW',   0,   5/
      DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW',   0,  -9/
      DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE',   7,   7/
      DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW',   7,   9/
      DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW',   6,  11/
      DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW',   5,  12/
      DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW',   3,  12/
      DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW',   2,  11/
      DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW',   1,   9/
      DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW',   0,   5/
C
      DATA IXMIND(  20)/  -9/
      DATA IXMAXD(  20)/   9/
      DATA IXDELD(  20)/  18/
      DATA ISTARD(  20)/ 163/
      DATA NUMCOO(  20)/  17/
C
C     DEFINE CHARACTER    547--UPPER CASE PHI
C
      DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE',   0,  12/
      DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW',   0,  -9/
      DATA IOPERA( 182),IX( 182),IY( 182)/'MOVE',  -2,   7/
      DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW',  -5,   6/
      DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW',  -6,   5/
      DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW',  -7,   3/
      DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW',  -7,   0/
      DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW',  -6,  -2/
      DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW',  -5,  -3/
      DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW',  -2,  -4/
      DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW',   2,  -4/
      DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW',   5,  -3/
      DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW',   6,  -2/
      DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW',   7,   0/
      DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW',   7,   3/
      DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW',   6,   5/
      DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW',   5,   6/
      DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW',   2,   7/
      DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW',  -2,   7/
C
      DATA IXMIND(  21)/ -10/
      DATA IXMAXD(  21)/  10/
      DATA IXDELD(  21)/  20/
      DATA ISTARD(  21)/ 180/
      DATA NUMCOO(  21)/  19/
C
C     DEFINE CHARACTER    548--UPPER CASE CHI
C
      DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE',  -7,  12/
      DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW',   7,  -9/
      DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE',  -7,  -9/
      DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW',   7,  12/
C
      DATA IXMIND(  22)/ -10/
      DATA IXMAXD(  22)/  10/
      DATA IXDELD(  22)/  20/
      DATA ISTARD(  22)/ 199/
      DATA NUMCOO(  22)/   4/
C
C     DEFINE CHARACTER    549--UPPER CASE PSI
C
      DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE',   0,  12/
      DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW',   0,  -9/
      DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE',  -9,   6/
      DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW',  -8,   6/
      DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW',  -7,   5/
      DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW',  -6,   1/
      DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW',  -5,  -1/
      DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW',  -4,  -2/
      DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW',  -1,  -3/
      DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW',   1,  -3/
      DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW',   4,  -2/
      DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW',   5,  -1/
      DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW',   6,   1/
      DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW',   7,   5/
      DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW',   8,   6/
      DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW',   9,   6/
C
      DATA IXMIND(  23)/ -11/
      DATA IXMAXD(  23)/  11/
      DATA IXDELD(  23)/  22/
      DATA ISTARD(  23)/ 203/
      DATA NUMCOO(  23)/  16/
C
C     DEFINE CHARACTER    550--UPPER CASE OMEG
C
      DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE',  -7,  -9/
      DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW',  -3,  -9/
      DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW',  -6,  -2/
      DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW',  -7,   2/
      DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW',  -7,   6/
      DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW',  -6,   9/
      DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW',  -4,  11/
      DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW',  -1,  12/
      DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW',   1,  12/
      DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW',   4,  11/
      DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW',   6,   9/
      DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW',   7,   6/
      DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW',   7,   2/
      DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW',   6,  -2/
      DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW',   3,  -9/
      DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW',   7,  -9/
C
      DATA IXMIND(  24)/ -10/
      DATA IXMAXD(  24)/  10/
      DATA IXDELD(  24)/  20/
      DATA ISTARD(  24)/ 219/
      DATA NUMCOO(  24)/  16/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      NUMCO=1
      ISTART=1
      ISTOP=1
      NC=1
C
C               ******************************************
C               ******************************************
C               **  TREAT THE ROMAN SIMPLEX UPPER CASE  **
C               **  HERSHEY CHARACTER SET CASE          **
C               ******************************************
C               ******************************************
C
C
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPGSU--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICHAR2
   52 FORMAT('ICHAR2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR
   59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************************************
C               **************************************************
C               **  STEP 1--                                    **
C               **  SEARCH FOR THE INPUT CHARACTER(S).          **
C               **  MAP THE CHARACTER(S) INTO A NUMERIC VALUE.  **
C               **************************************************
C               **************************************************
C
      CALL DPCHGR(ICHAR2,ICHARN,IBUGD2,IFOUND)
      IF(IFOUND.EQ.'NO')GOTO9000
      GOTO1000
C
C               **************************************
C               **************************************
C               **  STEP 2--                        **
C               **  EXTRACT THE COORDINATES         **
C               **  FOR THIS PARTICULAR CHARACTER.  **
C               **************************************
C               **************************************
C
 1000 CONTINUE
      ISTART=ISTARD(ICHARN)
      NC=NUMCOO(ICHARN)
      ISTOP=ISTART+NC-1
      J=0
      DO1100I=ISTART,ISTOP
      J=J+1
      IOP(J)=IOPERA(I)
      X(J)=IX(I)
      Y(J)=IY(I)
 1100 CONTINUE
      NUMCO=J
      IXMINS=IXMIND(ICHARN)
      IXMAXS=IXMAXD(ICHARN)
      IXDELS=IXDELD(ICHARN)
C
      GOTO9000
C
C               *****************
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPGSU--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR
 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICHAR2,ICHARN
 9013 FORMAT('ICHAR2,ICHARN = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO
 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019
      DO9015I=1,NUMCO
      WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I)
 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS
 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHADE(IHARG,IARGT,ARG,NUMARG,DEFHAD,
     1HARDDE,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE HARDCOPY DELAY FACTOR.
C              THE SPECIFIED HARDCOPY DELAY FACTOR WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE HARDDE.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --ARG    (A  FLOATING POINT VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --DEFHAD (A  FLOATING POINT VARIABLE)
C     OUTPUT ARGUMENTS--HARDDE (A  FLOATING POINT VARIABLE)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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 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
      IF(NUMARG.EQ.0)GOTO1199
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DELA')GOTO1110
      GOTO1199
C
 1110 CONTINUE
      IF(IHARG(NUMARG).EQ.'DELA')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 DPHADE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR HARDCOPY DELAY ',
     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 ANALYST WISHES TO DOUBLE  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      THE DELAY TIME WHILE HARDCOPIES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      ARE BEING MADE, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1130)
 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)
 1131 FORMAT('      HARDCOPY DELAY 2 ')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1150 CONTINUE
      HOLD=DEFHAD
      GOTO1180
C
 1160 CONTINUE
      HOLD=ARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
CCCCC HARDDE=HOLD
      AIMAX=2**(NUMBPC*NUMCPW-2)
      IF(HOLD.LT.AIMAX)HARDDE=HOLD
      IF(HOLD.GE.AIMAX)HARDDE=AIMAX
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)HARDDE
 1181 FORMAT('THE HARDCOPY DELAY FACTOR HAS JUST BEEN SET TO ',
     1E15.7)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPHANW(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,IANS,
     1IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--ACCESS THE ON-LINE NIST/SEMATECH ENGINEERING
C              STATISTICS HANDBOOK VIA
C              A WEB BROWSER (DEFAULTS TO NETSCAPE).
C
C              THIS COMMAND TAKES THE FOLLOWING FORMS:
C                  WEB HANDBOOK       - GO TO MAIN HANDBOOK HOME PAGE
C                  WEB HANDBOOK  - GO TO A PARTICULAR PAGE
C                                       IN THE ON-LINE HANDBOOK BASED
C                                       ON MATCHING  TO A
C                                       FILE (HANDBOOK.TEX)
C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
C                     --IWIDTH (AN INTEGER VARIABLE)
C                     --IBROWS  (A CHARACTER VARIABLE THAT IDENTIFIES
C                               THE BROWSER TO USE)
C                     --IHBURL  (A CHARACTER VARIABLE THAT IDENTIFIES
C                               THE WEB URL OF THE DATAPLOT HOME PAGE)
C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--99/3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
      CHARACTER*4 IANS
      CHARACTER*1 IQUOTE
      CHARACTER*40 ILINE1
      CHARACTER*40 ILINE2
      CHARACTER*500 ICALL
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 ISUBN0
      CHARACTER*4 IERRFI
      CHARACTER*4 IENDFI
      CHARACTER*4 IREWIN
C
      CHARACTER*4 IWORD1
      CHARACTER*4 IWORD2
      CHARACTER*4 IWORD3
      CHARACTER*4 IWORD4
      CHARACTER*4 IWOR12
C
      CHARACTER*4 IBRWFL
C
      CHARACTER*1 ICHAR1
C
      CHARACTER*4 ICTEST
      CHARACTER*4 ICTES2
C
      CHARACTER*4 IZ1
      CHARACTER*4 IZ2
      CHARACTER*4 IZ3
      CHARACTER*4 IZ4
C
      CHARACTER*40 ISTRIN
      CHARACTER*4 IERRO2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHO.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOF2.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPHA'
      ISUBN2='NW  '
      NUMLIN=(-999)
      NUMSEC=(-999)
      ISECNA=(-999)
C
      NUMAR2=(-999)
C
      IWORD1='    '
      IWORD2='    '
      IWORD3='    '
      IWORD4='    '
      IWOR12='    '
C
      ICTEST='    '
      ICTES2='    '
C
      ILINE1='                              '
      ILINE2='                              '
      ICALL=' '
C
      IZ1='    '
      IZ2='    '
      IZ3='    '
      IZ4='    '
C
      JCHAR1=(-999)
      JSEC=(-999)
      JSECP1=(-999)
C
      ISKIP=(-999)
      ISTART=(-999)
      ISTOP=(-999)
      I2=(-999)
C
      ISTRIN='                              '
C
      NUMWHF=(-999)
      ILOC2=(-999)
      ILOC3=(-999)
      ILOC4=(-999)
C
      ILOC2P=(-999)
      ILOC3P=(-999)
      ILOC4P=(-999)
C
      CALL DPCONA(39,IQUOTE)
C
      IFOUND='YES'
      IERROR='NO'
C
      ISHIFT=1
      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGS2,IERROR)
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HANW')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHANW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR
   53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IWIDTH
   54 FORMAT('IWIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH)
   55 FORMAT('IANS(.) = ',120A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)IBROWS(1:80)
   86 FORMAT('IBROWS = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,88)IHBURL(1:80)
   88 FORMAT('IHBURL = ',A80)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IF(
     1       (IHOST1.EQ.'SUN') .OR.
     1       (IHOST1.EQ.'CRAY' .AND. IOPSY1.EQ.'UNIX') .OR.
     1       (IHOST1.EQ.'CONV') .OR.
     1       (IHOST1.EQ.'SGI ') .OR.
     1       (IHOST1.EQ.'HP-9') .OR.
     1       (IHOST1.EQ.'AIX ') .OR.
     1       (IHOST1.EQ.'LINU') .OR.
     1       (IOPSY1.EQ.'UNIX'))GOTO199
      IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')GOTO199
      IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'LAHE')GOTO199
  100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** FROM DPHANW--WEB HANDBOOK CURRENTLY ONLY ',
     1'SUPPORTED ON UNIX OR PC WINDOWS PLATFORMS.')
  199 CONTINUE
C
C               **********************************************************
C               **  STEP 21--                                           **
C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORDS WEB HANDBOOK**
C               **********************************************************
C
      IPASS=0
 1000 CONTINUE
      IPASS=IPASS+1
C
      ISTEPN='21'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.LE.1)THEN
         IF(NUMARG.GE.1)IWORD1=IHARG(1)
         IF(NUMARG.GE.1)IWOR12=IHARG2(1)
         IF(NUMARG.GE.2)IWORD2=IHARG(2)
         IF(NUMARG.GE.3)IWORD3=IHARG(3)
         IF(NUMARG.GE.4)IWORD4=IHARG(4)
         NUMAR2=NUMARG
      ENDIF
C
      IF(NUMAR2.LE.0)THEN
         NUMAR2=1
         IWORD1='HOME'
         IWOR12='PAGE'
      ENDIF
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5099
C
C             ********************************************************
C             **  STEP 22--                                         **
C             **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
C             ********************************************************
C
      ISTEPN='22'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICHAR1=IWORD1(1:1)
C
C               *******************************
C               **  STEP 32--                **
C               **  COPY OVER FILE VARIABLES **
C               *******************************
C
      ISTEPN='32'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
 3210 CONTINUE
      IOUNIT=IHHBNU
      IFILE=IHHBNA
      ISTAT=IHHBST
      IFORM=IHHBFO
      IACCES=IHHBAC
      IPROT=IHHBPR
      ICURST=IHHBCS
      ISUBN0='HANW'
      IERRFI='NO'
C
 3291 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HANW')GOTO3299
      WRITE(ICOUT,3293)IOUNIT
 3293 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3294)IFILE
 3294 FORMAT('IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
 3295 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3296)IBUGS2,ISUBRO,ISUBN0,IERRFI
 3296 FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 3299 CONTINUE
C
C               ****************************************
C               **  STEP 33--                         **
C               **  CHECK TO SEE IF HELP FILE EXISTS  **
C               ****************************************
C
      ISTEPN='33'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ISTAT.EQ.'NONE')GOTO3300
      GOTO3390
 3300 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3311)
 3311 FORMAT('***** ERROR IN DPHANW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3312)
 3312 FORMAT('      THE DESIRED HANDBOOK INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3313)
 3313 FORMAT('      CANNOT BE GIVEN BECAUSE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3314)
 3314 FORMAT('      THE REQUIRED SYSTEM MASS STORAGE FILE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3315)
 3315 FORMAT('      WHICH STORES SUCH HANDBOOK INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3316)
 3316 FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3317)ISTAT,IHHBST
 3317 FORMAT('ISTAT,IHELST = ',A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3318)IFILE(1:50)
 3318 FORMAT('IFILE(1:50) = ',A50)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 3390 CONTINUE
C
C               *********************
C               **  STEP 34--      **
C               **  OPEN THE FILE  **
C               *********************
C
      ISTEPN='34'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     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 52.1--                                     **
C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
C               **  OF THE FILE.                                    **
C               ******************************************************
C
 5099 CONTINUE
      ISTEPN='52.1'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICALL=' '
      DO5100I=MAXBRO,1,-1
         NUMBRO=I
         IF(IBROWS(I:I).NE.' ')GOTO5109
 5100 CONTINUE
 5109 CONTINUE
      IF(NUMBRO.GT.0)THEN
        ICALL(1:NUMBRO)=IBROWS(1:NUMBRO)
        NCSTR=NUMBRO+1
        ICALL(NCSTR:NCSTR)=' '
      ELSE
        ICALL(1:9)='netscape '
        NCSTR=9
      ENDIF
C
      IBRWFL='NETS'
      IF(NUMBRO.GE.8)THEN
        DO5125I=1,NUMBRO-7
          IF(IBROWS(I:I+7).EQ.'IEXPLORE' .OR.
     1       IBROWS(I:I+7).EQ.'iexplore')THEN
             IBRWFL='IEXP'
             GOTO5128
          ENDIF
 5125   CONTINUE
 5128   CONTINUE
      ENDIF
C
      NUMURL=NCHURL
C
C  IF "SET NETSCAPE OLD" COMMAND WAS ENTERED, THEN USE 
C  -remote NETSCAPE OPTION.  THIS ONLY APPLIES TO UNIX PLATFORMS.
C
      IF(IHOST1.EQ.'IBM-')THEN
        IF(IBRWFL.EQ.'NETS')THEN
          NCSTR=NCSTR+1
          NCSTR2=NCSTR+3
          ICALL(NCSTR:NCSTR2)=' -h '
          NCSTR=NCSTR2
        ENDIF
        GOTO5129 
      ENDIF
      IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+8
        ICALL(NCSTR:NCSTR2)=' -remote '
        NCSTR=NCSTR2+1
        ICALL(NCSTR:NCSTR)=IQUOTE
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+7
        ICALL(NCSTR:NCSTR2)='openURL('
        NCSTR=NCSTR2
      ENDIF
C
 5129 CONTINUE
      IF(NUMURL.GT.0)THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+NUMURL-1
        ICALL(NCSTR:NCSTR2)=IHBURL(1:NUMURL)
        N1URL=NCSTR
        N2URL=NCSTR2
        NCSTR=NCSTR2
      ELSE
        NCSTR=NCSTR+1
        N1URL=NCSTR
        NCSTR2=NCSTR+6
        ICALL(NCSTR:NCSTR2)='http://'
        NCSTR=NCSTR2
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+16
        ICALL(NCSTR:NCSTR2)='www.itl.nist.gov/'
        NCSTR=NCSTR2
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+19
        ICALL(NCSTR:NCSTR2)='itl/div898/handbook/'
        NCSTR=NCSTR2
        N2URL=NCSTR2
      ENDIF
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5300
      DO5200I=1,100000
      ILINE1=' '
      ILINE2=' '
      I2=I
C
C               *****************************************
C               **  STEP 52.2--                        **
C               **  READ IN SUCCEEDING LINES UNTIL     **
C               **  GET A HIT BASED ON THE FIRST WORD  **
C               **  OF THE COMMAND.                    **
C               *****************************************
C
      ISTEPN='52.2'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      READ(IOUNIT,5202,END=5280)ILINE1,ILINE2
 5202 FORMAT(A40,A40)
      IF(ILINE1(1:4).EQ.'    ')GOTO5200
C
      ICTEST=' '
      ICTES2=' '
      NBLANK=41
      DO5203II=1,40
        IF(ILINE1(II:II).EQ.' '.OR.ILINE1(II:II).EQ.'-')THEN
          NBLANK=II
          GOTO5204
        ENDIF
 5203 CONTINUE
 5204 CONTINUE
      IF(NBLANK.LE.5)THEN
        ICTEST(1:NBLANK-1)=ILINE1(1:NBLANK-1)
      ELSE
        NLAST=NBLANK
        IF(NLAST.GT.9)NLAST=9
        ICTEST(1:4)=ILINE1(1:4)
        ICTES2(1:NLAST-5)=ILINE1(5:NLAST-1)
      ENDIF
C
      IF(ICTEST.NE.IWORD1)GOTO5200
CCCC  IF(ICTES2.NE.' '.AND.ICTES2.NE.IWOR12)GOTO5200
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5206)I,ILINE1(1:40)
 5206    FORMAT('I,ILINE1(1:40)=',I8,2X,A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5207)I,ILINE2(1:40)
 5207    FORMAT('I,ILINE2(1:40)=',I8,2X,A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2
 5208    FORMAT('NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2 = ',
     1   I8,I8,2X,A4,2X,A4,2X,A4,2x,A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***********************************************
C               **  STEP 52.3--                              **
C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
C               ***********************************************
C
CCCCC FIX A FEW SMALL BUGS IN THIS SECTION.  AUGUST 1999.
CCCCC 1) TREAT HYPHEN AS SPACE
CCCCC 2) VALUES OF ILOCP2, ILOCP3, ILOCP4 IF LESS THAN 3 CHARACTERS
C
      ISTEPN='52.3'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NSTRT=NBLANK
      NUMWHF=1
      IZ1(1:4)=ICTEST(1:4)
      IZ2=' '
      IZ3=' '
      IZ4=' '
C
C  LOOK FOR SECOND WORD
C
      DO5212II=NBLANK,40
        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
          NSTRT=II
          DO5214J=II,40
            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
              NLAST=J-1
              GOTO5219
            ENDIF
 5214     CONTINUE
        ENDIF
 5212 CONTINUE
      NLAST=0
 5219 CONTINUE
      IF(NLAST.LE.0)GOTO5270
      NUMWHF=2
      NCH=NLAST-NSTRT+1
      IF(NCH.GT.4)NCH=4
      IZ2(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
      NBLANK=NLAST+1
      IF(NBLANK.GE.40)GOTO5270
C
C  LOOK FOR THIRD WORD
C
      DO5222II=NBLANK,40
        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
          NSTRT=II
          DO5224J=II,40
            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
              NLAST=J-1
              GOTO5229
            ENDIF
 5224     CONTINUE
        ENDIF
 5222 CONTINUE
      NLAST=0
 5229 CONTINUE
      IF(NLAST.LE.0)GOTO5270
      NUMWHF=3
      NCH=NLAST-NSTRT+1
      IF(NCH.GT.4)NCH=4
      IZ3(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
      NBLANK=NLAST+1
      IF(NBLANK.GE.40)GOTO5270
C
C  LOOK FOR FOURTH WORD
C
      DO5232II=NBLANK,40
        IF(ILINE1(II:II).NE.' '.AND.ILINE1(II:II).NE.'-')THEN
          NSTRT=II
          DO5234J=II,40
            IF(ILINE1(J:J).EQ.' '.OR.ILINE1(J:J).EQ.'-')THEN
              NLAST=J-1
              GOTO5239
            ENDIF
 5234     CONTINUE
        ENDIF
 5232 CONTINUE
      NLAST=0
 5239 CONTINUE
      IF(NLAST.LE.0)GOTO5270
      NUMWHF=4
      NCH=NLAST-NSTRT+1
      IF(NCH.GT.4)NCH=4
      IZ4(1:NCH)=ILINE1(NSTRT:NSTRT+NCH-1)
      NBLANK=NLAST+1
      IF(NBLANK.GE.40)GOTO5270
C
 5270 CONTINUE
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
         WRITE(ICOUT,5241)
 5241    FORMAT('***** FROM 1731 IN MIDDLE OF DPHANW--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5242)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4
 5242    FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4 = ',
     1   A4,2X,A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5243)ILINE1(1:40)
 5243    FORMAT('ILINE1(1:40) = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5244)IZ1,IZ2,IZ3,IZ4
 5244    FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5245)ISTRIN
 5245    FORMAT('ISTRIN = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5246)NUMARG,NUMAR2,NUMWHF
 5246    FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5247)ILOC2,ILOC3,ILOC4
 5247    FORMAT('ILOC2,ILOC3,ILOC4 = ',3I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5248)ILOC2P,ILOC3P,ILOC4P
 5248    FORMAT('ILOC2P,ILOC3P,ILOC4P = ',3I8)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
      IF(NUMAR2.NE.NUMWHF)GOTO5200
C
 5252 CONTINUE
      IF(NUMAR2.LE.1)GOTO5290
      IF(NUMWHF.LE.1)GOTO5290
C
      IF(IZ2.EQ.IWORD2)GOTO5253
C
      GOTO5200
C
 5253 CONTINUE
      IF(NUMAR2.LE.2)GOTO5290
      IF(NUMWHF.LE.2)GOTO5290
C
      IF(IZ3.EQ.IWORD3)GOTO5254
C
      GOTO5200
C
 5254 CONTINUE
      IF(NUMAR2.LE.3)GOTO5290
      IF(NUMWHF.LE.3)GOTO5290
C
      IF(IZ4.EQ.IWORD4)GOTO5290
C
 5200 CONTINUE
C
 5280 CONTINUE
      IERROR='YES'
CCCCC ONLY ONE PASS MADE.  FEBRUARY 2000.
CCCCC IF(IPASS.GE.2)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5281)
 5281    FORMAT('***** ERROR IN DPHANW--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5282)
 5282    FORMAT('      THE SPECIFIED COMMAND FOR WHICH')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5283)
 5283    FORMAT('      WEB HANDBOOK WAS DESIRED WAS NOT FOUND')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5284)
 5284    FORMAT('      IN THE HELP FILE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5285)
 5285    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5286)(IANS(I),I=1,IWIDTH)
 5286    FORMAT('      ',120A1)
         CALL DPWRST('XXX','BUG ')
CCCCC ENDIF
      GOTO6100
C
 5290 CONTINUE
C
C               ****************************************************
C               **  STEP 53--                                     **
C               **  IF HAVE A HIT ON ALL WORDS,                   **
C               **  THEN USE DPSYS2 TO MAKE A SYSTEM CALL         **
C               **  TO INIATE NETSCAPE.                           **
C               **  CHECK IF URL BEGINS WITH http (A FEW SPECIAL  **
C               **  CASES GO TO NON-DATAPLOT WEB PAGE             **
C               ****************************************************
C
 5300 CONTINUE
      ISTEPN='53'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+12
        ICALL(NCSTR:NCSTR2)='homepage.html'
        NCSTR=NCSTR2
        GOTO5349
      ENDIF
C
      DO5330J=40,1,-1
        NTEMP=J
        IF(ILINE2(J:J).NE.' ')GOTO5339
 5330 CONTINUE
 5339 CONTINUE
      IF(NTEMP.LE.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5351)
        CALL DPWRST('XXX','BUG ')
        ILINE2(1:13)='homepage.html'
        NTEMP=13
      ENDIF
 5351 FORMAT('***** WARNING: NO MATCH FOUND, DEFAULT TO HANDBOOK ',
     1'HOME PAGE.')
C
C  ABSOLUTE URL ADDRESS FOUND
C
      IF(ILINE2(1:5).EQ.'http:')THEN
        ICALL(N1URL:N2URL)=' '
        NCSTR=N1URL-1
      ENDIF
C
      NCSTR=NCSTR+1
      NCSTR2=NCSTR+NTEMP-1
      ICALL(NCSTR:NCSTR2)=ILINE2(1:NTEMP)
      NCSTR=NCSTR2
 5349 CONTINUE
      IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        ICALL(NCSTR:NCSTR)=')'
        NCSTR=NCSTR+1
        ICALL(NCSTR:NCSTR)=IQUOTE
      ENDIF
      IF(IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+1
        ICALL(NCSTR:NCSTR2)=' &'
        NCSTR=NCSTR2
      ENDIF
C
      IF(INETSW.EQ.'NEW')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5411)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IF(IHOST1.NE.'IBM-')THEN
          WRITE(ICOUT,5412)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5413)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5414)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5415)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
 5411 FORMAT('*****NOTE: IT MAY TAKE THE BROWSER A FEW MOMENTS TO ',
     1      'START UP.')
 5412 FORMAT('     IF YOU ARE USING THE NETSCAPE BROWSER, YOU CAN ',
     1       'SPEED UP SUBSEQUENT')
 5413 FORMAT('     USE OF WEB HANDBOOK BY ENTERING THE FOLLOWING ',
     1       'DATAPLOT COMMAND')
 5414 FORMAT('     (LEAVE THE BROWSER OPEN):')
 5415 FORMAT('         SET NETSCAPE OLD')
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HANW')THEN
         WRITE(ICOUT,5441)NCSTR
 5441    FORMAT('AT CALL DPSYS2, NCSTR = ',I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5443)ICALL(1:100)
 5443    FORMAT('ICALL(1:100)=',A100)
         CALL DPWRST('XXX','BUG ')
      ENDIF
CCCCC CLOSE FILE BEFORE CALL DPSYS2.  SEEMS TO CAUSE A PROBLEM ON
CCCCC RS-6000.  FEBRUARY 2000.
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
      IF(IERRFI.EQ.'YES')GOTO9000
      CALL DPSYS2(ICALL,NCSTR,ISUBRO,IERROR)
      GOTO9000
C
C               **************************************
C               **  STEP 61--                       **
C               **  CLOSE           THE HELP FILE.  **
C               **************************************
C
 6100 CONTINUE
C
      ISTEPN='61'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO6199
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
      IF(IERRFI.EQ.'YES')GOTO9000
 6199 CONTINUE
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HANW')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHANW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR,IERRO2
 9012 FORMAT('IBUGS2,ISUBRO,IERROR,IERRO2 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IBUGS2,IFOUND,IERROR
 9028 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IOUNIT
 9031 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IFILE
 9032 FORMAT('IFILE  = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)ISTAT
 9033 FORMAT('ISTAT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IFORM
 9034 FORMAT('IFORM  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IACCES
 9035 FORMAT('IACCES = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)IPROT
 9036 FORMAT('IPROT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)ICURST
 9037 FORMAT('ICURST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)IENDFI
 9038 FORMAT('IENDFI = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IREWIN
 9039 FORMAT('IREWIN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)ISUBN0
 9041 FORMAT('ISUBN0 = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)IERRFI
 9042 FORMAT('IERRFI = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)IWORD1,IWORD2,ICHAR1
 9043 FORMAT('IWORD1,IWORD2,ICHAR1 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9060)ILINE1(1:40),ICTEST,IWORD1,IWOR12
 9060 FORMAT('ILINE1(1:40),ICTEST,IWORD1,IWOR12=',A30,2X,A4,A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA
 9061 FORMAT('NUMSEC,NUMLIN,ISECNA = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9062)NUMARG,NUMAR2
 9062 FORMAT('NUMARG,NUMAR2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9063)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12
 9063 FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9064)ILINE1(1:40)
 9064 FORMAT('ILINE1(1:40) = ',A40)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4
 9065 FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9066)ISTRIN
 9066 FORMAT('ISTRIN = ',A40)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9067)NUMWHF
 9067 FORMAT('NUMWHF = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9068)ILOC2,ILOC3,ILOC4
 9068 FORMAT('ILOC2,ILOC3,ILOC4 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P
 9069 FORMAT('ILOC2P,ILOC3P,ILOC4P = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9071)ICHAR1
 9071 FORMAT('ICHAR1 = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9077)I2
 9077 FORMAT('I2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9079)IBUGS2,ISUBRO,IERROR
 9079 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9093)IERROR,IERRO2,IPASS
 9093 FORMAT('IERROR,IERRO2,IPASS = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9095)IWORD1,IWOR12,IWORD2
 9095 FORMAT('IWORD1,IWOR12,IWORD2 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9096)IWORD3,IWORD4
 9096 FORMAT('IWORD3,IWORD4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9097)IBROWS(1:80)
 9097 FORMAT('IBROWS = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9097)IHBURL(1:80)
 9098 FORMAT('IHBURL = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9099)ICALL(1:256)
 9099 FORMAT('ICALL = ',A256)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHAPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1ICOPSW,NUMCOP,IFOUND,IERROR)
C
C     PURPOSE--TURN ON THE LOCAL HARDCOPY DEVICE
C              AND DEFINE THE NUMBER OF DESIRED COPIES.
C              THE POWER STATUS OF THE LOCAL HARDCOPY WILL BE
C              PLACED IN THE CHARACTER VARIABLE ICOPSW (ON/OFF).
C              THE NUMBER OF COPIES TO BE MADE WILL BE
C              PLACED IN THE INTEGER VARIABLE NUMCOP.
C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
C                     --IHARG2 (A CHARACTER VECTOR)
C                     --IARGT  (A CHARACTER VECTOR)
C                     --IARG   (A CHARACTER VECTOR)
C                     --NUMARG
C     OUTPUT ARGUMENTS--ICOPSW (A CHARACTER VECTOR
C                              WHICH CONTAINS THE
C                              POWER (ON/OFF) FOR THE LOCAL HARDCOPY UNIT.
C                     --NUMCOP (AN INTEGER VARIABLE
C                              WHICH CONTAINS THE NUMBER OF COPIES
C                              TO BE MADE.
C                     --IFOUND ('YES' OR 'NO')
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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--OCTOBER   1978.
C     UPDATED         --NOVEMBER  1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
      CHARACTER*4 ICOPSW
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IDEV
      CHARACTER*4 IHOLD1
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      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
      IDEV='HARD'
C
 1150 CONTINUE
      IF(NUMARG.LE.0)GOTO1160
C
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ON')GOTO1160
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFF')GOTO1161
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO')GOTO1160
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEFA')GOTO1161
      IF(NUMARG.EQ.1.AND.IARGT(1).EQ.'NUMB')GOTO1162
C
      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'ON'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1163
      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'OFF'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1161
      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'AUTO'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1163
      IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'DEFA'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1161
C
      GOTO1199
C
 1160 CONTINUE
      IHOLD1='ON'
      IHOLD2=1
      GOTO1180
C
 1161 CONTINUE
      IHOLD1='OFF'
      IHOLD2=-1
      GOTO1180
C
 1162 CONTINUE
      IHOLD1='ON'
      IHOLD2=IARG(1)
      GOTO1180
C
 1163 CONTINUE
      IHOLD1='ON'
      IHOLD2=IARG(2)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      ICOPSW=IHOLD1
      NUMCOP=IHOLD2
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)IHOLD1
 1181 FORMAT('THE LOCAL HARDCOPY HAS JUST BEEN TURNED ',A4)
      CALL DPWRST('XXX','BUG ')
      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.EQ.1)WRITE(ICOUT,1182)NUMCOP
 1182 FORMAT('    (WITH ',I3,' HARDCOPY   PER PLOT)')
      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.GE.2)WRITE(ICOUT,1183)NUMCOP
 1183 FORMAT('    (WITH ',I3,' HARDCOPIES PER PLOT)')
      IF(ICOPSW.EQ.'ON'.AND.NUMCOP.GE.2)CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPHAZA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1IANGLU,MAXNPP,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1IX1TSV,IX2TSV,IY1TSV,IY2TSV,
     1IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
     1IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--FORM A NORMAL/LOGNORMAL/EXPONENTIAL/WEIBULL/GUMBEL HAZARD PLOT
C     EXAMPLE--LOGNORMAL HAZARD PLOT Y
C              LOGNORMAL HAZARD PLOT Y TAG
C     NOTE--THIS COMMAND CAN HAVE 1 OR 2 ARGUMENTS.
C           ARGUMENT 1 IS THE RESPONSE VARIABLE
C           IF THE HAZARD PLOT COMMAND HAS ONLY
C           1 ARGUMENT, THEN IT IS ASSUMED THAT ALL
C           OF THE DATA IS TO BE INCLUDED
C           (THAT IS, NO CENSORING).
C     NOTE--SOMETIMES THIS COMMAND HAS 2 ARGUMENTS--
C           ARGUMENT 1 IS THE RESPONSE VARIABLE
C           ARGUMENT 2 IS THE CENSOR-TAG VARIABLE
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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/5
C     ORIGINAL VERSION--MAY       1998. THIS IMPLEMENTATION NOT WORKING
C     UPDATED         --JANUARY   2006. CORRECT IMPLEMENTATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IX2TSC
      CHARACTER*4 IY1TSC
      CHARACTER*4 IY2TSC
C
      CHARACTER*4 IX1TSV
      CHARACTER*4 IX2TSV
      CHARACTER*4 IY1TSV
      CHARACTER*4 IY2TSV
C
      CHARACTER*4 IX1ZFM
      CHARACTER*4 IX2ZFM
      CHARACTER*4 IY1ZFM
      CHARACTER*4 IY2ZFM
C
      CHARACTER*4 IX1ZSV
      CHARACTER*4 IX2ZSV
      CHARACTER*4 IY1ZSV
      CHARACTER*4 IY2ZSV
C
      CHARACTER*4 IANGLU
      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 IH
      CHARACTER*4 IH2
      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'
      INCLUDE 'DPCOHO.INC'
      DIMENSION Y1(MAXOBV)
      DIMENSION Y2(MAXOBV)
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZI.INC'
      DIMENSION YS(MAXOBV)
      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
      EQUIVALENCE (GARBAG(IGARB3),YS(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='DPHA'
      ISUBN2='ZA  '
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
      SIGMA=(-999.0)
      AMU=(-999.0)
      SDSIGM=(-999.0)
      SDAMU=(-999.0)
      BPT1=(-999.0)
      BPT5=(-999.0)
      B1=(-999.0)
      B5=(-999.0)
      B10=(-999.0)
      B20=(-999.0)
      B50=(-999.0)
      B80=(-999.0)
      B90=(-999.0)
      B95=(-999.0)
      B99=(-999.0)
      B995=(-999.0)
      B999=(-999.0)
C
CCCCC THE FOLLOWING 4 LINES WERE ADDED   APRIL 1992
      ICUTMX=NUMBPW
      IF(IHOST1.EQ.'CDC '.OR.IHOST1.EQ.'CYBE')ICUTMX=48
      IF(IHOST1.EQ.'205 ')ICUTMX=48
      CUTOFF=2**(ICUTMX-3)
C
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF DPHAZA--')
        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)IANGLU,IBUGG2,IBUGG3,IBUGQ
   54   FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ = ',
     1         A4,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 ')
        WRITE(ICOUT,61)IX1TSC,IX2TSC,IY1TSC,IY2TSC
   61   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,62)IX1TSV,IX2TSV,IY1TSV,IY2TSV
   62   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***********************************
C               **  TREAT THE HAZARD  PLOT CASE  **
C               ***********************************
C
C               ***************************
C               **  STEP 11--            **
C               **  EXTRACT THE COMMAND  **
C               ***************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PLOT')GOTO1111
      GOTO9000
C
 1111 CONTINUE
      ILASTC=2
      IF(ICOM.EQ.'NORM')THEN
        ICASPL='NHAZ'
      ELSEIF(ICOM.EQ.'LOGN')THEN
        ICASPL='LHAZ'
      ELSEIF(ICOM.EQ.'EXPO')THEN
        ICASPL='EHAZ'
      ELSEIF(ICOM.EQ.'WEIB')THEN
        ICASPL='WHAZ'
      ELSEIF(ICOM.EQ.'GUMB')THEN
        ICASPL='GHAZ'
      ELSEIF(ICOM.EQ.'EXTR'.AND.IHARG(1).EQ.'VALU')THEN
        ICASPL='GHAZ'
        ILASTC=3
      ELSE
        GOTO9000
      ENDIF
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      IFOUND='YES'
C
C               *****************************************************
C               **  STEP 12--                                      **
C               **  CARRY OUT A GENERAL CHECK FOR THE              **
C               **  PROPER NUMBER OF INPUT ARGUMENTS               **
C               **  (IT SHOULD BE 1 OR 2).                         **
C               *****************************************************
C
      ISTEPN='12'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               *****************************************
C               **  STEP 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.'HAZA')
     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.'HAZA')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 1 OR 2).                         **
C               *****************************************************
C
      ISTEPN='14'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMVAR=ILOCQ-1
      IF(NUMVAR.GT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1411)
 1411   FORMAT('***** ERROR IN HAZARD PLOT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1412)
 1412   FORMAT('      FOR A HAZARD PLOT, THE NUMBER OF VARIABLES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1419)
 1419   FORMAT('      MUST BE EITHER 1 OR 2;  SUCH WAS NOT THE ',
     1         'CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1422)NUMVAR
 1422   FORMAT('      THE SPECIFIED NUMBER 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)THEN
          WRITE(ICOUT,1424)(IANS(I),I=1,MIN(80,IWIDTH))
 1424     FORMAT('      ',80A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
      ENDIF
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.'HAZA')
     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
      IF(NUMVAR.LE.1)GOTO1590
      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 HAZARD PLOT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1562)ICTAR1,ICTAR2,IHRIX1,IHRIX2
 1562 FORMAT('      THE SPECIFIED ',A4,A4,' ARGUMENT (',A4,A4,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1565)
 1565 FORMAT('      WAS FOUND IN THE INTERNAL NAME LIST, BUT AS ',
     1       '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 HAZARD PLOT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1572)ICTAR1,ICTAR2,IHRIX1,IHRIX2
 1572 FORMAT('      THE SPECIFIED ',A4,A4,' ARGUMENT (',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)THEN
        WRITE(ICOUT,1579)(IANS(I),I=1,MIN(80,IWIDTH))
 1579   FORMAT(80A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      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.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMVAR.EQ.2.AND.(NIRIG1.NE.NIRIG2))THEN
        WRITE(ICOUT,2111)
 2111   FORMAT('***** ERROR IN HAZARD PLOT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2113)
 2113   FORMAT('      THE NUMBER OF OBSERVATIONS IN VARIABLES 1 AND 2')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2114)
 2114   FORMAT('      MUST BE THE SAME;  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)THEN
          WRITE(ICOUT,2121)(IANS(I),I=1,MIN(100,IWIDTH))
 2121     FORMAT('      ',100A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
      ENDIF
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.'HAZA')
     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.LT.MINN2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3251)
 3251   FORMAT('***** ERROR IN HAZARD PLOT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3252)
 3252   FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
     1         '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 HAZARD PLOT 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)THEN
          WRITE(ICOUT,3260)(IANS(I),I=1,MIN(80,IWIDTH))
 3260     FORMAT('      ',80A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               **********************************************
C               **  STEP 33--                               **
C               **  FORM THE SUBSETTED VARIABLES            **
C               **       Y1(.)                              **
C               **       Y2(.)                              **
C               **  CONTAINING                              **
C               **       THE RESPONSE VARIABLE              **
C               **       THE CENSOR-TAG VARIABLE            **
C               **  RESPECTIVELY.                           **
C               **********************************************
C
      ISTEPN='33'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      J=0
      IMAX=NIRIG1
      IF(NQ.LT.NIRIG1)IMAX=NQ
C
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')THEN
        WRITE(ICOUT,780)N,NIRIG1,NQ,IMAX
  780   FORMAT(' N,NIRIG1,NQ,IMAX = ',4I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      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
      IF(NUMVAR.LE.1)THEN
        Y2(J)=1.0
      ELSE
        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)
      ENDIF
C
 3300 CONTINUE
      NS=J
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')THEN
        WRITE(ICOUT,776)J,NS
  776   FORMAT('J,NS = ',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *********************************************
C               **  STEP 34--                              **
C               **  CHECK TO MAKE SURE THAT THE            **
C               **  COMBINATION OF CENSORING AND           **
C               **  SUBSETTING DOES NOT RESULT IN          **
C               **  TOO FEW DATA POINTS RESULTING          **
C               **  (AT LEAST 2)                           **
C               **  WITH WHICH TO FORM A NORMAL PLOT.      **
C               *********************************************
C
      ISTEPN='34'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICOUNT=0
      IF(NS.LE.2)THEN
        ICOUNT=NS
      ELSE
        DO3400I=1,NS
          IF(Y2(I).LE.-0.0001.OR.Y2(I).GE.0.0001)ICOUNT=ICOUNT+1
 3400   CONTINUE
      ENDIF
C
      IF(ICOUNT.LE.MINN2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3451)
 3451   FORMAT('***** ERROR IN HAZARD PLOT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3452)
 3452   FORMAT('      AFTER THE SPECIFIED CENSORING AND SUBSETTING ',
     1         'HAS BEEN PERFORMED,')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3454)IHRI11,IHRI12
 3454   FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING FROM ',
     1         'VARIABLE ',A4,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3455)
 3455   FORMAT('      (FOR WHICH A HAZARD PLOT 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)ICOUNT
 3458   FORMAT('      SUCH WAS NOT THE CASE HERE (ICOUNT = ',I8,')')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3459)
 3459   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
        CALL DPWRST('XXX','BUG ')
        IF(IWIDTH.GE.1)THEN
          WRITE(ICOUT,3460)(IANS(I),I=1,MIN(80,IWIDTH))
 3460     FORMAT('      ',80A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
      ENDIF
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.'HAZA')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL DPHAZ2(Y1,Y2,NS,ICASPL,MAXN,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1IX1TSV,IX2TSV,IY1TSV,IY2TSV,
     1IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
     1IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
     1SIGMA,AMU,SDSIGM,SDAMU,
     1BPT1,BPT5,B1,B5,B10,B20,B50,B80,B90,B95,B99,B995,B999,
     1Y,X,D,NPLOTP,NPLOTV,
     1YS,
     1IBUGG3,ISUBRO,IERROR)
C
C               ***************************************
C               **  STEP 51--                        **
C               **  UPDATE INTERNAL DATAPLOT TABLES  **
C               ***************************************
C
      ISTEPN='51'
      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      DO5100IPASS=1,17
      IF(IPASS.EQ.1)IH='SIGM'
      IF(IPASS.EQ.1)IH2='A   '
      IF(IPASS.EQ.2)IH='MU'
      IF(IPASS.EQ.2)IH2='    '
      IF(IPASS.EQ.3)IH='SDSI'
      IF(IPASS.EQ.3)IH2='GMA '
      IF(IPASS.EQ.4)IH='SDET'
      IF(IPASS.EQ.4)IH2='A   '
C
      IF(IPASS.EQ.5)IH='BPT1'
      IF(IPASS.EQ.5)IH2='    '
      IF(IPASS.EQ.6)IH='BPT5'
      IF(IPASS.EQ.6)IH2='    '
      IF(IPASS.EQ.7)IH='B1  '
      IF(IPASS.EQ.7)IH2='    '
      IF(IPASS.EQ.8)IH='B5  '
      IF(IPASS.EQ.8)IH2='    '
      IF(IPASS.EQ.9)IH='B10 '
      IF(IPASS.EQ.9)IH2='    '
      IF(IPASS.EQ.10)IH='B20 '
      IF(IPASS.EQ.10)IH2='    '
      IF(IPASS.EQ.11)IH='B50 '
      IF(IPASS.EQ.11)IH2='    '
      IF(IPASS.EQ.12)IH='B80 '
      IF(IPASS.EQ.12)IH2='    '
      IF(IPASS.EQ.13)IH='B90 '
      IF(IPASS.EQ.13)IH2='    '
      IF(IPASS.EQ.14)IH='B95 '
      IF(IPASS.EQ.14)IH2='    '
      IF(IPASS.EQ.15)IH='B99 '
      IF(IPASS.EQ.15)IH2='    '
      IF(IPASS.EQ.16)IH='B995'
      IF(IPASS.EQ.16)IH2='    '
      IF(IPASS.EQ.17)IH='B999'
      IF(IPASS.EQ.17)IH2='    '
      DO5150I=1,NUMNAM
      I2=I
      IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO5180
 5150 CONTINUE
      IF(NUMNAM.LT.MAXNAM)GOTO5170
      WRITE(ICOUT,5151)
 5151 FORMAT('***** ERROR IN DPHAZA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5152)
 5152 FORMAT('      THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5153)MAXNAM
 5153 FORMAT('      NAMES MUST BE AT MOST ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5154)
 5154 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5155)
 5155 FORMAT('      THE MAXIMUM ALLOWABLE NUMBER OF NAMES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5156)
 5156 FORMAT('      HAS JUST EXCEEDED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5157)
 5157 FORMAT('      SUGGESTED ACTION--ENTER     STAT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5158)
 5158 FORMAT('      TO DETERMINE THE IMPORTANT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5159)
 5159 FORMAT('      (VERSUS UNIMPORTANT) VARIABLES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5160)
 5160 FORMAT('      AND PARAMETERS, AND THEN REUSE SOME')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5161)
 5161 FORMAT('      OF THE NAMES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5162)
 5162 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,5163)(IANS(I),I=1,IWIDTH)
 5163 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 5170 CONTINUE
      NUMNAM=NUMNAM+1
      ILOC=NUMNAM
      IHNAME(ILOC)=IH
      IHNAM2(ILOC)=IH2
      IUSE(ILOC)='P'
      IF(IPASS.EQ.1)VALUE(ILOC)=SIGMA
      IF(IPASS.EQ.2)VALUE(ILOC)=AMU
      IF(IPASS.EQ.3)VALUE(ILOC)=SDSIGM
      IF(IPASS.EQ.4)VALUE(ILOC)=SDAMU
      IF(IPASS.EQ.5)VALUE(ILOC)=BPT1
      IF(IPASS.EQ.6)VALUE(ILOC)=BPT5
      IF(IPASS.EQ.7)VALUE(ILOC)=B1
      IF(IPASS.EQ.8)VALUE(ILOC)=B5
      IF(IPASS.EQ.9)VALUE(ILOC)=B10
      IF(IPASS.EQ.10)VALUE(ILOC)=B20
      IF(IPASS.EQ.11)VALUE(ILOC)=B50
      IF(IPASS.EQ.12)VALUE(ILOC)=B80
      IF(IPASS.EQ.13)VALUE(ILOC)=B90
      IF(IPASS.EQ.14)VALUE(ILOC)=B95
      IF(IPASS.EQ.15)VALUE(ILOC)=B99
      IF(IPASS.EQ.16)VALUE(ILOC)=B995
      IF(IPASS.EQ.17)VALUE(ILOC)=B999
      VAL=VALUE(ILOC)
      IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5
      IF(VAL.GT.CUTOFF)IVAL=CUTOFF
      IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF)
      IVALUE(ILOC)=IVAL
      GOTO5100
C
 5180 CONTINUE
      IF(IPASS.EQ.1)VALUE(I2)=SIGMA
      IF(IPASS.EQ.2)VALUE(I2)=AMU
      IF(IPASS.EQ.3)VALUE(I2)=SDSIGM
      IF(IPASS.EQ.4)VALUE(I2)=SDAMU
      IF(IPASS.EQ.5)VALUE(I2)=BPT1
      IF(IPASS.EQ.6)VALUE(I2)=BPT5
      IF(IPASS.EQ.7)VALUE(I2)=B1
      IF(IPASS.EQ.8)VALUE(I2)=B5
      IF(IPASS.EQ.9)VALUE(I2)=B10
      IF(IPASS.EQ.10)VALUE(I2)=B20
      IF(IPASS.EQ.11)VALUE(I2)=B50
      IF(IPASS.EQ.12)VALUE(I2)=B80
      IF(IPASS.EQ.13)VALUE(I2)=B90
      IF(IPASS.EQ.14)VALUE(I2)=B95
      IF(IPASS.EQ.15)VALUE(I2)=B99
      IF(IPASS.EQ.16)VALUE(I2)=B995
      IF(IPASS.EQ.17)VALUE(I2)=B999
      VAL=VALUE(I2)
      IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=VAL+0.5
      IF(VAL.GT.CUTOFF)IVAL=CUTOFF
      IF(VAL.LT.(-CUTOFF))IVAL=(-CUTOFF)
      IVALUE(I2)=IVAL
      GOTO5100
C
 5100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG2.EQ.'ON'.AND.ISUBRO.EQ.'HAZA')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPHAZA--')
        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 = ',
     1         I8,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.GT.0)THEN
          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
        ENDIF
        WRITE(ICOUT,9031)ICOUNT
 9031   FORMAT('ICOUNT = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9041)IX1TSC,IX2TSC,IY1TSC,IY2TSC
 9041   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9042)IX1TSV,IX2TSV,IY1TSV,IY2TSV
 9042   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9043)SIGMA,AMU,SDSIGM,SDAMU
 9043   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7)
        CALL DPWRST('XXX','BUG ')
        DO9050I=1,NIRIG1
          WRITE(ICOUT,9051)I,Y1(I),Y2(I),ISUB(I)
 9051     FORMAT('I,Y1(I),Y2(I),ISUB(I) = ',I8,2E15.7,I8)
          CALL DPWRST('XXX','BUG ')
 9050   CONTINUE
        WRITE(ICOUT,9061)IHRI11,IHRI12
 9061   FORMAT('IHRI11,IHRI12 = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9062)IHRI21,IHRI22
 9062   FORMAT('IHRI21,IHRI22 = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPHAZ2(Y,TAGC,N,ICASPL,MAXN,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1IX1TSV,IX2TSV,IY1TSV,IY2TSV,
     1IX1ZFM,IX2ZFM,IY1ZFM,IY2ZFM,
     1IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
     1SIGMA,AMU,SDSIGM,SDAMU,
     1BPT1,BPT5,B1,B5,B10,B20,B50,B80,B90,B95,B99,B995,B999,
     1Y2,X2,D2,N2,NPLOTV,
     1YS,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE
C              A HAZARD PLOT.
C              THE PLOT WILL CONSIST OF 6 COMPONENTS--
C                  1) THE RAW DATA
C                  2) THE FITTED LINE
C                  3) THE HORIZONTAL 50% LINE
C                  4) THE VERTICAL   50% LINE
C                  5) 95% CONFIDENCE LIMITS
C                  6) 99% CONFIDENCE LIMITS
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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/5
C     ORIGINAL VERSION--MAY       1998. THIS IMPLEMENTATION REALLY NOT
C                                       CORRECT
C     UPDATED         --JANUARY   2006. INITIAL CORRECT IMPLEMENTATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IWRITE
c
      CHARACTER*4 IX1TSC
      CHARACTER*4 IX2TSC
      CHARACTER*4 IY1TSC
      CHARACTER*4 IY2TSC
C
      CHARACTER*4 IX1TSV
      CHARACTER*4 IX2TSV
      CHARACTER*4 IY1TSV
      CHARACTER*4 IY2TSV
C
      CHARACTER*4 IX1ZFM
      CHARACTER*4 IX2ZFM
      CHARACTER*4 IY1ZFM
      CHARACTER*4 IY2ZFM
C
      CHARACTER*4 IX1ZSV
      CHARACTER*4 IX2ZSV
      CHARACTER*4 IY1ZSV
      CHARACTER*4 IY2ZSV
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DOUBLE PRECISION DTEMP
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DEPS
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION TAGC(*)
C
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D2(*)
C
      DIMENSION YS(*)
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
      DATA DEPS /1.0D-16/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPHA'
      ISUBN2='Z2  '
C
      IERROR='NO'
C
      AN=N
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF DPHAZ2--')
        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,N,NPLOTV
   53   FORMAT('ICASPL,MAXN,N,NPLOTV = ',A4,2X,I8,I8,I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GT.0)THEN
          DO60I=1,N
            WRITE(ICOUT,61)I,Y(I),TAGC(I)
   61       FORMAT('I,Y(I),TAGC(I) = ',I8,2E12.5)
            CALL DPWRST('XXX','BUG ')
   60     CONTINUE
        ENDIF
        WRITE(ICOUT,71)IX1TSC,IX2TSC,IY1TSC,IY2TSC
   71   FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,72)IX1TSV,IX2TSV,IY1TSV,IY2TSV
   72   FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,73)SIGMA,AMU,SDSIGM,SDAMU
   73   FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,74)BPT1,BPT5,B1,B5
   74   FORMAT('BPT1,BPT5,B1,B5 = ',4E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,75)B10,B20,B50,B80,B90
   75   FORMAT(' B10,B20,B50,B80,B90 = ',5E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,76)B95,B99,B995,B999
   76   FORMAT('B95,B99,B995,B999 = ',4E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1.1'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LT.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1111)
 1111   FORMAT('***** ERROR IN HAZARD PLOT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1112)
 1112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 3.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1114)N
 1114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      HOLD=Y(1)
      DO1130I=1,N
        IF(Y(I).NE.HOLD)GOTO1139
 1130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)
 1131 FORMAT('***** ERROR IN HAZARD PLOT--')
      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
      DO1140I=1,N
        IF(TAGC(I).NE.0.0)GOTO1149
 1140 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN HAZARD PLOT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      ALL INPUT TAG VARIABLE ELEMENTS ARE ',
     1       'IDENTICALLY EQUAL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      TO 0.0;  THUS THERE ARE NO RESPONSE VARIABLE ',
     1       'VALUES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1145)
 1145 FORMAT('      REMAINING UPON WHICH TO PERFORM A HAZARD ANALYSIS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1149 CONTINUE
C
C   THE FOLLOWING IS THE BASIC ALGORITHM FOR THE HAZARD PLOT:
C
C    1) SORT THE FAILURE AND CENSORING TIMES AND ASSIGN A REVERSE
C       RANK, K, TO EACH VALUE
C    2) COMPUTE THE CUMULATIVE HAZARD FOR EACH FAILURE TIME
C       A) HAZARD = 100/K
C       B) CUMULTIVE HAZARD = SUM OF HAZARDS UP TO AND INCLUDING
C          THE CURRENT FAILURE
C    3) PLOT TIME ON THE VERTICAL AXIS AND THE CUMULATIVE HAZARD
C       (OR SOME FUNCTION OF THE CUMULATIVE HAZARD) ON THE HORIZONTAL
C       AXIS
C    4) DEPENDING ON THE SPECIFIC DISTRIBUTION, DETERMINE WHETHER
C       THE TIME AND CUMULATIVE HAZARD SCALES ARE LINEAR OR LOG
C
C   THE FOLLOWING ARE THE PLOT COORDINATES FOR THE SPECIFIC DISTRIBUTIONS:
C
C   1) EXPONENTIAL:
C      A) TIME IS PLOTTED ON A LINEAR SCALE
C      B) CUMULATIVE HAZARD IS PLOTTED ON A LINEAR SCALE
C
C   2) WEIBULL
C      A) TIME IS PLOTTED ON A LOG SCALE
C      B) CUMULATIVE HAZARD IS PLOTTED ON A LOG SCALE
C
C   3) EXTREME VALUE (GUMBEL)
C      A) TIME IS PLOTTED ON A LINEAR SCALE
C      B) CUMULATIVE HAZARD IS PLOTTED ON A LOG SCALE
C
C   4) NORMAL
C      A) TIME IS PLOTTED ON A LINEAR SCALE
C      B) NORPPF(1 - EXP(-H)) IS PLOTTED ON A LINEAR SCALE
C         WHERE H IS THE CUMULATIVE HAZARD VALUE
C
C   5) LOGNORMAL
C      A) TIME IS PLOTTED ON A LOG SCALE
C      B) NORPPF(1 - EXP(-H)) IS PLOTTED ON A LINEAR SCALE
C         WHERE H IS THE CUMULATIVE HAZARD VALUE
C
C               ***********************************************
C               **  STEP 21--                                **
C               **  SORT THE DATA AND CARRY ALONG THE TAG    **
C               ***********************************************
C
      ISTEPN='2.1'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL SORTC(Y,TAGC,N,YS,TAGC)
      IWRITE='OFF'
C
C               ***********************************************
C               **  STEP 22--                                **
C               **  COMPUTE CUMULATIVE HAZARD                **
C               ***********************************************
C
      ISTEPN='2.2'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL CUMHAZ(YS,TAGC,N,IWRITE,Y,IBUGG3,IERROR)
C
C               ***********************************************
C               **  STEP 23--                                **
C               **  COMPUTE PLOT COORDINATES FOR VARIOUS     **
C               **  DISTRIBUTIONS                            **
C               ***********************************************
C
      ISTEPN='2.3'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HAZ2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C
      IX1TSV=IX1TSC
      IX2TSV=IX2TSC
      IY1TSV=IY1TSC
      IY2TSV=IY2TSC
C
      IX1ZSV=IX1ZFM
      IX2ZSV=IX2ZFM
      IY1ZSV=IY1ZFM
      IY2ZSV=IY2ZFM
C
C  Y   = CUMULATIVE HAZARD
C  YS  = SORTED FAILURE/CENSOR TIMES
C
      IF(ICASPL.EQ.'EHAZ')THEN
        J=0
        DO2310I=1,N
          IF(ABS(TAGC(I)).GE.0.5)THEN
            J=J+1
            X2(J)=Y(I)
            Y2(J)=YS(I)
            D2(J)=1.0
          ENDIF
 2310   CONTINUE
        IX1TSC='LINE'
        IX2TSC='LINE'
        IY1TSC='LINE'
        IY2TSC='LINE'
      ELSEIF(ICASPL.EQ.'WHAZ')THEN
        J=0
        DO2320I=1,N
          IF(ABS(TAGC(I)).GE.0.5)THEN
            J=J+1
            X2(J)=Y(I)
            Y2(J)=YS(I)
            D2(J)=1.0
          ENDIF
 2320   CONTINUE
        IX1TSC='LOG '
        IX2TSC='LOG '
        IX1ZFM='REAL'
        IX2ZFM='REAL'
        IY1TSC='LOG '
        IY2TSC='LOG '
        IY1ZFM='REAL'
        IY2ZFM='REAL'
      ELSEIF(ICASPL.EQ.'GHAZ')THEN
        J=0
        DO2330I=1,N
          IF(ABS(TAGC(I)).GE.0.5)THEN
            J=J+1
            X2(J)=Y(I)
            Y2(J)=YS(I)
            D2(J)=1.0
          ENDIF
 2330   CONTINUE
        IX1TSC='LOG '
        IX2TSC='LOG '
        IX1ZFM='REAL'
        IX2ZFM='REAL'
        IY1TSC='LINE'
        IY2TSC='LINE'
      ELSEIF(ICASPL.EQ.'NHAZ')THEN
        J=0
        DO2340I=1,N
          IF(ABS(TAGC(I)).GE.0.5)THEN
            J=J+1
CCCCC       DTEMP=DBLE(Y(I))
CCCCC       DTEMP=1.0D0 - DEXP(-DTEMP)
CCCCC       IF(DTEMP.LE.DEPS)THEN
CCCCC         DTEMP=DEPS
CCCCC       ELSEIF(DTEMP.GT.1.0D0-DEPS)THEN
CCCCC         DTEMP=1.0D0-DEPS
CCCCC       ENDIF
CCCCC       CALL NODPPF(DTEMP,DPDF)
CCCCC       X2(J)=REAL(DPDF)
            X2(J)=Y(I)
            Y2(J)=YS(I)
            D2(J)=1.0
          ENDIF
 2340   CONTINUE
CCCCC   IX1TSC='LOG '
CCCCC   IX2TSC='LOG '
        IX1TSC='NORM'
        IX2TSC='NORM'
        IX1ZFM='REAL'
        IX2ZFM='REAL'
        IY1TSC='LINE'
        IY2TSC='LINE'
      ELSEIF(ICASPL.EQ.'LHAZ')THEN
        J=0
        DO2350I=1,N
          IF(ABS(TAGC(I)).GE.0.5)THEN
            J=J+1
            DTEMP=DBLE(Y(I))
            DTEMP=1.0D0 - DEXP(-DTEMP)
            IF(DTEMP.LE.DEPS)THEN
              DTEMP=DEPS
            ELSEIF(DTEMP.GT.1.0D0-DEPS)THEN
              DTEMP=1.0D0-DEPS
            ENDIF
            CALL NODPPF(DTEMP,DPDF)
            X2(J)=REAL(DPDF)
            Y2(J)=YS(I)
            D2(J)=1.0
          ENDIF
 2350   CONTINUE
CCCCC   IX1TSC='LOG '
CCCCC   IX2TSC='LOG '
        IX1TSC='NORM'
        IX2TSC='NORM'
        IX1ZFM='REAL'
        IX2ZFM='REAL'
        IY1TSC='LOG '
        IY2TSC='LOG '
        IY1ZFM='REAL'
        IY2ZFM='REAL'
      ENDIF
      N2=J
      NPLOTV=3
C
      ISUBRO='DPHA'
      DO3000I=1,N2
       IF(IY1TSC.EQ.'LOG ')Y2(I)=LOG(Y2(I))
       IF(IX1TSC.EQ.'LOG ')X2(I)=LOG(X2(I))
 3000 CONTINUE 
      CALL LINFIT(Y2,X2,N2,
     1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE,
     1ISUBRO,IBUGG3,IERROR)
      SIGMA=BETA
      AMU=ALPHA
      SDSIGM=SDBETA
      SDAMU=SDALPH
C
      NTEMP=N2
      N2=N2+1
      X2(N2)=X2(1)
      Y2(N2)=ALPHA+BETA*X2(1)
      D2(N2)=2.0
C
      N2=N2+1
      X2(N2)=X2(NTEMP)
      Y2(N2)=ALPHA+BETA*X2(NTEMP)
      D2(N2)=2.0
C
      DO3100I=1,N2
       IF(IY1TSC.EQ.'LOG ')Y2(I)=EXP(Y2(I))
       IF(IX1TSC.EQ.'LOG ')X2(I)=EXP(X2(I))
 3100 CONTINUE 
C
C               ************************************************
C               **  STEP 35--                                 **
C               **  FORM ESTIMATES FOR                        **
C               **     BPT1= .1%   POINT OF BEST-FIT DIST.    **
C               **     BPT5= .5%   POINT OF BEST-FIT DIST.    **
C               **     B1  =  1%   POINT OF BEST-FIT DIST.    **
C               **     B5  =  5%   POINT OF BEST-FIT DIST.    **
C               **     B10 = 10%   POINT OF BEST-FIT DIST.    **
C               **     B20 = 20%   POINT OF BEST-FIT DIST.    **
C               **     B50 = 50%   POINT OF BEST-FIT DIST.    **
C               **     B80 = 80%   POINT OF BEST-FIT DIST.    **
C               **     B90 = 90%   POINT OF BEST-FIT DIST.    **
C               **     B95 = 95%   POINT OF BEST-FIT DIST.    **
C               **     B99 = 99%   POINT OF BEST-FIT DIST.    **
C               **     B995= 99.5% POINT OF BEST-FIT DIST.    **
C               **     B999= 99.9% POINT OF BEST-FIT DIST.    **
C               ************************************************
C
      IF(ICASPL.EQ.'NHAZ')THEN
        P=.001
        CALL NORPPF(P,XOUT)
        BPT1=AMU+XOUT*SIGMA
        P=.005
        CALL NORPPF(P,XOUT)
        BPT5=AMU+XOUT*SIGMA
        P=.01
        CALL NORPPF(P,XOUT)
        B1=AMU+XOUT*SIGMA
        P=.05
        CALL NORPPF(P,XOUT)
        B5=AMU+XOUT*SIGMA
        P=.10
        CALL NORPPF(P,XOUT)
        B10=AMU+XOUT*SIGMA
        P=.20
        CALL NORPPF(P,XOUT)
        B20=AMU+XOUT*SIGMA
        P=.50
        CALL NORPPF(P,XOUT)
        B50=AMU+XOUT*SIGMA
        P=.80
        CALL NORPPF(P,XOUT)
        B80=AMU+XOUT*SIGMA
        P=.90
        CALL NORPPF(P,XOUT)
        B90=AMU+XOUT*SIGMA
        P=.95
        CALL NORPPF(P,XOUT)
        B95=AMU+XOUT*SIGMA
        P=.99
        CALL NORPPF(P,XOUT)
        B99=AMU+XOUT*SIGMA
        P=.995
        CALL NORPPF(P,XOUT)
        B995=AMU+XOUT*SIGMA
        P=.999
        CALL NORPPF(P,XOUT)
        B999=AMU+XOUT*SIGMA
      ELSEIF(ICASPL.EQ.'EHAZ')THEN
        P=.001
        CALL EXPPPF(P,XOUT)
        BPT1=AMU+XOUT*SIGMA
        P=.005
        CALL EXPPPF(P,XOUT)
        BPT5=AMU+XOUT*SIGMA
        P=.01
        CALL EXPPPF(P,XOUT)
        B1=AMU+XOUT*SIGMA
        P=.05
        CALL EXPPPF(P,XOUT)
        B5=AMU+XOUT*SIGMA
        P=.10
        CALL EXPPPF(P,XOUT)
        B10=AMU+XOUT*SIGMA
        P=.20
        CALL EXPPPF(P,XOUT)
        B20=AMU+XOUT*SIGMA
        P=.50
        CALL EXPPPF(P,XOUT)
        B50=AMU+XOUT*SIGMA
        P=.80
        CALL EXPPPF(P,XOUT)
        B80=AMU+XOUT*SIGMA
        P=.90
        CALL EXPPPF(P,XOUT)
        B90=AMU+XOUT*SIGMA
        P=.95
        CALL EXPPPF(P,XOUT)
        B95=AMU+XOUT*SIGMA
        P=.99
        CALL EXPPPF(P,XOUT)
        B99=AMU+XOUT*SIGMA
        P=.995
        CALL EXPPPF(P,XOUT)
        B995=AMU+XOUT*SIGMA
        P=.999
        CALL EXPPPF(P,XOUT)
        B999=AMU+XOUT*SIGMA
CCCCC ELSEIF(ICASPL.EQ.'LHAZ')THEN
CCCCC   SD=1.0
CCCCC   P=.001
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   BPT1=AMU+XOUT*SIGMA
CCCCC   P=.005
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   BPT5=AMU+XOUT*SIGMA
CCCCC   P=.01
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B1=AMU+XOUT*SIGMA
CCCCC   P=.05
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B5=AMU+XOUT*SIGMA
CCCCC   P=.10
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B10=AMU+XOUT*SIGMA
CCCCC   P=.20
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B20=AMU+XOUT*SIGMA
CCCCC   P=.50
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B50=AMU+XOUT*SIGMA
CCCCC   P=.80
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B80=AMU+XOUT*SIGMA
CCCCC   P=.90
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B90=AMU+XOUT*SIGMA
CCCCC   P=.95
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B95=AMU+XOUT*SIGMA
CCCCC   P=.99
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B99=AMU+XOUT*SIGMA
CCCCC   P=.995
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B995=AMU+XOUT*SIGMA
CCCCC   P=.999
CCCCC   CALL LGNPPF(P,SD,XOUT)
CCCCC   B999=AMU+XOUT*SIGMA
CCCCC ELSEIF(ICASPL.EQ.'WHAZ')THEN
CCCCC   MINMAX=1
CCCCC   GAMMA=1.0
CCCCC   P=.001
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   BPT1=AMU+XOUT*SIGMA
CCCCC   P=.005
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   BPT5=AMU+XOUT*SIGMA
CCCCC   P=.01
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B1=AMU+XOUT*SIGMA
CCCCC   P=.05
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B5=AMU+XOUT*SIGMA
CCCCC   P=.10
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B10=AMU+XOUT*SIGMA
CCCCC   P=.20
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B20=AMU+XOUT*SIGMA
CCCCC   P=.50
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B50=AMU+XOUT*SIGMA
CCCCC   P=.80
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B80=AMU+XOUT*SIGMA
CCCCC   P=.90
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B90=AMU+XOUT*SIGMA
CCCCC   P=.95
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B95=AMU+XOUT*SIGMA
CCCCC   P=.99
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B99=AMU+XOUT*SIGMA
CCCCC   P=.995
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B995=AMU+XOUT*SIGMA
CCCCC   P=.999
CCCCC   CALL WEIPPF(P,GAMMA,MINMAX,XOUT)
CCCCC   B999=AMU+XOUT*SIGMA
      ELSEIF(ICASPL.EQ.'GHAZ')THEN
        MINMAX=1
        P=.001
        CALL EV1PPF(P,MINMAX,XOUT)
        BPT1=AMU+XOUT*SIGMA
        P=.005
        CALL EV1PPF(P,MINMAX,XOUT)
        BPT5=AMU+XOUT*SIGMA
        P=.01
        CALL EV1PPF(P,MINMAX,XOUT)
        B1=AMU+XOUT*SIGMA
        P=.05
        CALL EV1PPF(P,MINMAX,XOUT)
        B5=AMU+XOUT*SIGMA
        P=.10
        CALL EV1PPF(P,MINMAX,XOUT)
        B10=AMU+XOUT*SIGMA
        P=.20
        CALL EV1PPF(P,MINMAX,XOUT)
        B20=AMU+XOUT*SIGMA
        P=.50
        CALL EV1PPF(P,MINMAX,XOUT)
        B50=AMU+XOUT*SIGMA
        P=.80
        CALL EV1PPF(P,MINMAX,XOUT)
        B80=AMU+XOUT*SIGMA
        P=.90
        CALL EV1PPF(P,MINMAX,XOUT)
        B90=AMU+XOUT*SIGMA
        P=.95
        CALL EV1PPF(P,MINMAX,XOUT)
        B95=AMU+XOUT*SIGMA
        P=.99
        CALL EV1PPF(P,MINMAX,XOUT)
        B99=AMU+XOUT*SIGMA
        P=.995
        CALL EV1PPF(P,MINMAX,XOUT)
        B995=AMU+XOUT*SIGMA
        P=.999
        CALL EV1PPF(P,MINMAX,XOUT)
        B999=AMU+XOUT*SIGMA
      ENDIF
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 DPHAZ2--')
      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
      WRITE(ICOUT,9021)IX1TSC,IX2TSC,IY1TSC,IY2TSC
 9021 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IX1TSV,IX2TSV,IY1TSV,IY2TSV
 9022 FORMAT('IX1TSV,IX2TSV,IY1TSV,IY2TSV = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)SIGMA,AMU,SDSIGM,SDAMU
 9032 FORMAT('SIGMA,AMU,SDSIGM,SDAMU = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)BPT1,BPT5,B1,B5
 9034 FORMAT('BPT1,BPT5,B1,B5 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)B10,B20,B50,B80,B90
 9035 FORMAT(' B10,B20,B50,B80,B90 = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)B95,B99,B995,B999
 9036 FORMAT('B95,B99,B995,B999 = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)AMU
 9044 FORMAT('AMU = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHEIG(IHARG,IARGT,ARG,NUMARG,
     1PDEFHE,
     1PTEXHE,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE HEIGHT FOR TEXT CHARACTERS.
C              THE HEIGHT FOR TEXT CHARACTERS WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE PTEXHE.
C     NOTE--THE HEIGHT IS IN STANDARDIZED UNITS (0.0 TO 100.0).
C     NOTE--THE HEIGHT DOES NOT INCLUDE BETWEEN-LINE GAP.
C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
C                     --IARGT
C                     --ARG
C                     --NUMARG
C                     --PDEFHE
C                     --IBUGD2
C     OUTPUT ARGUMENTS--PTEXHE
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
      CHARACTER*4 IBUGD2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
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
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)PDEFHE
   53 FORMAT('PDEFHE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NUMARG
   54 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),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
   90 CONTINUE
C
C               *****************************
C               **  TREAT THE HEIGHT CASE  **
C               *****************************
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
C
      IF(NUMARG.GE.1.AND.IARGT(NUMARG).EQ.'NUMB')
     1GOTO1160
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN DPHEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR HEIGHT ',
     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 IT IS DESIRED THAT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HEIGHT OF 5')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      (WHERE THE VERTICAL SCREEN UNITS RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1128)
 1128 FORMAT('      FROM 0 TO 100, AND WHERE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1129)
 1129 FORMAT('      THE BETWEEN-LINE GAP IS NOT INCLUDED),')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1130)
 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)
 1131 FORMAT('           HEIGHT 5 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      PTEXHE=PDEFHE
      GOTO1180
C
 1160 CONTINUE
      PTEXHE=ARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE HEIGHT (FOR TEXT CHARACTERS)  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)PTEXHE
 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
      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)PTEXHE
 8111 FORMAT('THE CURRENT (TEXT) HEIGHT IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8112)PDEFHE
 8112 FORMAT('THE DEFAULT (TEXT) HEIGHT IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHEIG--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)PTEXHE
 9013 FORMAT('PTEXHE = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHELP(IHARG,IHARG2,NUMARG,IANS,IWIDTH,
CCCCC THE FOLLOWING 9 LINES WERE COMMENTED OUT NOVEMBER 1991
CCCCC1IHE1CO,IHE1AL,
CCCCC1IHE2CO,IHE2AL,
CCCCC1IHE3CO,IHE3AL,
CCCCC1IHE4CO,IHE4AL,
CCCCC1IHE5CO,IHE5AL,
CCCCC1IHE6CO,IHE6AL,
CCCCC1IHE7CO,IHE7AL,
CCCCC1IHE8CO,IHE8AL,
CCCCC1IHE9CO,IHE9AL,
     1IHELMX,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IBUGS2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--PRINT OUT BRIEF INSTRUCTIONAL INFORMATION
C              ABOUT A PARTICULAR COMMAND
C              AS CALLED FOR BY THE HELP COMMAND.
C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
C                     --IWIDTH (AN INTEGER VARIABLE)
C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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--DECEMBER  1977.
C     UPDATED         --NOVEMBER  1980.
C     UPDATED         --JUNE      1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --DECEMBER  1985.
C     UPDATED         --SEPTEMBER 1987.  MORE/PAUSE
C     UPDATED         --JANUARY   1989.  FIX TRUNCATION OF LONG LINES
C                                        UNDER CYBER NOS (ALAN)
C     UPDATED         --JULY      1989.  MORE/PAUSE IN THE SUBROUTINE DPMORE
C     UPDATED         --NOVEMBER  1989.  IERRO TO IERROR--CALL DPMORE
C     UPDATED         --JULY      1990.  ALLOW MORE... TO STOP LIST
C     UPDATED         --JULY      1990.  SPLIT HELP INTO 6 FILES
C     UPDATED         --AUGUST    1990.  EXPLICIT SETTING OF NUMLPR=0
C     UPDATED         --APRIL     1992.  IBUGHE/2 TO IBUGS2
C     UPDATED         --APRIL     1992.  COMMENT OUT 12 DEBUG STATEMENTS
C     UPDATED         --AUGUST    1994.  SEARCH SYNONYM FILE
C     UPDATED         --AUGUST    1994.  NUMWOR => NUMWHF
C     UPDATED         --DECEMBER  1994.  CORRECTIONS FOR SYNONYM FILE
C     UPDATED         --MARCH     1996.  UPDATE SECTIONS FOR MATR OPER
C     UPDATED         --APRIL     1997.  CONFLICT BETWEEN STATUS AND
C                                        STATISTIC PLOT
C     UPDATED         --NOVEMBER  1997.  CONFLICT BETWEEN:
C                                           INTERPOLATION - INTEGRAL
C                                           ROOTOGRAM     - ROOTS
C     UPDATED         --FEBRUARY  2003.  BUG FIX FOR LONGER ENTRIES
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IANS
C
CCCCC THE FOLLOWING 18 LINES WERE COMMENTED OUT NOVEMBER 1991
CCCCC CHARACTER*12 IHE1CO
CCCCC CHARACTER*4 IHE1AL
C
CCCCC CHARACTER*12 IHE2CO
CCCCC CHARACTER*4 IHE2AL
C
CCCCC CHARACTER*12 IHE3CO
CCCCC CHARACTER*4 IHE3AL
C
CCCCC CHARACTER*12 IHE4CO
CCCCC CHARACTER*4 IHE4AL
C
CCCCC CHARACTER*12 IHE5CO
CCCCC CHARACTER*4 IHE5AL
C
CCCCC CHARACTER*12 IHE6CO
CCCCC CHARACTER*4 IHE6AL
C
CCCCC CHARACTER*12 IHE7CO
CCCCC CHARACTER*4 IHE7AL
C
CCCCC CHARACTER*12 IHE8CO
CCCCC CHARACTER*4 IHE8AL
C
CCCCC CHARACTER*12 IHE9CO
CCCCC CHARACTER*4 IHE9AL
C
      CHARACTER*40 ICPREH
      CHARACTER*40 ICPOSH
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 ISUBN0
      CHARACTER*4 IERRFI
      CHARACTER*4 IENDFI
      CHARACTER*4 IREWIN
C
      CHARACTER*4 ITABID
CCCCC CHARACTER*4 ITABII
      CHARACTER*4 IWORD1
      CHARACTER*4 IWORD2
      CHARACTER*4 IWORD3
      CHARACTER*4 IWORD4
      CHARACTER*4 IWORD5
      CHARACTER*4 IWOR12
C
      CHARACTER*1 ICHAR1
C
      CHARACTER*4 ICTEST
C
CCCCC THE FOLLOWING 5 LINES WERE COMMENTED OUT   AUGUST 1994
CCCCC CHARACTER*4 IW1
CCCCC CHARACTER*4 IW2
CCCCC CHARACTER*4 IW3
CCCCC CHARACTER*4 IW4
CCCCC CHARACTER*4 IW5
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
CCCCC THE FOLLOWING LINE WAS FXED FEBRUARY 2003
CCCCC CHARACTER*30 ILIN30
      CHARACTER*40 ILIN30
C
      CHARACTER*4 IZ1
      CHARACTER*4 IZ2
      CHARACTER*4 IZ3
      CHARACTER*4 IZ4
CCCCC FEBRUARY 2003: ADD FOLLOWING LINE
      CHARACTER*4 IZ5
C
      CHARACTER*4 ICTEXT
C
CCCCC FEBRUARY 2003: FIX FOLLOWING LINE
CCCCC CHARACTER*30 ISTRIN
      CHARACTER*40 ISTRIN
C
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
      CHARACTER*4 IRESP
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
      CHARACTER*4 IERRO2
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
      CHARACTER*1 ICJUNK
      CHARACTER*80 ILINE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IANS(*)
C
      DIMENSION ITABID(100)
      DIMENSION ITABLN(100)
C
      DIMENSION ICTEXT(20)
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='DPHE'
      ISUBN2='LP  '
C
      NUMLIN=(-999)
      NUMSEC=(-999)
      ISECNA=(-999)
C
      NUMAR2=(-999)
C
      IWORD1='    '
      IWORD2='    '
      IWORD3='    '
      IWORD4='    '
      IWORD5='    '
      IWOR12='    '
C
      ICTEST='    '
C
CCCCC THE FOLLOWING 5 LINES WERE COMMENTED OUT AUGUST 1994
CCCCC IW1='    '
CCCCC IW2='    '
CCCCC IW3='    '
CCCCC IW4='    '
CCCCC IW5='    '
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
      ILIN30='                              '
C
      IZ1='    '
      IZ2='    '
      IZ3='    '
      IZ4='    '
      IZ5='    '
C
      JCHAR1=(-999)
      JSEC=(-999)
      JSECP1=(-999)
C
      ISKIP=(-999)
      ISTART=(-999)
      ISTOP=(-999)
      I2=(-999)
C
      ISTRIN='                              '
C
CCCCC THE FOLLOWING LINE (AND ALL OTHER LINES          AUGUST 1994
CCCCC IN THIS SUBROUTINE CONTAINING NUMWOR)            AUGUST 1994
CCCCC WAS CHANGED (NUMWOR =>NUMWHF)                    AUGUST 1994
CCCCC NUMWOR=(-999)
      NUMWHF=(-999)
C
      ILOC2=(-999)
      ILOC3=(-999)
      ILOC4=(-999)
      ILOC5=(-999)
C
      ILOC2P=(-999)
      ILOC3P=(-999)
      ILOC4P=(-999)
      ILOC5P=(-999)
C
C
      IFOUND='YES'
      IERROR='NO'
C
      ISUBN1='DPHE'
      ISUBN2='LP  '
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HELP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHELP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR
   53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IWIDTH
   54 FORMAT('IWIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH)
   55 FORMAT('IANS(.) = ',120A1)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 18 LINES WERE COMMENTED OUT NOVEMBER 1991
CCCCC WRITE(ICOUT,61)IHE1CO,IHE1AL
CCC61 FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,62)IHE2CO,IHE2AL
CCC62 FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,63)IHE3CO,IHE3AL
CCC63 FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,64)IHE4CO,IHE4AL
CCC64 FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,65)IHE5CO,IHE5AL
CCC65 FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,66)IHE6CO,IHE6AL
CCC66 FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,67)IHE7CO,IHE7AL
CCC67 FORMAT('IHE7CO,IHE7AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,68)IHE8CO,IHE8AL
CCC68 FORMAT('IHE8CO,IHE8AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,69)IHE9CO,IHE9AL
CCC69 FORMAT('IHE9CO,IHE9AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)NCPREH
   81 FORMAT('NCPREH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO84
      DO82I=1,NCPREH
      WRITE(ICOUT,83)I,ICPREH(I:I)
   83 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   82 CONTINUE
   84 CONTINUE
      WRITE(ICOUT,86)NCPOSH
   86 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO89
      DO87I=1,NCPOSH
      WRITE(ICOUT,88)I,ICPOSH(I:I)
   88 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   87 CONTINUE
   89 CONTINUE
   90 CONTINUE
C
C               **********************************************************
C               **  STEP 21--                                           **
C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORD   HELP.  **
C               **********************************************************
C
CCCCC THE FOLLOWING 3 LINES WERE ADDED       AUGUST 1994 (JJF)
CCCCC TO SEARCH A SYNONYM FILE (DPHE7F.TEX)  AUGUST 1994
      IPASS=0
 1000 CONTINUE
      IPASS=IPASS+1
C
      ISTEPN='21'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.LE.1)THEN
         IWORD1=IHARG(1)
         IWOR12=IHARG2(1)
         IWORD2=IHARG(2)
         IWORD3=IHARG(3)
         IWORD4=IHARG(4)
         IWORD5=IHARG(5)
         NUMAR2=NUMARG
      ENDIF
C
      IF(NUMAR2.LE.0)THEN
         NUMAR2=1
         IWORD1='OVER'
         IWOR12='VIEW'
      ENDIF
C
C               ********************************************************
C               **  STEP 22--                                         **
C               **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
C               ********************************************************
C
      ISTEPN='22'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICHAR1=IWORD1(1:1)
C
C               **************************************************
C               **  STEP 31--                                   **
C               **  BASED ON THE FIRST WORD OR                  **
C               **  THE FIRST CHARACTER OF THE FIRST WORD,      **
C               **  DETERMINE WHICH OF THE 6 HELP               **
C               **  FILES WILL BE USED.                         **
C               **************************************************
C
      JFILE=6
C
      IF(IWORD1.EQ.'OVER')GOTO3110
      IF(IWORD1.EQ.'GRAP')GOTO3110
      IF(IWORD1.EQ.'DIAG')GOTO3110
      IF(IWORD1.EQ.'ANAL')GOTO3110
      IF(IWORD1.EQ.'PLOT'.AND.IWORD2.EQ.'CONT')GOTO3110
      IF(IWORD1.EQ.'SUPP')GOTO3110
      IF(IWORD1.EQ.'OUTP')GOTO3110
      IF(IWORD1.EQ.'KEYW')GOTO3110
      IF(IWORD1.EQ.'FUNC')GOTO3110
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'FUNC')GOTO3110
      IF(IWORD1.EQ.'TRIG')GOTO3110
CCCCC THE FOLLOWING LINE WAS CHANGED     AUGUST 1994
CCCCC IF(IWORD1.EQ.'PROB')GOTO3110
      IF(IWORD1.EQ.'PROB'.AND.IWORD2.NE.'PLOT')GOTO3110
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUBC')GOTO3110
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB-')GOTO3110
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB ')GOTO3110
CCCCC APRIL 1997.  STAT CAN MEAN EITHER STATISTICS, STATUS, OR
CCCCC STATISTIC PLOT.  FOLLOWING LINE ONLY FOR STATISTICS.
CCCCC IF(IWORD1.EQ.'STAT')GOTO3110
      IF(IWORD1.EQ.'STAT')THEN
        IF(IWORD2.NE.'PLOT' .AND. IWOR12.NE.'US')GOTO3110
      ENDIF
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'OPER')GOTO3110
CCCCC MARCH 1996.  ADD FOLLOWING LINE.
      IF(IWORD1.EQ.'MATR'.AND.IWORD2.EQ.'OPER')GOTO3110
CCCCC MAY 2002: CHECK FOR CONFLICT WITH RANDOM NUMBER GENERATOR
CCCCC COMMAND.
CCCCC IF(IWORD1.EQ.'RAND')GOTO3110
      IF(IWORD1.EQ.'RAND'.AND.IWORD3.NE.'GENE')GOTO3110
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUBC')GOTO3110
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB-')GOTO3110
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB ')GOTO3110
      IF(IWORD1.EQ.'CAPI')GOTO3110
      IF(IWORD1.EQ.'CAPS')GOTO3110
      IF(IWORD1.EQ.'CAP ')GOTO3110
      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'CRIP')GOTO3110
      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'SET ')GOTO3110
      IF(IWORD1.EQ.'GREE')GOTO3110
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'SYMB')GOTO3110
      IF(IWORD1.EQ.'MISC')GOTO3110
      IF(IWORD1.EQ.'CHAR'.AND.IWORD2.EQ.'TYPE')GOTO3110
      IF(IWORD1.EQ.'LINE'.AND.IWORD2.EQ.'TYPE')GOTO3110
      IF(IWORD1.EQ.'COLO'.AND.IWORD2.EQ.'TYPE')GOTO3110
      IF(IWORD1.EQ.'ASCI'.AND.IWORD2.EQ.'FILE')GOTO3110
C
      IF(ICHAR1.EQ.'A')GOTO3120
      IF(ICHAR1.EQ.'B')GOTO3120
      IF(ICHAR1.EQ.'C')GOTO3120
C
      IF(ICHAR1.EQ.'D')GOTO3130
      IF(ICHAR1.EQ.'E')GOTO3130
      IF(ICHAR1.EQ.'F')GOTO3130
      IF(ICHAR1.EQ.'G')GOTO3130
      IF(ICHAR1.EQ.'H')GOTO3130
      IF(ICHAR1.EQ.'I')GOTO3130
      IF(ICHAR1.EQ.'J')GOTO3130
      IF(ICHAR1.EQ.'K')GOTO3130
C
      IF(ICHAR1.EQ.'L')GOTO3140
      IF(ICHAR1.EQ.'M')GOTO3140
      IF(ICHAR1.EQ.'N')GOTO3140
      IF(ICHAR1.EQ.'O')GOTO3140
C
      IF(ICHAR1.EQ.'P')GOTO3150
      IF(ICHAR1.EQ.'Q')GOTO3150
      IF(ICHAR1.EQ.'R')GOTO3150
      IF(ICHAR1.EQ.'S')GOTO3150
C
CCCCC IF(ICHAR1.EQ.'T')GOTO3160
CCCCC IF(ICHAR1.EQ.'U')GOTO3160
CCCCC IF(ICHAR1.EQ.'V')GOTO3160
CCCCC IF(ICHAR1.EQ.'W')GOTO3160
CCCCC IF(ICHAR1.EQ.'X')GOTO3160
CCCCC IF(ICHAR1.EQ.'Y')GOTO3160
CCCCC IF(ICHAR1.EQ.'Z')GOTO3160
      GOTO3160
 
 3110 CONTINUE
      JFILE=1
      GOTO3190
 3120 CONTINUE
      JFILE=2
      GOTO3190
 3130 CONTINUE
      JFILE=3
      GOTO3190
 3140 CONTINUE
      JFILE=4
      GOTO3190
 3150 CONTINUE
      JFILE=5
      GOTO3190
 3160 CONTINUE
      JFILE=6
      GOTO3190
C
 3190 CONTINUE
C
C               *******************************
C               **  STEP 32--                **
C               **  COPY OVER FILE VARIABLES **
C               *******************************
C
      ISTEPN='32'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(JFILE.EQ.1)GOTO3210
      IF(JFILE.EQ.2)GOTO3220
      IF(JFILE.EQ.3)GOTO3230
      IF(JFILE.EQ.4)GOTO3240
      IF(JFILE.EQ.5)GOTO3250
      GOTO3260
C
 3210 CONTINUE
      IOUNIT=IHE1NU
      IFILE=IHE1NA
      ISTAT=IHE1ST
      IFORM=IHE1FO
      IACCES=IHE1AC
      IPROT=IHE1PR
      ICURST=IHE1CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3220 CONTINUE
      IOUNIT=IHE2NU
      IFILE=IHE2NA
      ISTAT=IHE2ST
      IFORM=IHE2FO
      IACCES=IHE2AC
      IPROT=IHE2PR
      ICURST=IHE2CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3230 CONTINUE
      IOUNIT=IHE3NU
      IFILE=IHE3NA
      ISTAT=IHE3ST
      IFORM=IHE3FO
      IACCES=IHE3AC
      IPROT=IHE3PR
      ICURST=IHE3CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3240 CONTINUE
      IOUNIT=IHE4NU
      IFILE=IHE4NA
      ISTAT=IHE4ST
      IFORM=IHE4FO
      IACCES=IHE4AC
      IPROT=IHE4PR
      ICURST=IHE4CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3250 CONTINUE
      IOUNIT=IHE5NU
      IFILE=IHE5NA
      ISTAT=IHE5ST
      IFORM=IHE5FO
      IACCES=IHE5AC
      IPROT=IHE5PR
      ICURST=IHE5CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3260 CONTINUE
      IOUNIT=IHE6NU
      IFILE=IHE6NA
      ISTAT=IHE6ST
      IFORM=IHE6FO
      IACCES=IHE6AC
      IPROT=IHE6PR
      ICURST=IHE6CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO3291
C
 3291 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO3299
      WRITE(ICOUT,3293)IOUNIT
 3293 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3294)IFILE
 3294 FORMAT('IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
 3295 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3296)IBUGS2,ISUBRO,ISUBN0,IERRFI
 3296 FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 3299 CONTINUE
C
C               ****************************************
C               **  STEP 33--                         **
C               **  CHECK TO SEE IF HELP FILE EXISTS  **
C               ****************************************
C
      ISTEPN='33'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ISTAT.EQ.'NONE')GOTO3300
      GOTO3390
 3300 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3311)
 3311 FORMAT('***** ERROR IN DPHELP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3312)
 3312 FORMAT('      THE DESIRED HELP INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3313)
 3313 FORMAT('      CANNOT BE GIVEN BECAUSE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3314)
 3314 FORMAT('      THE REQUIRED SYSTEM MASS STORAGE FILE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3315)
 3315 FORMAT('      WHICH STORES SUCH HELP INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3316)
 3316 FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3317)ISTAT,IHELST
 3317 FORMAT('ISTAT,IHELST = ',A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3318)IFILE(1:50)
 3318 FORMAT('IFILE(1:50) = ',A50)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 3390 CONTINUE
C
C               *********************
C               **  STEP 34--      **
C               **  OPEN THE FILE  **
C               *********************
C
      ISTEPN='34'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     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               **  BASED ON THE FIRST WORD OR                  **
C               **  THE FIRST CHARACTER OF THE FIRST WORD,      **
C               **  DETERMINE THE SECTION NUMBER WITHIN A FILE  **
C               **  THAT SHOULD BE SEARCHED.                    **
C               **************************************************
C
      ISTEPN='42'
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC JCHAR1=ICHAR(ICHAR1)
      CALL DPCOAN(ICHAR1,JCHAR1)
C
      IF(JFILE.EQ.1)GOTO4110
      IF(JFILE.EQ.2)GOTO4120
      IF(JFILE.EQ.3)GOTO4130
      IF(JFILE.EQ.4)GOTO4140
      IF(JFILE.EQ.5)GOTO4150
      GOTO4160
C
 4110 CONTINUE
      IF(IWORD1.EQ.'OVER')JSEC=1
      IF(IWORD1.EQ.'GRAP')JSEC=2
      IF(IWORD1.EQ.'DIAG')JSEC=3
      IF(IWORD1.EQ.'ANAL')JSEC=4
      IF(IWORD1.EQ.'PLOT'.AND.IWORD2.EQ.'CONT')JSEC=5
      IF(IWORD1.EQ.'SUPP')JSEC=6
      IF(IWORD1.EQ.'OUTP')JSEC=7
      IF(IWORD1.EQ.'KEYW')JSEC=8
      IF(IWORD1.EQ.'FUNC')JSEC=9
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'FUNC')JSEC=10
      IF(IWORD1.EQ.'TRIG')JSEC=11
      IF(IWORD1.EQ.'PROB')JSEC=12
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUBC')JSEC=13
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB-')JSEC=13
      IF(IWORD1.EQ.'LET '.AND.IWORD2.EQ.'SUB ')JSEC=13
      IF(IWORD1.EQ.'STAT')JSEC=14
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'OPER')JSEC=15
CCCCC MARCH 1996.  A MATRIX OPERATIONS SECTION ADDED, ADD 1 TO
CCCCC FOLLOWING SECTION NUMBERS.
      IF(IWORD1.EQ.'MATR'.AND.IWORD2.EQ.'OPER')JSEC=16
CCCCC IF(IWORD1.EQ.'RAND')JSEC=16
CCCCC IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUBC')JSEC=17
CCCCC IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB-')JSEC=17
CCCCC IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB ')JSEC=17
CCCCC IF(IWORD1.EQ.'CAPI')JSEC=18
CCCCC IF(IWORD1.EQ.'CAPS')JSEC=18
CCCCC IF(IWORD1.EQ.'CAP ')JSEC=18
CCCCC IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'CRIP')JSEC=19
CCCCC IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'SET ')JSEC=ISECNA+18
CCCCC IF(IWORD1.EQ.'GREE')JSEC=20
CCCCC IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'SYMB')JSEC=21
CCCCC IF(IWORD1.EQ.'MISC')JSEC=22
CCCCC IF(IWORD1.EQ.'CHAR'.AND.IWORD2.EQ.'TYPE')JSEC=23
CCCCC IF(IWORD1.EQ.'LINE'.AND.IWORD2.EQ.'TYPE')JSEC=24
CCCCC IF(IWORD1.EQ.'COLO'.AND.IWORD2.EQ.'TYPE')JSEC=25
      IF(IWORD1.EQ.'RAND')JSEC=17
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUBC')JSEC=18
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB-')JSEC=18
      IF(IWORD1.EQ.'TEXT'.AND.IWORD2.EQ.'SUB ')JSEC=18
      IF(IWORD1.EQ.'CAPI')JSEC=19
      IF(IWORD1.EQ.'CAPS')JSEC=19
      IF(IWORD1.EQ.'CAP ')JSEC=19
      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'CRIP')JSEC=20
      IF(IWORD1.EQ.'SUBS'.AND.IWOR12.EQ.'SET ')JSEC=ISECNA+18
      IF(IWORD1.EQ.'GREE')JSEC=21
      IF(IWORD1.EQ.'MATH'.AND.IWORD2.EQ.'SYMB')JSEC=22
      IF(IWORD1.EQ.'MISC')JSEC=23
      IF(IWORD1.EQ.'CHAR'.AND.IWORD2.EQ.'TYPE')JSEC=24
      IF(IWORD1.EQ.'LINE'.AND.IWORD2.EQ.'TYPE')JSEC=25
      IF(IWORD1.EQ.'COLO'.AND.IWORD2.EQ.'TYPE')JSEC=26
      IF(IWORD1.EQ.'ASCI'.AND.IWORD2.EQ.'FILE')JSEC=27
      GOTO4190
C
 4120 CONTINUE
      IF(ICHAR1.EQ.'A')JSEC=1
      IF(ICHAR1.EQ.'B')JSEC=2
      IF(ICHAR1.EQ.'C')JSEC=3
      GOTO4190
C
 4130 CONTINUE
      IF(ICHAR1.EQ.'D')JSEC=1
      IF(ICHAR1.EQ.'E')JSEC=2
      IF(ICHAR1.EQ.'F')JSEC=3
      IF(ICHAR1.EQ.'G')JSEC=4
      IF(ICHAR1.EQ.'H')JSEC=5
      IF(ICHAR1.EQ.'I')JSEC=6
      IF(ICHAR1.EQ.'J')JSEC=7
      IF(ICHAR1.EQ.'K')JSEC=8
      GOTO4190
C
 4140 CONTINUE
      IF(ICHAR1.EQ.'L')JSEC=1
      IF(ICHAR1.EQ.'M')JSEC=2
      IF(ICHAR1.EQ.'N')JSEC=3
      IF(ICHAR1.EQ.'O')JSEC=4
      GOTO4190
C
 4150 CONTINUE
      IF(ICHAR1.EQ.'P')JSEC=1
      IF(ICHAR1.EQ.'Q')JSEC=2
      IF(ICHAR1.EQ.'R')JSEC=3
      IF(ICHAR1.EQ.'S')JSEC=4
      GOTO4190
C
 4160 CONTINUE
      JSEC=8
      IF(ICHAR1.EQ.'T')JSEC=1
      IF(ICHAR1.EQ.'U')JSEC=2
      IF(ICHAR1.EQ.'V')JSEC=3
      IF(ICHAR1.EQ.'W')JSEC=4
      IF(ICHAR1.EQ.'X')JSEC=5
      IF(ICHAR1.EQ.'Y')JSEC=6
      IF(ICHAR1.EQ.'Z')JSEC=7
      GOTO4190
C
 4190 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO4199
      WRITE(ICOUT,4191)
 4191 FORMAT('***** FROM 4191 IN MIDDLE OF DPHELP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4192)IWORD1,ICHAR1
 4192 FORMAT('IWORD1,ICHAR1 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4193)JFILE,JSEC
 4193 FORMAT('JFILE,JSEC = ',I8,2X,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4194)IBUGS2,ISUBRO,ISUBN0,IERRFI
 4194 FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 4199 CONTINUE
C
 4209 CONTINUE
C
C               ************************************************************
C               **  STEP 42--                                             **
C               **  READ IN SECTION LOCATION INFORMATION
C               **  FROM THE BEGINNING LINES OF THE FILE.                 **
C               **  THE FIRST LINE CONTAINS THE                           **
C               **  NUMBER OF LINES IN THE FILE (ANUMLI) (F10.0 FORMAT).  **
C               **  THE SECOND LINE CONTAINS THE NUMBER OF                **
C               **  SECTIONS IN THE FILE (ANUMSE) (F10.0 FORMAT)          **
C               **  THE NEXT ANUMSE LINES CONTAIN                         **
C               **  THE STARTING LINE NUMBER OF EACH SECTION              **
C               **  IN THE FILE (ATABLN)   (F10.0 FORMAT), AND            **
C               **  THE IDENTIFIER (IF ANY) FOR EACH SECTION              **
C               **  IN THE FILE (ITABID(.) (A4 FORMAT).                   **
C               ************************************************************
C
      ISTEPN='42'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      READ(IOUNIT,4211)ANUMLI
 4211 FORMAT(F10.0)
      NUMLIN=ANUMLI+0.5
      READ(IOUNIT,4212)ANUMSE
 4212 FORMAT(F10.0)
      NUMSEC=ANUMSE+0.5
      IF(NUMSEC.LE.0)GOTO4290
      DO4220I=1,NUMSEC
      READ(IOUNIT,4221)ATABLN,ITABID(I)
 4221 FORMAT(F10.0,A4)
      ITABLN(I)=ATABLN+0.5
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1WRITE(ICOUT,4222)I,ATABLN,ITABLN(I),ITABID(I)
 4222 FORMAT('I,ATABLN,ITABLN(I),ITABID(I) = ',I8,E15.7,I8,2X,A4)
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL DPWRST('XXX','BUG ')
 4220 CONTINUE
 4290 CONTINUE
C
C               *******************************************************
C               **  STEP 43--                                        **
C               **  BASED ON THE FILE, SECTION, & HEADER TABLE INFO, *
C               **  DO A TABLE LOOK-UP WHICH WILL SPECIFY            **
C               **  THE ABSOLUTE LINE NUMBER IN THE FILE             **
C               **  WHERE THE SECTION WITH THAT CODE WORD STARTS     **
C               *******************************************************
C
      ISTEPN='43'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTART=ITABLN(JSEC)
      JSECP1=JSEC+1
      ISTOP=NUMLIN
      IF(JSECP1.LE.NUMSEC)ISTOP=ITABLN(JSECP1)
      IF(ISTOP.LE.ISTART)ISTOP=NUMLIN
 
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO4390
      WRITE(ICOUT,4311)
 4311 FORMAT('***** FROM 4211 IN MIDDLE OF DPHEL2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4313)JSEC,ISTART
 4313 FORMAT('JSEC,ISTART = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4314)JSECP1,ISTOP
 4314 FORMAT('JSECP1,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
 4390 CONTINUE
C
C               *************************************************
C               **  STEP 51--                                  **
C               **  READ DOWN IN THE FILE TO                   **
C               **  THE LINE BEFORE WHERE THE CHARACTER RESIDES**
C               *************************************************
C
      ISTEPN='51'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      REWIND(IOUNIT)
C
      ISKIP=ISTART-1
      IF(ISKIP.LE.0)GOTO5190
      DO5100I=1,ISKIP
      READ(IOUNIT,5105,END=5280)
 5105 FORMAT()
 5100 CONTINUE
 5190 CONTINUE
C
C               ******************************************************
C               **  STEP 52.1--                                     **
C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
C               **  OF THE FILE.                                    **
C               ******************************************************
C
      ISTEPN='52.1'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO5200I=ISTART,ISTOP
      I2=I
C
CCCCC THE FOLLOWING SECTION WAS FIXED AUGUST 1994
C               *****************************************
C               **  STEP 52.2--                        **
C               **  READ IN SUCCEEDING LINES UNTIL     **
C               **  GET A HIT BASED ON THE FIRST WORD  **
C               **  OF THE COMMAND.                    **
C               *****************************************
C
CCCCC FEBRUARY 2003: FOLLOWING PRODUCES TOO MUCH IRELEVANT OUTPUT
CCCCC ISTEPN='52.2'
CCCCC IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
CCCCC1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC FEBRUARY 2003: UP FROM 30 CHARACTERS TO 40 CHARACTERS AND
CCCCC FROM MAXIMUM OF FOUR WORDS TO MAXIMUM OF FIVE WORDS.
C
      ILIN30='                                        '
      READ(IOUNIT,5202,END=5280)ILIN30
 5202 FORMAT(A40)
      IF(ILIN30(1:4).EQ.'    ')GOTO5200
C
CCCCC COMPARE CHAR. 1 TO 4 OF THE HELP FILE LINE
CCCCC (ILIN30(1:4) AND ICTEST) WITH
CCCCC CHAR. 1 TO 4 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWORD1)
C
      ICTEST=ILIN30(1:4)
      IF(ICTEST(4:4).EQ.' ' .OR. ICTEST(4:4).EQ.'-')ICTEST(4:4)=' '
      IF(ICTEST(3:3).EQ.' ' .OR. ICTEST(3:3).EQ.'-')ICTEST(3:4)='  '
      IF(ICTEST(2:2).EQ.' ' .OR. ICTEST(4:4).EQ.'-')ICTEST(2:4)='   '
C
      IF(ICTEST.EQ.IWORD1)GOTO5206
C
      GOTO5200
 5206 CONTINUE
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5207)I,ILIN30(1:40)
 5207    FORMAT('I,ILIN30(1:40)=',I8,2X,A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,ILIN30(1:4),ICTEST
 5208    FORMAT('NUMARG,NUMAR2,IWORD1,ILIN30(1:4),ICTEST = ',
     1   I8,I8,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC COMPARE CHAR. 5 TO 8 OF THE HELP FILE LINE
CCCCC (ILIN30(5:8) AND ICTEST) WITH
CCCCC CHAR. 5 TO 8 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWOR12)
C
      ICTEST=ILIN30(5:8)
      IF(ILIN30(4:4).EQ.' ' .OR. ILIN30(4:4).EQ.'-')ICTEST='    '
      IF(ILIN30(3:3).EQ.' ' .OR. ILIN30(3:3).EQ.'-')ICTEST='    '
      IF(ILIN30(2:2).EQ.' ' .OR. ILIN30(2:2).EQ.'-')ICTEST='    '
      IF(ILIN30(1:1).EQ.' ' .OR. ILIN30(1:1).EQ.'-')ICTEST='    '
C
      IF(ICTEST(3:3).EQ.' ' .OR. ICTEST(3:3).EQ.'-')ICTEST(3:4)='  '
      IF(ICTEST(2:2).EQ.' ' .OR. ICTEST(2:2).EQ.'-')ICTEST(2:4)='   '
      IF(ICTEST(1:1).EQ.' ' .OR. ICTEST(1:1).EQ.'-')ICTEST(1:4)='    '
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
         WRITE(ICOUT,5209)IWOR12,ICTEST
 5209    FORMAT('IWOR12,ICTEST = ',A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING LINE WAS CHANGED            DECEMBER 1994
CCCCC SO THAT    HELP CHAR    WOULD WORK        DECEMBER 1994
CCCCC IF(ICTEST.EQ.IWOR12)GOTO5210
CCCCC FIX SO THAT TEST DONE IF THERE IS A SECOND    JUNE 1999
CCCCC WORD TO RESOLVE NAME CONFLICTS                JUNE 1999
      IF(ICTEST(1:4).EQ.'    ')THEN
        GOTO5210
      ELSE
        IF(ICTEST.EQ.IWOR12)GOTO5210
        IF(ICTEST.NE.IWOR12)GOTO5200
      ENDIF
CCCCC GOTO5210
C
      GOTO5200
 5210 CONTINUE
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
         WRITE(ICOUT,5211)NUMARG,NUMAR2,IWOR12,ILIN30(5:8),ICTEST
 5211    FORMAT('NUMARG,NUMAR2,IWOR12,ILIN30(5:8),ICTEST = ',
     1   I8,I8,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS FIXED    AUGUST 1994
C               ***********************************************
C               **  STEP 52.3--                              **
C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
C               ***********************************************
C
      ISTEPN='52.3'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTRIN(1:40)=ILIN30(1:40)
C
      NUMWHF=1
      ILOC2=1
      ILOC3=1
      ILOC4=1
      ILOC5=1
      DO5220J=1,39
         JP1=J+1
         IF((ISTRIN(J:J).EQ.' ' .OR. ISTRIN(J:J).EQ.'-').AND.
     1       ISTRIN(JP1:JP1).NE.' ')THEN
            NUMWHF=NUMWHF+1
            IF(NUMWHF.EQ.2)ILOC2=JP1
            IF(NUMWHF.EQ.3)ILOC3=JP1
            IF(NUMWHF.EQ.4)ILOC4=JP1
            IF(NUMWHF.EQ.5)ILOC5=JP1
         ENDIF
 5220 CONTINUE
      ILOC2P=ILOC2+3
      ILOC3P=ILOC3+3
      ILOC4P=ILOC4+3
      ILOC5P=ILOC5+3
C
      IZ1=ILIN30(1:4)
      IZ2(1:4)='    '
      IF(NUMWHF.GE.2)IZ2(1:4)=ISTRIN(ILOC2:ILOC2P)
      IZ3(1:4)='    '
      IF(NUMWHF.GE.3)IZ3(1:4)=ISTRIN(ILOC3:ILOC3P)
      IZ4(1:4)='    '
      IF(NUMWHF.GE.4)IZ4(1:4)=ISTRIN(ILOC4:ILOC4P)
      IZ5(1:4)='    '
      IF(NUMWHF.GE.5)IZ5(1:4)=ISTRIN(ILOC5:ILOC5P)
C
      DO5225J=2,4
        IF(IZ1(J:J).EQ.' '.OR.IZ1(J:J).EQ.'-')IZ1(J:4)=' '
        IF(IZ2(J:J).EQ.' '.OR.IZ2(J:J).EQ.'-')IZ2(J:4)=' '
        IF(IZ3(J:J).EQ.' '.OR.IZ3(J:J).EQ.'-')IZ3(J:4)=' '
        IF(IZ4(J:J).EQ.' '.OR.IZ4(J:J).EQ.'-')IZ4(J:4)=' '
        IF(IZ5(J:J).EQ.' '.OR.IZ5(J:J).EQ.'-')IZ5(J:4)=' '
 5225 CONTINUE
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
         WRITE(ICOUT,5231)
 5231    FORMAT('***** FROM 1731 IN MIDDLE OF DPHELP--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5
 5232    FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5 = ',
     1   A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5233)ILIN30(1:40)
 5233    FORMAT('ILIN30(1:40) = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5234)IZ1,IZ2,IZ3,IZ4,IZ5
 5234    FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5235)ISTRIN
 5235    FORMAT('ISTRIN = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5236)NUMARG,NUMAR2,NUMWHF
 5236    FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5237)ILOC2,ILOC3,ILOC4,ILOC5
 5237    FORMAT('ILOC2,ILOC3,ILOC4,ILOC5 = ',4I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5238)ILOC2P,ILOC3P,ILOC4P,ILOC5P
 5238    FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
         IF(NUMAR2.NE.NUMWHF)GOTO5200
C
 5252 CONTINUE
      IF(NUMAR2.LE.1)GOTO5290
      IF(NUMWHF.LE.1)GOTO5290
C
      IF(IZ2.EQ.IWORD2)GOTO5253
C
      GOTO5200
C
 5253 CONTINUE
      IF(NUMAR2.LE.2)GOTO5290
      IF(NUMWHF.LE.2)GOTO5290
C
      IF(IZ3.EQ.IWORD3)GOTO5254
C
      GOTO5200
C
 5254 CONTINUE
      IF(NUMAR2.LE.3)GOTO5290
      IF(NUMWHF.LE.3)GOTO5290
C
      IF(IZ4.EQ.IWORD4)GOTO5255
C
      GOTO5200
C
 5255 CONTINUE
      IF(NUMAR2.LE.4)GOTO5290
      IF(NUMWHF.LE.4)GOTO5290
C
      IF(IZ5.EQ.IWORD5)GOTO5290
C
      GOTO5200
C
 5200 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS  CHANGED     AUGUST 1994 (JJF)
 5280 CONTINUE
      IERROR='YES'
      IF(IPASS.GE.2)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5281)
 5281    FORMAT('***** ERROR IN DPHELP--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5282)
 5282    FORMAT('      THE SPECIFIED COMMAND FOR WHICH')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5283)
 5283    FORMAT('      HELP WAS DESIRED WAS NOT FOUND')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5284)
 5284    FORMAT('      IN THE HELP FILE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5285)
 5285    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5286)(IANS(I),I=1,IWIDTH)
 5286    FORMAT('      ',120A1)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      GOTO6100
C
 5290 CONTINUE
C
C               ****************************************************
C               **  STEP 53--                                     **
C               **  IF HAVE A HIT ON ALL WORDS,                   **
C               **  THEN READ IN AND WRITE OUT                    **
C               **  THE ENTIRE TEXT DESCRIPTION ASSOCIATED WITH   **
C               **  THE DESIRED COMMAND.                          **
C               **  THIS DESCRIPTION WILL START ON THE NEXT LINE  **
C               **  AND WILL FINISH WHEN A LINE OF HYPHENS        **
C               **  IS ENCOUNTERED.                               **
C               ****************************************************
C
 5300 CONTINUE
      ISTEPN='53'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMLPR=0
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
      IRESP='YES'
      IF(NCPREH.LE.0)GOTO5319
      WRITE(ICOUT,5311)(ICPREH(J:J),J=1,NCPREH)
 5311 FORMAT(80A1)
CCCCC CALL DPWRST('XXX','BUG ')    SEPTEMBER 1993
      CALL DPWRST('XXX','WRIT')
 5319 CONTINUE
C
      WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')    SEPTEMBER 1993
      CALL DPWRST('XXX','WRIT')
CCCCC DO5320I=1,2
      DO5320I=1,100000
      READ(IOUNIT,5321,END=5390)(ICTEXT(J),J=1,20)
 5321 FORMAT(20A4)
      IF(ICTEXT(1).EQ.'----')GOTO5390
      IF(ICTEXT(1).EQ.'....')GOTO5390
C
CCCCC THE FOLLOWING 11 LINES WERE COMMENTED OUT JULY 1989
CCCCC IF(NUMLPR.LT.IHELMX)GOTO5329
CCCCC WRITE(ICOUT,5322)
C5322 FORMAT('                                      MORE...')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC READ(IRD,5323)
C5323 FORMAT()
CCCCC NUMLPR=0
CCCCC IF(NCPREH.LE.0)GOTO5327
CCCCC WRITE(ICOUT,5326)(ICPREH(J:J),J=1,NCPREH)
C5326 FORMAT(80A1)
CCCCC CALL DPWRST('XXX','BUG ')
C5327 CONTINUE
C5329 CONTINUE
C
CCCCC THE FOLLOWING 2 LINES WERE ADDED JULY 1989
CCCCC (AND THEN FIXED NOVEMBER 1989--AS PER NELSON HSU)
CCCCC IF(NUMLPR.GE.IHELMX)
CCCCC1CALL DPMORE(NUMLPR,NCPREH,ICPREH,IBUGS2,IERRO)
CCCCC THE FOLLOWING 2 LINES WERE MODIFIED JULY 1990
CCCCC IF(NUMLPR.GE.IHELMX)
CCCCC1CALL DPMORE(NUMLPR,NCPREH,ICPREH,IBUGS2,IERROR)
      IF(NUMLPR.GE.IHELMX)
     1CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGS2,IERROR)
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1990
      IF(NUMLPR.GE.IHELMX)NUMLPR=0
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1990
      IF(IRESP.EQ.'NO')GOTO5390
C
      DO5330J=1,20
      JREV=20-J+1
      IF(ICTEXT(JREV).NE.'    ')GOTO5335
 5330 CONTINUE
 5335 CONTINUE
      JMAX=JREV
C
      WRITE(ICOUT,5336)(ICTEXT(J),J=1,JMAX)
 5336 FORMAT(20A4)
CCCCC CALL DPWRST('XXX','BUG ')    SEPTEMBER 1993
      CALL DPWRST('XXX','WRIT')
      NUMLPR=NUMLPR+1
 5320 CONTINUE
C
 5390 CONTINUE
C
      IF(NCPOSH.LE.0)GOTO5399
      WRITE(ICOUT,5391)(ICPOSH(J:J),J=1,NCPOSH)
 5391 FORMAT(80A1)
CCCCC CALL DPWRST('XXX','BUG ')    SEPTEMBER 1993
      CALL DPWRST('XXX','WRIT')
 5399 CONTINUE
C
C               **************************************
C               **  STEP 61--                       **
C               **  CLOSE           THE HELP FILE.  **
C               **************************************
C
 6100 CONTINUE
C
      ISTEPN='61'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
CCCCC THE FOLLOWING LINE WAS FIXED    AUGUST 1994
CCCCC1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
      IF(IERRFI.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED         AUGUST 1994
CCCCC TO SEARCH A SYNONYM FILE (DPHE7F.TEX)   AUGUST 1994
C               ***********************************************
C               **  STEP 62--                                **
C               ** IF PASS 1 AND NOT FOUND IN FILES 1 TO 6,  **
C               ** THEN SCAN SYNONYM FILE FOR MATCH          **
C               ** AND TRY AGAIN IN FILES 1 TO 6             **
C               ***********************************************
C
 6200 CONTINUE
      IF(IPASS.EQ.1.AND.IERROR.EQ.'YES')THEN
         IOUNIT=IHE7NU
         IFILE=IHE7NA
         ISTAT=IHE7ST
         IFORM=IHE7FO
         IACCES=IHE7AC
         IPROT=IHE7PR
         ICURST=IHE7CS
         ISUBN0='HEL2'
         IERRFI='NO'
         IREWIN='ON'
         CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1   IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
         IF(IERRFI.EQ.'YES')GOTO9000
C
CCCCC CORRECTIONS WERE MADE IN THE FOLLOWING SECTION DECEMBER 1994
         IMATCH=0
         DO6210I=1,5
            READ(IOUNIT,6211)ICJUNK
 6211       FORMAT(A1)
 6210    CONTINUE
         DO6220I=1,10000
            READ(IOUNIT,6221,END=6229)ILINE(1:80)
 6221       FORMAT(A80)
            IF(ILINE(1:4).EQ.IWORD1.AND.ILINE(5:8).EQ.IWOR12)THEN
               IF(ILINE(10:13).EQ.IWORD2)THEN
                  IF(ILINE(15:18).EQ.IWORD3)THEN
                     IF(ILINE(20:23).EQ.IWORD4)THEN
                        IF(ILINE(25:28).EQ.IWORD5)THEN
                          IMATCH=1
                          IWORD1=ILINE(41:44)
                          IWOR12=ILINE(45:48)
                          IWORD2=ILINE(50:53)
                          IWORD3=ILINE(55:58)
                          IWORD4=ILINE(60:63)
                          IWORD5=ILINE(65:68)
                          NUMAR2=5
                          IF(IWORD5.EQ.'    ')NUMAR2=4
                          IF(IWORD4.EQ.'    ')NUMAR2=3
                          IF(IWORD3.EQ.'    ')NUMAR2=2
                          IF(IWORD2.EQ.'    ')NUMAR2=1
                       ENDIF
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
 6220    CONTINUE
 6229    CONTINUE
C
         IENDFI='OFF'
         IREWIN='ON'
         CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1   IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
         IF(IERRFI.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING I/O SECTION WAS ADDED     DECEMBER 1994
         IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6231)
 6231       FORMAT('FROM DPHELP AT 6231--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4
 6232       FORMAT(A4,2X,A4,2X,A4,2X,A4,2X,A4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6233)NUMAR2,IMATCH
 6233       FORMAT('NUMAR2,IMATCH = ',2I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
         ENDIF
C
         IF(IMATCH.EQ.1)THEN
            IERROR='NO'
            GOTO1000
         ENDIF
      ENDIF
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HELP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHELP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR,IERRO2
 9012 FORMAT('IBUGS2,ISUBRO,IERROR,IERRO2 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 12 LINES WERE COMMENTED OUT APRIL 1992
CCCCC WRITE(ICOUT,9021)IHE1CO,IHE1AL
C9021 FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9022)IHE2CO,IHE2AL
C9022 FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9023)IHE3CO,IHE3AL
C9023 FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9024)IHE4CO,IHE4AL
C9024 FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9025)IHE5CO,IHE5AL
C9025 FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9026)IHE6CO,IHE6AL
C9026 FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE FIXED   APRIL 1992
CCCCC WRITE(ICOUT,9028)IBUGHE,IBUGH2,IFOUND,IERROR
C9028 FORMAT('IBUGHE,IBUGH2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IBUGS2,IFOUND,IERROR
 9028 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IOUNIT
 9031 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IFILE
 9032 FORMAT('IFILE  = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)ISTAT
 9033 FORMAT('ISTAT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IFORM
 9034 FORMAT('IFORM  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IACCES
 9035 FORMAT('IACCES = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)IPROT
 9036 FORMAT('IPROT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)ICURST
 9037 FORMAT('ICURST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)IENDFI
 9038 FORMAT('IENDFI = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IREWIN
 9039 FORMAT('IREWIN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)ISUBN0
 9041 FORMAT('ISUBN0 = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)IERRFI
 9042 FORMAT('IERRFI = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)IWORD1,IWORD2,ICHAR1
 9043 FORMAT('IWORD1,IWORD2,ICHAR1 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)JFILE,JSEC,ISTART
 9044 FORMAT('JFILE,JSEC,ISTART = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)ISKIP,ISTART,ISTOP,JMAX
 9051 FORMAT('ISKIP,ISTART,ISTOP,JMAX = ',4I8)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE CHANGED AUGUST 1994
CCCCC WRITE(ICOUT,9060)IW1,ICTEST,IWORD1,IWOR12
C9060 FORMAT('IW1,ICTEST,IWORD1,IWOR12 = ',A4,2X,A4,2X,A4,2X,A4)
      WRITE(ICOUT,9060)ILIN30(1:30),ICTEST,IWORD1,IWOR12
 9060 FORMAT('ILIN30(1:30),ICTEST,IWORD1,IWOR12=',A30,2X,A4,A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA
 9061 FORMAT('NUMSEC,NUMLIN,ISECNA = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9062)NUMARG,NUMAR2
 9062 FORMAT('NUMARG,NUMAR2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9063)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12
 9063 FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE CHANGED AUGUST 1994
CCCCC WRITE(ICOUT,9064)IW1,IW2,IW3,IW4,IW5
C9064 FORMAT('IW1,IW2,IW3,IW4,IW5 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4)
      WRITE(ICOUT,9064)ILIN30(1:30)
 9064 FORMAT('ILIN30(1:30) = ',A30)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4,IZ5
 9065 FORMAT('IZ1,IZ2,IZ3,IZ4,IZ5 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9066)ISTRIN
 9066 FORMAT('ISTRIN = ',A40)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9067)NUMWHF
 9067 FORMAT('NUMWHF = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9068)ILOC2,ILOC3,ILOC4,ILOC5
 9068 FORMAT('ILOC2,ILOC3,ILOC4,ILOC5 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P,ILOC5P
 9069 FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9071)ICHAR1
 9071 FORMAT('ICHAR1 = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9072)JCHAR1,JSEC,JSECP1
 9072 FORMAT('JCHAR1,JSEC,JSECP1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9073)ITABLN(JSEC),ITABLN(JSECP1)
 9073 FORMAT('ITABLN(JSEC),ITABLN(JSECP1) = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9074)ITABID(JSEC),ITABID(JSECP1)
 9074 FORMAT('ITABID(JSEC),ITABID(JSECP1) = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9075)ISTART,ISTOP
 9075 FORMAT('ISTART,ISTOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9077)I2
 9077 FORMAT('I2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9079)IBUGS2,ISUBRO,IERROR
 9079 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9081)IHELMX
 9081 FORMAT('IHELMX = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO9084
      DO9082I=1,NCPREH
      WRITE(ICOUT,9083)I,ICPREH(I:I)
 9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9082 CONTINUE
 9084 CONTINUE
      WRITE(ICOUT,9086)NCPOSH
 9086 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO9089
      DO9087I=1,NCPOSH
      WRITE(ICOUT,9088)I,ICPOSH(I:I)
 9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9087 CONTINUE
 9089 CONTINUE
CCCCC THE FOLLOWING 3 LINES WERE ADDED JULY 1990
      WRITE(ICOUT,9091)IRESP
 9091 FORMAT('IRESP = ',A4)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 3 LINES WERE ADDED AUGUST 1994
      WRITE(ICOUT,9093)IERROR,IERRO2,IPASS,IMATCH
 9093 FORMAT('IERROR,IERRO2,IPASS,IMATCH = ',A4,2X,A4,I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9094)ILINE
 9094 FORMAT('ILINE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9095)IWORD1,IWOR12,IWORD2
 9095 FORMAT('IWORD1,IWOR12,IWORD2 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9096)IWORD3,IWORD4
 9096 FORMAT('IWORD3,IWORD4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHELW(IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,IANS,
     1IWIDTH,IBUGS2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--ACCESS THE ON-LINE DATAPLOT REFERENCE MANUAL VIA
C              A WEB BROWSER (DEFAULTS TO NETSCAPE).  A PDF READER,
C              TYPICALLY THE ADOBE "ACROREAD" IS USED.  CURRENTLY,
C              THIS IS ONLY SUPPORTED FOR UNIX SYSTEMS (THE PC
C              VERSION IS A LITTLE HARDER TO ACCESS IN COMMAND MODE).
C
C              THIS COMMAND TAKES THE FOLLOWING FORMS:
C                  WEB HELP           - GO TO MAIN DATAPLOT HOME PAGE
C                  WEB HELP HOME PAGE - GO TO MAIN DATAPLOT HOME PAGE
C                  WEB HELP REFERENCE MANUAL - GO TO MAIN PAGE OF
C                                              REFERENCE MANUAL
C                  WEB HELP  - GO TO A PARTICULAR PDF FILE
C                                       IN THE ON-LINE MANUAL BASED
C                                       ON MATCHING  TO A
C                                       FILE (REFMAN.TEX)
C     INPUT  ARGUMENTS--IANS    (A  HOLLERITH VECTOR)
C                     --IWIDTH (AN INTEGER VARIABLE)
C                     --IBROWS  (A CHARACTER VARIABLE THAT IDENTIFIES
C                               THE BROWSER TO USE)
C                     --IDPURL  (A CHARACTER VARIABLE THAT IDENTIFIES
C                               THE WEB URL OF THE DATAPLOT HOME PAGE)
C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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--97/4
C     ORIGINAL VERSION--APRIL     1997.
C     UPDATED         --NOVEMBER  1997. BETTER CHECKING FOR NAME CONFLICTS
C     UPDATED         --FEBRUARY  2003. CHECK FOR 5 WORDS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
      CHARACTER*4 IANS
      CHARACTER*1 IQUOTE
      CHARACTER*40 ILINE1
      CHARACTER*40 ILINE2
      CHARACTER*500 ICALL
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 ISUBN0
      CHARACTER*4 IERRFI
      CHARACTER*4 IENDFI
      CHARACTER*4 IREWIN
C
      CHARACTER*4 IWORD1
      CHARACTER*4 IWORD2
      CHARACTER*4 IWORD3
      CHARACTER*4 IWORD4
      CHARACTER*4 IWORD5
      CHARACTER*4 IWOR12
C
      CHARACTER*4 IBRWFL
C
      CHARACTER*1 ICHAR1
C
      CHARACTER*4 ICTEST
      CHARACTER*4 ICTES2
C
      CHARACTER*4 IZ1
      CHARACTER*4 IZ2
      CHARACTER*4 IZ3
      CHARACTER*4 IZ4
      CHARACTER*4 IZ5
C
      CHARACTER*40 ISTRIN
      CHARACTER*4 IERRO2
      CHARACTER*1 ICJUNK
      CHARACTER*80 ILINE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARG(*)
      DIMENSION ARG(*)
      DIMENSION IARGT(*)
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHO.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOF2.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPHE'
      ISUBN2='LW  '
      NUMLIN=(-999)
      NUMSEC=(-999)
      ISECNA=(-999)
C
      NUMAR2=(-999)
C
      IWORD1='    '
      IWORD2='    '
      IWORD3='    '
      IWORD4='    '
      IWORD5='    '
      IWOR12='    '
C
      ICTEST='    '
      ICTES2='    '
C
      ILINE1='                              '
C
      IZ1='    '
      IZ2='    '
      IZ3='    '
      IZ4='    '
      IZ5='    '
C
      JCHAR1=(-999)
      JSEC=(-999)
      JSECP1=(-999)
C
      ISKIP=(-999)
      ISTART=(-999)
      ISTOP=(-999)
      I2=(-999)
C
      ISTRIN='                              '
C
      NUMWHF=(-999)
      ILOC2=(-999)
      ILOC3=(-999)
      ILOC4=(-999)
      ILOC5=(-999)
C
      ILOC2P=(-999)
      ILOC3P=(-999)
      ILOC4P=(-999)
      ILOC5P=(-999)
C
      CALL DPCONA(39,IQUOTE)
C
      IFOUND='YES'
      IERROR='NO'
C
      ISHIFT=1
      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1IBUGS2,IERROR)
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HELW')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHELW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR
   53 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IWIDTH
   54 FORMAT('IWIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH)
   55 FORMAT('IANS(.) = ',120A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,86)IBROWS(1:80)
   86 FORMAT('IBROWS = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,88)IDPURL(1:80)
   88 FORMAT('IDPURL = ',A80)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IF(
     1       (IHOST1.EQ.'SUN') .OR.
     1       (IHOST1.EQ.'CRAY' .AND. IOPSY1.EQ.'UNIX') .OR.
     1       (IHOST1.EQ.'CONV') .OR.
     1       (IHOST1.EQ.'SGI ') .OR.
     1       (IHOST1.EQ.'HP-9') .OR.
     1       (IHOST1.EQ.'AIX ') .OR.
     1       (IHOST1.EQ.'LINU') .OR.
     1       (IOPSY1.EQ.'UNIX'))GOTO199
      IF(IHOST1.EQ.'IBM-'.AND.ICOMPI.EQ.'MS-F')GOTO199
  100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** FROM DPHELW--WEB HELP CURRENTLY ONLY SUPPORTED ',
     1'UNIX OR IBM-PC WINDOW 95/NT PLATFORMS.')
  199 CONTINUE
C
C               **********************************************************
C               **  STEP 21--                                           **
C               **  COPY OVER THE FIRST 4 WORDS AFTER THE WORDS WEB HELP**
C               **********************************************************
C
      IPASS=0
 1000 CONTINUE
      IPASS=IPASS+1
C
      ISTEPN='21'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.LE.1)THEN
         IWORD1=IHARG(1)
         IWOR12=IHARG2(1)
         IWORD2=IHARG(2)
         IWORD3=IHARG(3)
         IWORD4=IHARG(4)
         IWORD5=IHARG(5)
         NUMAR2=NUMARG
      ENDIF
C
      IF(NUMAR2.LE.0)THEN
         NUMAR2=1
         IWORD1='HOME'
         IWOR12='PAGE'
      ENDIF
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5099
C
C             ********************************************************
C             **  STEP 22--                                         **
C             **  STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD.  **
C             ********************************************************
C
      ISTEPN='22'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICHAR1=IWORD1(1:1)
C
C               *******************************
C               **  STEP 32--                **
C               **  COPY OVER FILE VARIABLES **
C               *******************************
C
      ISTEPN='32'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
 3210 CONTINUE
      IOUNIT=IHRMNU
      IFILE=IHRMNA
      ISTAT=IHRMST
      IFORM=IHRMFO
      IACCES=IHRMAC
      IPROT=IHRMPR
      ICURST=IHRMCS
      ISUBN0='HELW'
      IERRFI='NO'
C
 3291 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HELW')GOTO3299
      WRITE(ICOUT,3293)IOUNIT
 3293 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3294)IFILE
 3294 FORMAT('IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3295)ISTAT,IFORM,IACCES,IPROT,ICURST
 3295 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3296)IBUGS2,ISUBRO,ISUBN0,IERRFI
 3296 FORMAT('IBUGS2,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 3299 CONTINUE
C
C               ****************************************
C               **  STEP 33--                         **
C               **  CHECK TO SEE IF HELP FILE EXISTS  **
C               ****************************************
C
      ISTEPN='33'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ISTAT.EQ.'NONE')GOTO3300
      GOTO3390
 3300 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3311)
 3311 FORMAT('***** ERROR IN DPHELW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3312)
 3312 FORMAT('      THE DESIRED HELP INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3313)
 3313 FORMAT('      CANNOT BE GIVEN BECAUSE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3314)
 3314 FORMAT('      THE REQUIRED SYSTEM MASS STORAGE FILE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3315)
 3315 FORMAT('      WHICH STORES SUCH HELP INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3316)
 3316 FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3317)ISTAT,IHRMST
 3317 FORMAT('ISTAT,IHELST = ',A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3318)IFILE(1:50)
 3318 FORMAT('IFILE(1:50) = ',A50)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 3390 CONTINUE
C
C               *********************
C               **  STEP 34--      **
C               **  OPEN THE FILE  **
C               *********************
C
      ISTEPN='34'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     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 52.1--                                     **
C               **  LOOP THROUGH THE VARIOUS LINES OF THIS SECTION  **
C               **  OF THE FILE.                                    **
C               ******************************************************
C
 5099 CONTINUE
      ISTEPN='52.1'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICALL=' '
      DO5100I=MAXBRO,1,-1
         NUMBRO=I
         IF(IBROWS(I:I).NE.' ')GOTO5109
 5100 CONTINUE
 5109 CONTINUE
      IF(NUMBRO.GT.0)THEN
        ICALL(1:NUMBRO)=IBROWS(1:NUMBRO)
        NCSTR=NUMBRO+1
        ICALL(NCSTR:NCSTR)=' '
      ELSE
        ICALL(1:9)='netscape '
        NCSTR=9
      ENDIF
C
      IBRWFL='NETS'
      IF(NUMBRO.GE.8)THEN
        DO5125I=1,NUMBRO-7
          IF(IBROWS(I:I+7).EQ.'IEXPLORE' .OR.
     1       IBROWS(I:I+7).EQ.'iexplore')THEN
             IBRWFL='IEXP'
             GOTO5128
          ENDIF
 5125   CONTINUE
 5128   CONTINUE
      ENDIF
C
      DO5110I=MAXURL,1,-1
         NUMURL=I
         IF(IDPURL(I:I).NE.' ')GOTO5119
 5110 CONTINUE
 5119 CONTINUE
C
C  IF "SET NETSCAPE OLD" COMMAND WAS ENTERED, THEN USE 
C  -remote NETSCAPE OPTION.  THIS ONLY APPLIES TO UNIX PLATFORMS.
C
      IF(IHOST1.EQ.'IBM-')THEN
        IF(IBRWFL.EQ.'NETS')THEN
          NCSTR=NCSTR+1
          NCSTR2=NCSTR+3
          ICALL(NCSTR:NCSTR2)=' -h '
          NCSTR=NCSTR2
        ENDIF
        GOTO5129 
      ENDIF
      IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+8
        ICALL(NCSTR:NCSTR2)=' -remote '
        NCSTR=NCSTR2+1
        ICALL(NCSTR:NCSTR)=IQUOTE
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+7
        ICALL(NCSTR:NCSTR2)='openURL('
        NCSTR=NCSTR2
      ENDIF
C
 5129 CONTINUE
      IF(NUMURL.GT.0)THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+NUMURL-1
        ICALL(NCSTR:NCSTR2)=IDPURL(1:NUMURL)
        N1URL=NCSTR
        N2URL=NCSTR2
        NCSTR=NCSTR2
      ELSE
        NCSTR=NCSTR+1
        N1URL=NCSTR
        NCSTR2=NCSTR+6
        ICALL(NCSTR:NCSTR2)='http://'
        NCSTR=NCSTR2
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+16
        ICALL(NCSTR:NCSTR2)='www.itl.nist.gov/'
        NCSTR=NCSTR2
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+28
        ICALL(NCSTR:NCSTR2)='itl/div898/software/dataplot/'
        NCSTR=NCSTR2
        N2URL=NCSTR2
      ENDIF
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO5300
      ISTEPN='52.2'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      DO5200I=1,100000
      ILINE1=' '
      ILINE2=' '
      I2=I
C
C               *****************************************
C               **  STEP 52.2--                        **
C               **  READ IN SUCCEEDING LINES UNTIL     **
C               **  GET A HIT BASED ON THE FIRST WORD  **
C               **  OF THE COMMAND.                    **
C               *****************************************
C
CCCCC ISTEPN='52.2'
CCCCC IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
CCCCC1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      READ(IOUNIT,5202,END=5280)ILINE1,ILINE2
 5202 FORMAT(A40,A40)
      IF(ILINE1(1:4).EQ.'    ')GOTO5200
C
CCCCC COMPARE CHAR. 1 TO 4 OF THE HELP FILE LINE
CCCCC (ILINE1(1:4) AND ICTEST) WITH
CCCCC CHAR. 1 TO 4 OF THE FIRST WORD OF THE HELP COMMAND EXT (IWORD1)
C
CCCCC NOVEMBER 1997.  THIS SECTION REWRITTEN TO SIMPLIFY AND TO
CCCCC CHECK FOR NAME CONFLICTS (I.E., USE CHARACTERS 5-8 IF NEEDED).
      ICTEST=' '
      ICTES2=' '
      NBLANK=9
      DO5203II=1,8
        IF(ILINE1(II:II).EQ.' ')THEN
          NBLANK=II
          GOTO5204
        ENDIF
 5203 CONTINUE
 5204 CONTINUE
      IF(NBLANK.LE.5)THEN
        ICTEST(1:NBLANK-1)=ILINE1(1:NBLANK-1)
      ELSE
        ICTEST(1:4)=ILINE1(1:4)
        ICTES2(1:NBLANK-5)=ILINE1(5:NBLANK-1)
      ENDIF
C
      IF(ICTEST.NE.IWORD1.OR.ICTES2.NE.IWOR12)GOTO5200
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5207)I,ILINE1(1:40)
 5207    FORMAT('I,ILINE1(1:20)=',I8,2X,A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5208)NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2
 5208    FORMAT('NUMARG,NUMAR2,IWORD1,IWOR12,ICTEST,ICTES2 = ',
     1   I8,I8,2X,A4,2X,A4,2X,A4,2x,A4)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***********************************************
C               **  STEP 52.3--                              **
C               **  IF GOT A HIT ON THE FIRST 4-CHAR. WORD,  **
C               **  CHECK FOR A HIT ON ALL 4-CHAR WORDS      **
C               ***********************************************
C
      ISTEPN='52.3'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTRIN(1:40)=ILINE1(1:40)
C
      NUMWHF=1
      ILOC2=1
      ILOC3=1
      ILOC4=1
      ILOC5=1
      DO5220J=1,39
         JP1=J+1
         IF(ISTRIN(J:J).EQ.' '.AND.ISTRIN(JP1:JP1).NE.' ')THEN
            NUMWHF=NUMWHF+1
            IF(NUMWHF.EQ.2)ILOC2=JP1
            IF(NUMWHF.EQ.3)ILOC3=JP1
            IF(NUMWHF.EQ.4)ILOC4=JP1
            IF(NUMWHF.EQ.5)ILOC5=JP1
         ENDIF
 5220 CONTINUE
      ILOC2P=ILOC2+3
      ILOC3P=ILOC3+3
      ILOC4P=ILOC4+3
      ILOC5P=ILOC5+3
C
      IZ1=ILINE1(1:4)
      IZ2(1:4)='    '
      IF(NUMWHF.GE.2)IZ2(1:4)=ISTRIN(ILOC2:ILOC2P)
      IZ3(1:4)='    '
      IF(NUMWHF.GE.3)IZ3(1:4)=ISTRIN(ILOC3:ILOC3P)
      IZ4(1:4)='    '
      IF(NUMWHF.GE.4)IZ4(1:4)=ISTRIN(ILOC4:ILOC4P)
      IZ5(1:4)='    '
      IF(NUMWHF.GE.5)IZ5(1:4)=ISTRIN(ILOC5:ILOC5P)
C
      DO5225J=2,4
        IF(IZ1(J:J).EQ.' ')IZ1(J:4)=' '
        IF(IZ2(J:J).EQ.' ')IZ2(J:4)=' '
        IF(IZ3(J:J).EQ.' ')IZ3(J:4)=' '
        IF(IZ4(J:J).EQ.' ')IZ4(J:4)=' '
        IF(IZ5(J:J).EQ.' ')IZ5(J:4)=' '
 5225 CONTINUE
C
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
         WRITE(ICOUT,5231)
 5231    FORMAT('***** FROM 1731 IN MIDDLE OF DPHELW--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5
 5232    FORMAT('IWORD1,IWOR12,IWORD2,IWORD3,IWORD4,IWORD5 = ',
     1   A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5233)ILINE1(1:40)
 5233    FORMAT('ILINE1(1:40) = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5234)IZ1,IZ2,IZ3,IZ4,IZ5
 5234    FORMAT('IZ1,IZ2,IZ3,IZ4,IZ5 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5235)ISTRIN
 5235    FORMAT('ISTRIN = ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5236)NUMARG,NUMAR2,NUMWHF
 5236    FORMAT('NUMARG,NUMAR2,NUMWHF = ',3I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5237)ILOC2,ILOC3,ILOC4,ILOC5
 5237    FORMAT('ILOC2,ILOC3,ILOC4,ILOC5 = ',4I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5238)ILOC2P,ILOC3P,ILOC4P,ILOC5P
 5238    FORMAT('ILOC2P,ILOC3P,ILOC4P,ILOC5P = ',4I8)
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1994
         IF(NUMAR2.NE.NUMWHF)GOTO5200
C
 5252 CONTINUE
      IF(NUMAR2.LE.1)GOTO5290
      IF(NUMWHF.LE.1)GOTO5290
C
      IF(IZ2.EQ.IWORD2)GOTO5253
C
      GOTO5200
C
 5253 CONTINUE
      IF(NUMAR2.LE.2)GOTO5290
      IF(NUMWHF.LE.2)GOTO5290
C
      IF(IZ3.EQ.IWORD3)GOTO5254
C
      GOTO5200
C
 5254 CONTINUE
      IF(NUMAR2.LE.3)GOTO5290
      IF(NUMWHF.LE.3)GOTO5290
C
      IF(IZ4.EQ.IWORD4)GOTO5255
C
      GOTO5200
C
 5255 CONTINUE
      IF(NUMAR2.LE.3)GOTO5290
      IF(NUMWHF.LE.3)GOTO5290
C
      IF(IZ5.EQ.IWORD5)GOTO5290
C
      GOTO5200
C
 5200 CONTINUE
C
 5280 CONTINUE
      IERROR='YES'
      IF(IPASS.GE.2)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5281)
 5281    FORMAT('***** ERROR IN DPHELW--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5282)
 5282    FORMAT('      THE SPECIFIED COMMAND FOR WHICH')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5283)
 5283    FORMAT('      WEB HELP WAS DESIRED WAS NOT FOUND')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5284)
 5284    FORMAT('      IN THE HELP FILE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5285)
 5285    FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,5286)(IANS(I),I=1,IWIDTH)
 5286    FORMAT('      ',120A1)
         CALL DPWRST('XXX','BUG ')
      ENDIF
      GOTO6100
C
 5290 CONTINUE
C
C               ****************************************************
C               **  STEP 53--                                     **
C               **  IF HAVE A HIT ON ALL WORDS,                   **
C               **  THEN USE DPSYS2 TO MAKE A SYSTEM CALL         **
C               **  TO INIATE NETSCAPE.                           **
C               **  CHECK IF URL BEGINS WITH http (A FEW SPECIAL  **
C               **  CASES GO TO NON-DATAPLOT WEB PAGE             **
C               ****************************************************
C
 5300 CONTINUE
      ISTEPN='53'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+12
        ICALL(NCSTR:NCSTR2)='homepage.html'
        NCSTR=NCSTR2
        GOTO5349
      ENDIF
C
      DO5330J=40,1,-1
        NTEMP=J
        IF(ILINE2(J:J).NE.' ')GOTO5339
 5330 CONTINUE
 5339 CONTINUE
      IF(NTEMP.LE.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5351)
        CALL DPWRST('XXX','BUG ')
        ILINE2(1:13)='homepage.html'
        NTEMP=13
      ENDIF
 5351 FORMAT('***** WARNING: NO MATCH FOUND, DEFAULT TO DATAPLOT ',
     1'HOME PAGE.')
C
C  ABSOLUTE URL ADDRESS FOUND
C
      IF(ILINE2(1:5).EQ.'http:')THEN
        ICALL(N1URL:N2URL)=' '
        NCSTR=N1URL-1
      ENDIF
C
      NCSTR=NCSTR+1
      NCSTR2=NCSTR+NTEMP-1
      ICALL(NCSTR:NCSTR2)=ILINE2(1:NTEMP)
      NCSTR=NCSTR2
 5349 CONTINUE
      IF(INETSW.EQ.'OLD'.AND.IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        ICALL(NCSTR:NCSTR)=')'
        NCSTR=NCSTR+1
        ICALL(NCSTR:NCSTR)=IQUOTE
      ENDIF
      IF(IHOST1.NE.'IBM-')THEN
        NCSTR=NCSTR+1
        NCSTR2=NCSTR+1
        ICALL(NCSTR:NCSTR2)=' &'
        NCSTR=NCSTR2
      ENDIF
C
      IF(INETSW.EQ.'NEW')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5411)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IF(IHOST1.NE.'IBM-')THEN
          WRITE(ICOUT,5412)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5413)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5414)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5415)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
 5411 FORMAT('*****NOTE: IT MAY TAKE THE BROWSER A FEW MOMENTS TO ',
     1      'START UP.')
 5412 FORMAT('     IF YOU ARE USING THE NETSCAPE BROWSER, YOU CAN ',
     1       'SPEED UP SUBSEQUENT')
 5413 FORMAT('     USE OF WEB HELP BY ENTERING THE FOLLOWING DATAPLOT',
     1       ' COMMAND')
 5414 FORMAT('     (LEAVE THE BROWSER OPEN):')
 5415 FORMAT('         SET NETSCAPE OLD')
CCCCC BUG ON RS-6000.  CLOSE FILE BEFORE CALL DPSYS2.  FEBRUARY 2000.
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
      CALL DPSYS2(ICALL,NCSTR,ISUBRO,IERROR)
      GOTO9000
C
 5390 CONTINUE
C
C               **************************************
C               **  STEP 61--                       **
C               **  CLOSE           THE HELP FILE.  **
C               **************************************
C
 6100 CONTINUE
C
      ISTEPN='61'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IWORD1.EQ.'HOME'.AND.IWOR12.EQ.'PAGE')GOTO6199
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
      IF(IERRFI.EQ.'YES')GOTO9000
 6199 CONTINUE
C
C               ***********************************************
C               **  STEP 62--                                **
C               ** IF PASS 1 AND NOT FOUND IN FILES 1 TO 6,  **
C               ** THEN SCAN SYNONYM FILE FOR MATCH          **
C               ** AND TRY AGAIN IN FILES 1 TO 6             **
C               ***********************************************
C
 6200 CONTINUE
      IF(IPASS.EQ.1.AND.IERROR.EQ.'YES')THEN
         IOUNIT=IHE7NU
         IFILE=IHE7NA
         ISTAT=IHE7ST
         IFORM=IHE7FO
         IACCES=IHE7AC
         IPROT=IHE7PR
         ICURST=IHE7CS
         ISUBN0='HEL2'
         IERRFI='NO'
         IREWIN='ON'
         CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1   IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
         IF(IERRFI.EQ.'YES')GOTO9000
C
         IMATCH=0
         DO6210I=1,5
            READ(IOUNIT,6211)ICJUNK
 6211       FORMAT(A1)
 6210    CONTINUE
         DO6220I=1,10000
            READ(IOUNIT,6221,END=6229)ILINE(1:80)
 6221       FORMAT(A80)
            IF(ILINE(1:4).EQ.IWORD1.AND.ILINE(5:8).EQ.IWOR12)THEN
               IF(ILINE(10:13).EQ.IWORD2)THEN
                  IF(ILINE(15:18).EQ.IWORD3)THEN
                     IF(ILINE(20:23).EQ.IWORD4)THEN
                        IF(ILINE(25:28).EQ.IWORD5)THEN
                          IMATCH=1
                          IWORD1=ILINE(41:44)
                          IWOR12=ILINE(45:48)
                          IWORD2=ILINE(50:53)
                          IWORD3=ILINE(55:58)
                          IWORD4=ILINE(60:63)
                          IWORD5=ILINE(65:68)
                          NUMAR2=5
                          IF(IWORD5.EQ.'    ')NUMAR2=4
                          IF(IWORD4.EQ.'    ')NUMAR2=3
                          IF(IWORD3.EQ.'    ')NUMAR2=2
                          IF(IWORD2.EQ.'    ')NUMAR2=1
                       ENDIF
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
 6220    CONTINUE
 6229    CONTINUE
C
         IENDFI='OFF'
         IREWIN='ON'
         CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1   IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERRO2)
         IF(IERRFI.EQ.'YES')GOTO9000
C
         IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'HELW')THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6231)
 6231       FORMAT('FROM DPHELW AT 6231--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6232)IWORD1,IWOR12,IWORD2,IWORD3,IWORD4
 6232       FORMAT(A4,2X,A4,2X,A4,2X,A4,2X,A4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,6233)NUMAR2,IMATCH
 6233       FORMAT('NUMAR2,IMATCH = ',2I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
         ENDIF
C
         IF(IMATCH.EQ.1)THEN
            IERROR='NO'
            GOTO1000
         ENDIF
      ENDIF
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'HELW')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHELW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGS2,ISUBRO,IERROR,IERRO2
 9012 FORMAT('IBUGS2,ISUBRO,IERROR,IERRO2 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IBUGS2,IFOUND,IERROR
 9028 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IOUNIT
 9031 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IFILE
 9032 FORMAT('IFILE  = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)ISTAT
 9033 FORMAT('ISTAT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IFORM
 9034 FORMAT('IFORM  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IACCES
 9035 FORMAT('IACCES = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)IPROT
 9036 FORMAT('IPROT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)ICURST
 9037 FORMAT('ICURST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)IENDFI
 9038 FORMAT('IENDFI = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IREWIN
 9039 FORMAT('IREWIN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)ISUBN0
 9041 FORMAT('ISUBN0 = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)IERRFI
 9042 FORMAT('IERRFI = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)IWORD1,IWORD2,ICHAR1
 9043 FORMAT('IWORD1,IWORD2,ICHAR1 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9060)ILINE1(1:40),ICTEST,IWORD1,IWOR12
 9060 FORMAT('ILINE1(1:40),ICTEST,IWORD1,IWOR12=',A30,2X,A4,A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)NUMSEC,NUMLIN,ISECNA
 9061 FORMAT('NUMSEC,NUMLIN,ISECNA = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9062)NUMARG,NUMAR2
 9062 FORMAT('NUMARG,NUMAR2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9063)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12
 9063 FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 = ',
     1A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9064)ILINE1(1:40)
 9064 FORMAT('ILINE1(1:40) = ',A40)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9065)IZ1,IZ2,IZ3,IZ4
 9065 FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9066)ISTRIN
 9066 FORMAT('ISTRIN = ',A40)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9067)NUMWHF
 9067 FORMAT('NUMWHF = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9068)ILOC2,ILOC3,ILOC4
 9068 FORMAT('ILOC2,ILOC3,ILOC4 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9069)ILOC2P,ILOC3P,ILOC4P
 9069 FORMAT('ILOC2P,ILOC3P,ILOC4P = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9071)ICHAR1
 9071 FORMAT('ICHAR1 = ',A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9077)I2
 9077 FORMAT('I2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9079)IBUGS2,ISUBRO,IERROR
 9079 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9093)IERROR,IERRO2,IPASS
 9093 FORMAT('IERROR,IERRO2,IPASS = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9094)ILINE
 9094 FORMAT('ILINE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9095)IWORD1,IWOR12,IWORD2
 9095 FORMAT('IWORD1,IWOR12,IWORD2 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9096)IWORD3,IWORD4,IWORD5
 9096 FORMAT('IWORD3,IWORD4,IWORD5 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9097)IBROWS(1:80)
 9097 FORMAT('IBROWS = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9098)IDPURL(1:80)
 9098 FORMAT('IDPURL = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9099)ICALL(1:80)
 9099 FORMAT('ICALL(1:80) = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9101)ICALL(81:160)
 9101 FORMAT('ICALL(81:160) = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9103)ICALL(161:240)
 9103 FORMAT('ICALL(161:240) = ',A80)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHEL1(ICOM,ICOM2,ICOMT,ICOMI,
     1IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IHELSW,
     1IHE1CO,IHE1AL,
     1IHE2CO,IHE2AL,
     1IHE3CO,IHE3AL,
     1IHE4CO,IHE4AL,
     1IHE5CO,IHE5AL,
     1IHE6CO,IHE6AL,
     1IHE7CO,IHE7AL,
     1IHE8CO,IHE8AL,
     1IHE9CO,IHE9AL,
     1IHELCO,IHELAL,
     1IHELMX,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IANS,IWIDTH,IBUGHE,IBUGH2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DETERMINE IF DATAPLOT'S HELP   SYSTEM
C              COMMAND IS BEING INVOKED AND/OR
C              DETERMINE IF A USER'S MENU DESIGNATION IS VALID.
C              THIS SUBROUTINE IN TURN CALLS DPHEL2
C              WHICH READS THE DESIGNATED MENU
C              FROM (ONE OF) DATAPLOT'S HELP   SUB-SYSTEM FILE(S),
C              AND WRITES THE MENU OUT TO SCREEN.
C     INPUT  ARGUMENTS--ICOM ETC.
C     OUTPUT ARGUMENTS--IHELSW, IHELCO, AND IHELAL
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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--FEBRUARY  1985.
C     UPDATED         --JANUARY   1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICOM
      CHARACTER*4 ICOM2
      CHARACTER*4 ICOMT
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IHELSW
C
      CHARACTER*12 IHE1CO
      CHARACTER*4 IHE1AL
C
      CHARACTER*12 IHE2CO
      CHARACTER*4 IHE2AL
C
      CHARACTER*12 IHE3CO
      CHARACTER*4 IHE3AL
C
      CHARACTER*12 IHE4CO
      CHARACTER*4 IHE4AL
C
      CHARACTER*12 IHE5CO
      CHARACTER*4 IHE5AL
C
      CHARACTER*12 IHE6CO
      CHARACTER*4 IHE6AL
C
      CHARACTER*12 IHE7CO
      CHARACTER*4 IHE7AL
C
      CHARACTER*12 IHE8CO
      CHARACTER*4 IHE8AL
C
      CHARACTER*12 IHE9CO
      CHARACTER*4 IHE9AL
C
      CHARACTER*12 IHELCO
      CHARACTER*4 IHELAL
C
      CHARACTER*40 ICPREH
      CHARACTER*40 ICPOSH
C
      CHARACTER*4 IANS
      CHARACTER*4 IBUGHE
      CHARACTER*4 IBUGH2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IH11
      CHARACTER*4 IH12
      CHARACTER*4 IH21
      CHARACTER*4 IH22
C
      CHARACTER*4 IFOSEC
      CHARACTER*4 IHELSV
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
CCCCC INCLUDE 'DPCOFO.INC'
      INCLUDE 'DPCONP.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='DPHE'
      ISUBN2='L1  '
C
      IFOUND='NO'
      IERROR='NO'
C
      IHELAL='OFF'
C
      MAXCPS=12
C
      I2=(-999)
C
      IF(IBUGHE.EQ.'OFF'.AND.ISUBRO.NE.'HEL1')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHEL1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IHELSW
   52 FORMAT('IHELSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IHE1CO,IHE1AL
   61 FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IHE2CO,IHE2AL
   62 FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IHE3CO,IHE3AL
   63 FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IHE4CO,IHE4AL
   64 FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IHE5CO,IHE5AL
   65 FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)IHE6CO,IHE6AL
   66 FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)IHE7CO,IHE7AL
   67 FORMAT('IHE7CO,IHE7AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)IHE8CO,IHE8AL
   68 FORMAT('IHE8CO,IHE8AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IHE9CO,IHE9AL
   69 FORMAT('IHE9CO,IHE9AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)IHELCO,IHELAL
   70 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IWIDTH
   71 FORMAT('IWIDTH = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)(IANS(I),I=1,80)
   72 FORMAT('(IANS(I),I=1,80) = ',80A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IBUGHE,IBUGH2,IERROR
   73 FORMAT('IBUGHE,IBUGH2,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IHELMX
   74 FORMAT('IHELMX = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)NCPREH
   81 FORMAT('NCPREH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO84
      DO82I=1,NCPREH
      WRITE(ICOUT,83)I,ICPREH(I:I)
   83 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   82 CONTINUE
   84 CONTINUE
      WRITE(ICOUT,86)NCPOSH
   86 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO89
      DO87I=1,NCPOSH
      WRITE(ICOUT,88)I,ICPOSH(I:I)
   88 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   87 CONTINUE
   89 CONTINUE
   90 CONTINUE
C
C               **************************************************************
C               **  STEP 11--                                               **
C               **  DETERMINE IF HAVE AN HELP   COMMAND, OR                 **
C               **            IF HAVE A MENU RESPONSE NUMBER TO A MENU, OR  **
C               **            IF HAVE NEITHER.                              **
C               **************************************************************
C
 1100 CONTINUE
      ISTEPN='11'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICOM.EQ.'HELQ')GOTO1200
      IF(ICOM.EQ.'.')GOTO9000
      IF(ICOM.EQ.' ')GOTO9000
CCCCC IF(NUMARG.LE.0.AND.ICOM.EQ.' ')GOTO2100
      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.EQ.0)GOTO2300
      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.GT.0)GOTO1500
      IF(NUMARG.LE.0.AND.ICOMT.EQ.'NUMB'.AND.ICOMI.LT.0)GOTO1600
      GOTO9000
C
C               ***************************************
C               **  STEP 12--                        **
C               **  TREAT THE CASE WHEN HAVE         **
C               **  AN EXPLICIT    HELP     COMMAND  **
C               ***************************************
C
 1200 CONTINUE
      ISTEPN='12'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.LE.0)GOTO2100
      IF(IHARG(1).EQ.'LAST')GOTO2100
      IF(IHARG(1).EQ.'?')GOTO2100
      IF(IHARG(1).EQ.'ALL')IHELAL='ON'
      IF(IHARG(1).EQ.'ALL')GOTO2100
C
      IF(IHARG(1).EQ.'UP')GOTO1300
      IF(IHARG(1).EQ.'PRIO')GOTO1300
      IF(IHARG(1).EQ.'PREV')GOTO1300
      IF(IHARG(1).EQ.'BEFO')GOTO1300
C
      GOTO1400
C
C               ****************************************
C               **  STEP 13  --                       **
C               **  TREAT THE    HELP   UP #    CASE  **
C               ****************************************
C
 1300 CONTINUE
      ISTEPN='13'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IHELCO.EQ.'0           ')IHELSW='TOP'
      IF(IHELCO.EQ.'0           ')GOTO2100
      IF(IHELCO.EQ.'            ')IHELSW='TOP'
      IF(IHELCO.EQ.'            ')GOTO2100
C
      NLOOP=1
      IF(NUMARG.GE.2.AND.IARGT(2).EQ.'NUMB')NLOOP=IARG(2)
      IF(NLOOP.LE.1)NLOOP=1
C
      DO1310ILOOP=1,NLOOP
C
      DO1320I=1,MAXCPS
      IREV=MAXCPS-I+1
      IF(IHELCO(IREV:IREV).EQ.'.')GOTO1325
      IHELCO(IREV:IREV)=' '
 1320 CONTINUE
      GOTO1310
 1325 CONTINUE
      IHELCO(IREV:IREV)=' '
      GOTO1310
C
 1310 CONTINUE
      GOTO2100
C
C               *************************************
C               **  STEP 14--                      **
C               **  TREAT THE    HELP   #    CASE  **
C               *************************************
C
 1400 CONTINUE
      ISTEPN='14'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DATA')GOTO1490
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'GRAP')GOTO1490
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MATH')GOTO1490
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'STAT')GOTO1490
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ENGI')GOTO1490
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BUSI')GOTO1490
      IF(NUMARG.LE.0)GOTO1490
C
      IH11=IHARG(1)
      IH12=IHARG2(1)
      IHELCO(1:4)=IH11(1:4)
      IHELCO(5:8)=IH12(1:4)
      IHELCO(9:12)='    '
C
 1490 CONTINUE
      GOTO2100
C
C               *****************************************
C               **  STEP 15--                          **
C               **  TREAT THE    #    CASE             **
C               **  (AS IN RESPONDING TO A MENU        **
C               **  BY SPECIFYING A MENU ITEM CHOICE)  **
C               *****************************************
C
 1500 CONTINUE
      ISTEPN='15'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IHELSW.EQ.'TOP')IHELCO='0           '
      IF(IHELSW.EQ.'TOP')GOTO2100
C
      IF(IHELCO(1:1).EQ.'0')GOTO1510
      GOTO1520
C
 1510 CONTINUE
      I2=0
      GOTO1530
C
 1520 CONTINUE
      DO1525I=1,MAXCPS
      I2=I
      IF(IHELCO(I2:I2).EQ.' ')GOTO1526
 1525 CONTINUE
      GOTO1539
 1526 CONTINUE
      IHELCO(I2:I2)='.'
      GOTO1530
C
 1530 CONTINUE
      DO1535J=1,4
      I2=I2+1
      IF(I2.GT.MAXCPS)GOTO1539
      IHELCO(I2:I2)=ICOM(J:J)
 1535 CONTINUE
 1539 CONTINUE
      GOTO2100
C
C               *****************************************
C               **  STEP 16--                          **
C               **  TREAT THE   -#    CASE             **
C               **  (AS IN CALLING FOR PRIOR MENUS     **
C               *****************************************
C
 1600 CONTINUE
      ISTEPN='16'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IHELCO.EQ.'0           ')IHELSW='TOP'
      IF(IHELCO.EQ.'0           ')GOTO2100
      IF(IHELCO.EQ.'            ')IHELSW='TOP'
      IF(IHELCO.EQ.'            ')GOTO2100
C
      NLOOP=1
      IF(ICOMT.EQ.'NUMB')NLOOP=(-ICOMI)
C
      IF(NLOOP.LE.0)GOTO1619
      DO1610ILOOP=1,NLOOP
C
      DO1620I=1,MAXCPS
      IREV=MAXCPS-I+1
      IF(IHELCO(IREV:IREV).EQ.'.')GOTO1621
      IHELCO(IREV:IREV)=' '
 1620 CONTINUE
      GOTO1610
 1621 CONTINUE
      IHELCO(IREV:IREV)=' '
      GOTO1610
C
 1610 CONTINUE
C
 1619 CONTINUE
      GOTO2100
C
C               *************************************************
C               **  STEP 17--                                  **
C               **  STRIP OFF TRAILING PERIOD (IF ONE EXISTS)  **
C               *************************************************
C
 1700 CONTINUE
      ISTEPN='17'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1710I=1,MAXCPS
      IREV=MAXCPS-I+1
      IF(IHELCO(IREV:IREV).NE.' ')GOTO1711
 1710 CONTINUE
      GOTO1790
 1711 CONTINUE
      IF(IHELCO(IREV:IREV).EQ.'.')IHELCO(IREV:IREV)=' '
      GOTO1790
 1790 CONTINUE
C
C               *********************************************
C               **  STEP 21--                              **
C               **  BRANCH BETWEEN THE OVERALL MENU        **
C               **  OR THE GENERAL MENU WITHIN EACH AREA.  **
C               *********************************************
C
 2100 CONTINUE
      ISTEPN='21'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IFOUND='YES'
      IF(IHELCO.EQ.'            ')IHELCO='0           '
CCCCC IF(ICOM.EQ.'HELQ'.AND.NUMARG.LE.0)GOTO2200
      IF(ICOM.EQ.'HELQ'.AND.NUMARG.LE.0)GOTO2300
      IF(IHELSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
     1ICOM.EQ.' ')GOTO2200
      IF(IHELSW.EQ.'TOP'.AND.NUMARG.LE.0.AND.
     1ICOMT.EQ.'NUMB'.AND.ICOMI.LE.0)GOTO2200
      GOTO2300
C
C               **********************************************
C               **  STEP 22--                               **
C               **  WRITE (TO THE SCREEN) THE OVERALL MENU  **
C               **********************************************
C
 2200 CONTINUE
      ISTEPN='22'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHELSW='TOP'
C
      WRITE(ICOUT,2211)IESCC,IFFC
 2211 FORMAT(2A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2212)IESCC
 2212 FORMAT(A1,'8')
      CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,2221)
 2221 FORMAT('Enter     HELP HELP       ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2222)
 2222 FORMAT('for a brief description of DATAPLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2223)
 2223 FORMAT('Help Subsystem scope and conventions.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2230)
 2230 FORMAT('     GENERAL TOPIC AREAS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2231)
 2231 FORMAT('      1. Data Analysis (partially implemented)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2232)
 2232 FORMAT('      2. Mathematics   (not yet   implemented)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2233)
 2233 FORMAT('      3. Graphics      (not yet   implemented)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2234)
 2234 FORMAT('      4. DATAPLOT      (not yet   implemented)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2241)
 2241 FORMAT('To select a menu item, enter 1 through 4.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               ****************************************
C               **  STEP 23--                         **
C               **  READ THE HELP   FILE              **
C               **  AND WRITE (TO THE SCREEN) A MENU  **
C               ****************************************
C
 2300 CONTINUE
      ISTEPN='23'
      IF(IBUGHE.EQ.'ON'.OR.ISUBRO.EQ.'HEL1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.LE.0)GOTO2310
C
      IF(NUMARG.EQ.1.AND.IARGT(1).EQ.'NUMB')GOTO2320
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DATA')GOTO2331
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'GRAP')GOTO2332
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'MATH')GOTO2333
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'STAT')GOTO2334
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ENGI')GOTO2335
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'BUSI')GOTO2336
C
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'DATA')GOTO2341
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GRAP')GOTO2342
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MATH')GOTO2343
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'STAT')GOTO2344
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'ENGI')GOTO2345
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BUSI')GOTO2346
C
      GOTO2360
C
C     TREAT THE CASE    HELP
C     WITH NO ARGUMENTS
C
 2310 CONTINUE
      IHELSW='DATA'
      IF(NUMARG.EQ.0)IHELCO='TOPALL      '
      GOTO2400
C
C     TREAT THE CASE LIKE    HELP 4
C
 2320 CONTINUE
CCCCC IF(IHELSW.NE.'TOP')GOTO2360
      IF(IHELCO.NE.'TOP')GOTO2360
      IF(IARG(1).EQ.1)GOTO2331
      IF(IARG(1).EQ.2)GOTO2332
      IF(IARG(1).EQ.3)GOTO2333
      IF(IARG(1).EQ.4)GOTO2334
      IF(IARG(1).EQ.5)GOTO2335
      IF(IARG(1).EQ.6)GOTO2336
      GOTO2360
C
C     TREAT THE 6 CASES WHERE THERE IS ONLY 1 ARGUMENT
C     AND THAT ARGUMENT IS EXPLICTLY ONE OF THE 6--
C     DATA, GRAP, MATH, STAT, ENGI, BUSI
C     (E.G, HELP MATH, HELP ENGINEERING)
C
 2331 CONTINUE
      IHELSW='DATA'
      IHELCO='TOP         '
      GOTO2400
 2332 CONTINUE
      IHELSW='GRAP'
      IHELCO='TOP         '
      GOTO2400
 2333 CONTINUE
      IHELSW='MATH'
      IHELCO='TOP         '
      GOTO2400
 2334 CONTINUE
      IHELSW='STAT'
      IHELCO='TOP         '
      GOTO2400
 2335 CONTINUE
      IHELSW='ENGI'
      IHELCO='TOP         '
      GOTO2400
 2336 CONTINUE
      IHELSW='BUSI'
      IHELCO='TOP         '
      GOTO2400
C
C     TREAT THE 6 CASES WHERE THERE ARE 2 OR MORE ARGUMENT
C     AND THE FIRST ARGUMENT IS EXPLICTLY ONE OF THE 6--
C     DATA, GRAP, MATH, STAT, ENGI, BUSI
C     (E.G, HELP MATH GOODIES, HELP ENGINEERING TOPICS)
C
 2341 CONTINUE
      IHELSW='DATA'
      GOTO2349
 2342 CONTINUE
      IHELSW='GRAP'
      GOTO2349
 2343 CONTINUE
      IHELSW='MATH'
      GOTO2349
 2344 CONTINUE
      IHELSW='STAT'
      GOTO2349
 2345 CONTINUE
      IHELSW='ENGI'
      GOTO2349
 2346 CONTINUE
      IHELSW='BUSI'
      GOTO2349
 2349 CONTINUE
      IH21=IHARG(2)
      IH22=IHARG2(2)
      IHELCO(1:4)=IH21(1:4)
      IHELCO(5:8)=IH22(1:4)
      GOTO2400
C
 2360 CONTINUE
      IH11=IHARG(1)
      IH12=IHARG2(1)
      IHELCO(1:4)=IH11(1:4)
      IHELCO(5:8)=IH12(1:4)
      GOTO2400
C
 2400 CONTINUE
C
      CALL DPHEL2(IHELSW,
     1IHELCO,IHELAL,
     1IHELMX,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IFOSEC,
     1IANS,IWIDTH,IBUGH2,ISUBRO,IFOUND,IERROR)
      IF(IFOSEC.EQ.'NO')GOTO2410
      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
      GOTO9000
C
C     THE FOLLOWING SECTION IS EXECUTED ONLY IF
C     THE KEYWORD WAS NOT FOUND IN THE
C     CURRENT PRIMARY FILE.
C     IN SUCH CASE, LOOK IN OTHER FILES FOR
C     THE KEYWORD.
C
 2410 CONTINUE
      IHELSV=IHELSW
      DO2420I=1,6
      IF(I.EQ.1)IHELSW='DATA'
      IF(I.EQ.2)IHELSW='GRAP'
      IF(I.EQ.3)IHELSW='MATH'
      IF(I.EQ.4)IHELSW='STAT'
      IF(I.EQ.5)IHELSW='ENGI'
      IF(I.EQ.6)IHELSW='BUSI'
      CALL DPHEL2(IHELSW,
     1IHELCO,IHELAL,
     1IHELMX,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IFOSEC,
     1IANS,IWIDTH,IBUGH2,ISUBRO,IFOUND,IERROR)
      IF(IFOSEC.EQ.'NO')GOTO2420
      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
      GOTO9000
 2420 CONTINUE
      IHELSW=IHELSV
      IF(IHELSW.EQ.'DATA')IHE1CO=IHELCO
      IF(IHELSW.EQ.'MATH')IHE2CO=IHELCO
      IF(IHELSW.EQ.'GRAP')IHE3CO=IHELCO
      IF(IHELSW.EQ.'STAT')IHE4CO=IHELCO
      IF(IHELSW.EQ.'ENGI')IHE5CO=IHELCO
      IF(IHELSW.EQ.'BUSI')IHE6CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE7CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE8CO=IHELCO
      IF(IHELSW.EQ.'XXXX')IHE9CO=IHELCO
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2421)
 2421 FORMAT('***** ERROR IN DPHEL1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2422)IHELCO(1:4),IHELCO(5:8)
 2422 FORMAT('      NO HELP INFORMATION FOUND FOR ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2423)
 2423 FORMAT('      ANYWHERE UNDER THE 6 HELP CATEGORIES.')
      CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'TOP')WRITE(ICOUT,2430)
 2430 FORMAT('      CURRENT CATEGORY = ABOVE ALL 6')
      IF(IHELSW.EQ.'TOP')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'DATA')WRITE(ICOUT,2431)
 2431 FORMAT('      CURRENT CATEGORY = DATAPLOT')
      IF(IHELSW.EQ.'DATA')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'GRAP')WRITE(ICOUT,2432)
 2432 FORMAT('      CURRENT CATEGORY = GRAPHICS')
      IF(IHELSW.EQ.'GRAP')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'MATH')WRITE(ICOUT,2433)
 2433 FORMAT('      CURRENT CATEGORY = MATHEMATICS')
      IF(IHELSW.EQ.'MATH')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'STAT')WRITE(ICOUT,2434)
 2434 FORMAT('      CURRENT CATEGORY = STATISTICS/PROBABILITY')
      IF(IHELSW.EQ.'STAT')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'ENGI')WRITE(ICOUT,2435)
 2435 FORMAT('      CURRENT CATEGORY = ENGINEERING/SCIENCE')
      IF(IHELSW.EQ.'ENGI')CALL DPWRST('XXX','BUG ')
      IF(IHELSW.EQ.'BUSI')WRITE(ICOUT,2436)
 2436 FORMAT('      CURRENT CATEGORY = BUSINESS/ECONOMICS')
      IF(IHELSW.EQ.'BUSI')CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGHE.EQ.'OFF'.AND.ISUBRO.NE.'HEL1')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHEL1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IHELSW
 9012 FORMAT('IHELSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IHE1CO,IHE1AL
 9031 FORMAT('IHE1CO,IHE1AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IHE2CO,IHE2AL
 9032 FORMAT('IHE2CO,IHE2AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IHE3CO,IHE3AL
 9033 FORMAT('IHE3CO,IHE3AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IHE4CO,IHE4AL
 9034 FORMAT('IHE4CO,IHE4AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IHE5CO,IHE5AL
 9035 FORMAT('IHE5CO,IHE5AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)IHE6CO,IHE6AL
 9036 FORMAT('IHE6CO,IHE6AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)IHE7CO,IHE7AL
 9037 FORMAT('IHE7CO,IHE7AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9038)IHE8CO,IHE8AL
 9038 FORMAT('IHE8CO,IHE8AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9039)IHE9CO,IHE9AL
 9039 FORMAT('IHE9CO,IHE9AL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9040)IHELCO,IHELAL
 9040 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9049)IBUGHE,IBUGH2,IFOUND,IERROR
 9049 FORMAT('IBUGHE,IBUGH2,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)IHELMX
 9054 FORMAT('IHELMX = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)IFOSEC
 9055 FORMAT('IFOSEC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9081)NCPREH
 9081 FORMAT('NCPREH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO9084
      DO9082I=1,NCPREH
      WRITE(ICOUT,9083)I,ICPREH(I:I)
 9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9082 CONTINUE
 9084 CONTINUE
      WRITE(ICOUT,9086)NCPOSH
 9086 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO9089
      DO9087I=1,NCPOSH
      WRITE(ICOUT,9088)I,ICPOSH(I:I)
 9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9087 CONTINUE
 9089 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHEL2(IHELSW,
     1IHELCO,IHELAL,
     1IHELMX,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IFOSEC,
     1IANS,IWIDTH,IBUGH3,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--READ THE DESIGNATED SECTION
C              FROM (ONE OF) DATAPLOT'S HELP SUB-SYSTEM FILE(S),
C              AND WRITE THE SECTION CONTENTS OUT TO SCREEN.
C     INPUT  ARGUMENTS--IHELSW (A HOLLARITH VARIABLE
C                       IDENTIFYING WHICH SUB-SYSTEM.
C                     --IHELCO (A HOLLARITH VARIABLE
C                       CONTAINING A SECTION IDENTIFICATION STRING.
C                     --IHELAL (A HOLLARITH VARIABLE (ON/OFF)
C                       CONTAINING A SWITCH SETTING AS TO WHETHER
C                       ALL OF THE TOPIC SECTION SHOULD BE PRINTED OUT.
C     OUTPUT ARGUMENTS--IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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--FEBRAURY  1985.
C     UPDATED         --JANUARY   1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHELSW
      CHARACTER*12 IHELCO
      CHARACTER*4 IHELAL
      CHARACTER*40 ICPREH
      CHARACTER*40 ICPOSH
C
      CHARACTER*4 IFOSEC
C
      CHARACTER*4 IANS
      CHARACTER*4 IBUGH3
      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 ISUBN0
      CHARACTER*4 IERRFI
      CHARACTER*4 IENDFI
      CHARACTER*4 IREWIN
C
      CHARACTER*12 ITABID
C
      CHARACTER*80 ICTEXT
C
      CHARACTER*12 ITABII
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 ICRESP
C
      DIMENSION ITABID(500)
      DIMENSION ITABLN(500)
C
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
CCCCC INCLUDE 'DPCOFO.INC'
      INCLUDE 'DPCOF2.INC'
      INCLUDE 'DPCONP.INC'
CCCCC TEH FOLLOWING LINE WAS ADDED   JUNE 1993
      INCLUDE 'DPCODV.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
      NUMSEC=(-999)
      JSEC=(-999)
      ISKIP=(-999)
      ISTART=(-999)
      I2=(-999)
      ITABII='-99999999999'
C
      IFOUND='YES'
      IERROR='NO'
C
      ISUBN1='DPHE'
      ISUBN2='L2  '
C
      IFOSEC='-999'
      ICRESP='-999'
C
      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHEL2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IHELSW
   52 FORMAT('IHELSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IHELCO,IHELAL
   53 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IHELMX
   54 FORMAT('IHELMX = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IBUGH3,ISUBRO,IERROR
   55 FORMAT('IBUGH3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IFOSEC
   56 FORMAT('IFOSEC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)NCPREH
   81 FORMAT('NCPREH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO84
      DO82I=1,NCPREH
      WRITE(ICOUT,83)I,ICPREH(I:I)
   83 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   82 CONTINUE
   84 CONTINUE
      WRITE(ICOUT,86)NCPOSH
   86 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO89
      DO87I=1,NCPOSH
      WRITE(ICOUT,88)I,ICPOSH(I:I)
   88 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   87 CONTINUE
   89 CONTINUE
   90 CONTINUE
C
C               **************************
C               **  STEP 11--           **
C               **  COPY OVER VARIABLES **
C               **************************
C
      ISTEPN='11'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IHELSW.EQ.'TOP')GOTO1110
      IF(IHELSW.EQ.'DATA')GOTO1110
      IF(IHELSW.EQ.'GRAP')GOTO1120
      IF(IHELSW.EQ.'MATH')GOTO1130
      IF(IHELSW.EQ.'STAT')GOTO1140
      IF(IHELSW.EQ.'ENGI')GOTO1150
      IF(IHELSW.EQ.'BUSI')GOTO1160
      IF(IHELSW.EQ.'XXXX')GOTO1170
      IF(IHELSW.EQ.'XXXX')GOTO1180
      IF(IHELSW.EQ.'XXXX')GOTO1190
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1101)
 1101 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
     1'AT BRANCH POINT 1101--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1102)
 1102 FORMAT('      IHELSW SHOULD BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1103)
 1103 FORMAT('      DATA, GRAP, MATH, STAT, ENGI, OR BUSI, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1104)
 1104 FORMAT('      BUT IS NOT.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1105)IHELSW
 1105 FORMAT('      IHELSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1110 CONTINUE
      IOUNIT=IHE1NU
      IFILE=IHE1NA
      ISTAT=IHE1ST
      IFORM=IHE1FO
      IACCES=IHE1AC
      IPROT=IHE1PR
      ICURST=IHE1CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1120 CONTINUE
      IOUNIT=IHE2NU
      IFILE=IHE2NA
      ISTAT=IHE2ST
      IFORM=IHE2FO
      IACCES=IHE2AC
      IPROT=IHE2PR
      ICURST=IHE2CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1130 CONTINUE
      IOUNIT=IHE3NU
      IFILE=IHE3NA
      ISTAT=IHE3ST
      IFORM=IHE3FO
      IACCES=IHE3AC
      IPROT=IHE3PR
      ICURST=IHE3CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1140 CONTINUE
      IOUNIT=IHE4NU
      IFILE=IHE4NA
      ISTAT=IHE4ST
      IFORM=IHE4FO
      IACCES=IHE4AC
      IPROT=IHE4PR
      ICURST=IHE4CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1150 CONTINUE
      IOUNIT=IHE5NU
      IFILE=IHE5NA
      ISTAT=IHE5ST
      IFORM=IHE5FO
      IACCES=IHE5AC
      IPROT=IHE5PR
      ICURST=IHE5CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1160 CONTINUE
      IOUNIT=IHE6NU
      IFILE=IHE6NA
      ISTAT=IHE6ST
      IFORM=IHE6FO
      IACCES=IHE6AC
      IPROT=IHE6PR
      ICURST=IHE6CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1170 CONTINUE
      IOUNIT=IHE7NU
      IFILE=IHE7NA
      ISTAT=IHE7ST
      IFORM=IHE7FO
      IACCES=IHE7AC
      IPROT=IHE7PR
      ICURST=IHE7CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1180 CONTINUE
      IOUNIT=IHE8NU
      IFILE=IHE8NA
      ISTAT=IHE8ST
      IFORM=IHE8FO
      IACCES=IHE8AC
      IPROT=IHE8PR
      ICURST=IHE8CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1190 CONTINUE
      IOUNIT=IHE9NU
      IFILE=IHE9NA
      ISTAT=IHE9ST
      IFORM=IHE9FO
      IACCES=IHE9AC
      IPROT=IHE9PR
      ICURST=IHE9CS
      ISUBN0='HEL2'
      IERRFI='NO'
      GOTO1191
C
 1191 CONTINUE
      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')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)IBUGH3,ISUBRO,ISUBN0,IERRFI
 1196 FORMAT('IBUGH3,ISUBRO,ISUBN0,IERRFI = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  CHECK TO SEE IF THIS HELP   FILE EXISTS  **
C               ***********************************************
C
      ISTEPN='12'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     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 DPHEL2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      THE HELP SUB-SYSTEM')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      CANNOT BE ENTERED FOR THIS TOPIC 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 HELP INFORMATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)
 1216 FORMAT('      IS NOT YET AVAILABLE FOR THIS TOPIC.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)ISTAT,IHELSW
 1217 FORMAT('ISTAT,IHELSW = ',A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1290 CONTINUE
C
C               *********************
C               **  STEP 20--      **
C               **  OPEN THE FILE  **
C               *********************
C
      ISTEPN='20'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IREWIN='ON'
      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IREWIN,ISUBN0,IERRFI,IBUGH3,ISUBRO,IERROR)
      IF(IERRFI.EQ.'YES')GOTO9000
C
C               ************************************************************
C               **  STEP 41--                                             **
C               **  READ IN FILE INFORMATION                              **
C               **  FROM THE BEGINNING LINES OF THE FILE.                 **
C               **  THESE LEAD LINES CONTAIN                              **
C               **  THE STARTING LINE NUMBER OF EACH SECTION              **
C               **  IN THE FILE (ATABLN)   (F10.0 FORMAT), AND            **
C               **  THE IDENTIFIER          FOR EACH SECTION              **
C               **  IN THE FILE (ITABID(.) (A12 FORMAT).                  **
C               ************************************************************
C
      READ(IOUNIT,4101,END=4110)
 4101 FORMAT()
      READ(IOUNIT,4101,END=4110)
      GOTO4119
 4110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4111)
 4111 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
     1'AT BRANCH POINT 4111--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4112)
 4112 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4113)
 4113 FORMAT('      WHILE CARRYING OUT THE SKIP OF 2 LINES AT THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4114)
 4114 FORMAT('      BEGINNING OF ONE OF THE DATAPLOT HELP FILES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4115)IFILE
 4115 FORMAT('      IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 4119 CONTINUE
C
      NUMSEC=0
      DO4120I=1,100000
      READ(IOUNIT,4121,END=4180)ATABLN,ITABID(I)
 4121 FORMAT(F10.0,A12)
      IF(ITABID(I).EQ.'            ')GOTO4129
      NUMSEC=NUMSEC+1
      ITABLN(I)=ATABLN+0.5
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1WRITE(ICOUT,4122)I,ATABLN,ITABLN(I),ITABID(I)
 4122 FORMAT('I,ATABLN,ITABLN(I),ITABID(I) = ',I8,E15.7,I8,2X,A12)
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL DPWRST('XXX','BUG ')
 4120 CONTINUE
 4129 CONTINUE
      ANUMSE=NUMSEC
      GOTO4190
C
 4180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4181)
 4181 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
     1'AT BRANCH POINT 4181--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4182)
 4182 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4183)
 4183 FORMAT('      WHILE READING THE LOOK-UP TABLE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4184)
 4184 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4185)IFILE
 4185 FORMAT('      IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 4190 CONTINUE
C
C               *******************************************************
C               **  STEP 42--                                        **
C               **  BASED ON THE CODE STRING IN IHELCO               **
C               **  DO A TABLE LOOK-UP WHICH WILL SPECIFY            **
C               **  THE ABSOLUTE LINE NUMBER IN THE FILE             **
C               **  WHERE THE SECTION WITH THAT CODE WORD STARTS     **
C               *******************************************************
C
      ISTEPN='42'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO4200I=1,NUMSEC
      I2=I
      ITABII=ITABID(I)
      IF(IHELCO(1:4).EQ.ITABII(1:4))GOTO4210
 4200 CONTINUE
CCCCC JSEC=1
      IFOSEC='NO'
      GOTO9000
 4210 CONTINUE
      IFOSEC='YES'
      JSEC=I2
C
      ISTART=ITABLN(JSEC)
C
      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO4290
      WRITE(ICOUT,4211)
 4211 FORMAT('***** FROM 4211 IN MIDDLE OF DPHEL2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4213)JSEC,ISTART
 4213 FORMAT('JSEC,ISTART = ',2I8)
      CALL DPWRST('XXX','BUG ')
 4290 CONTINUE
C
C               *************************************************
C               **  STEP 43--                                  **
C               **  READ DOWN IN THE FILE TO                   **
C               **  THE LINE BEFORE WHERE THE SECTION STARTS   **
C               *************************************************
C
      ISTEPN='43'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      REWIND(IOUNIT)
C
      ISKIP=ISTART-1
      IF(ISKIP.LE.0)GOTO4319
      DO4310I=1,ISKIP
      READ(IOUNIT,4315,END=4380)
 4315 FORMAT()
 4310 CONTINUE
 4319 CONTINUE
      GOTO4390
C
 4380 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4381)
 4381 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
     1'AT BRANCH POINT 4381--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4382)
 4382 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4383)
 4383 FORMAT('      WHILE CARRYING OUT SKIPS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4384)
 4384 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4385)IFILE
 4385 FORMAT('      IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 4390 CONTINUE
C
C               ***************************************************
C               **  STEP 45--                                    **
C               **  FOR THIS TARGET SECTION--                    **
C               **     1) SKIP OVER 2 HEADER LINES               **
C               **     2) READ IN (AND WRITE OUT) THE TEXT       **
C               **        FOR THE SECTION--                      **
C               **        (THIS IS WHAT THE ANALYST WILL SEE     **
C               **        ON THE SCREEN).                        **
C               **        THE LAST LINE OF THE TEXT IS           **
C               **        A LINE OF HYPHENS (THIS LINE IS        **
C               **        NOT PRINTED OUT).                      **
C               **     3) READ IN (AND STORE) THE NUMBER OF      **
C               **        MENU ITEMS THAT WERE OFFERED           **
C               **     4) READ IN (AND STORE) THE CODE WORD      **
C               **        (= SUBSEQUENT BRANCH POINT)            **
C               **        FOR EACH MENU ITEM                     **
C               ***************************************************
C
      ISTEPN='45'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      READ(IOUNIT,4505,END=4580)
 4505 FORMAT()
      READ(IOUNIT,4505,END=4580)
C
CCCCC WRITE(ICOUT,4511)IESCC,IFFC
C4511 FORMAT(2A1)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,4512)IESCC
C4512 FORMAT(A1,'8')
CCCCC CALL DPWRST('XXX','BUG ')
C
CCCCC WRITE(ICOUT,4513)IHELCO
C4513 FORMAT(58X,A12)
CCCCC CALL DPWRST('XXX','BUG ')
C
      NUMLPR=0
      IF(NCPREH.LE.0)GOTO4519
      WRITE(ICOUT,4511)(ICPREH(J:J),J=1,NCPREH)
 4511 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
 4519 CONTINUE
C
      DO4520I=1,100000
C
      READ(IOUNIT,4521,END=4580)ICTEXT
 4521 FORMAT(A80)
CCCCC IF(ICTEXT(1:5).EQ.'SSSSS')GOTO4590   DECEMBER 1986
CCCCC IF(ICTEXT(1:5).EQ.'EEEEE')GOTO4590   DECEMBER 1986
      IF(ICTEXT(1:5).EQ.'-----')GOTO4590
      IF(ICTEXT(1:5).EQ.'.....')GOTO4590
C
      IF(NUMLPR.LT.IHELMX)GOTO4529
CCCCC THE FOLLOWING LINE WAS ADDED  JUNE 1993
      IF(TCMENU.EQ.'ON')GOTO4529
      WRITE(ICOUT,4522)
 4522 FORMAT('                                      MORE...')
      CALL DPWRST('XXX','BUG ')
      READ(IRD,4523)ICRESP
 4523 FORMAT(A4)
      IF(ICRESP.EQ.'STOP')GOTO4590
      IF(ICRESP.EQ.'stop')GOTO4590
      IF(ICRESP.EQ.'HALT')GOTO4590
      IF(ICRESP.EQ.'halt')GOTO4590
      IF(ICRESP.EQ.'EXIT')GOTO4590
      IF(ICRESP.EQ.'exit')GOTO4590
      IF(ICRESP.EQ.'END')GOTO4590
      IF(ICRESP.EQ.'end')GOTO4590
      IF(ICRESP.EQ.'QUIT')GOTO4590
      IF(ICRESP.EQ.'quit')GOTO4590
      IF(ICRESP.EQ.'BYE')GOTO4590
      IF(ICRESP.EQ.'bye')GOTO4590
      IF(ICRESP.EQ.'NO')GOTO4590
      IF(ICRESP.EQ.'no')GOTO4590
      NUMLPR=0
      IF(NCPREH.LE.0)GOTO4527
      WRITE(ICOUT,4526)(ICPREH(J:J),J=1,NCPREH)
 4526 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
 4527 CONTINUE
 4529 CONTINUE
C
      DO4530J=1,80
      JREV=80-J+1
      IF(ICTEXT(JREV:JREV).NE.' ')GOTO4535
 4530 CONTINUE
      JREV=1
 4535 CONTINUE
      IF(JREV.LE.0)WRITE(ICOUT,999)
      IF(JREV.LE.0)CALL DPWRST('XXX','BUG ')
      IF(JREV.GE.1)WRITE(ICOUT,4536)(ICTEXT(K:K),K=1,JREV)
C4536 FORMAT(80A1)
      IF(JREV.GE.1)CALL DPWRST('XXX','BUG ')
 4536 FORMAT(1H ,80A1)
      NUMLPR=NUMLPR+1
C
 4520 CONTINUE
C
 4580 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4581)
 4581 FORMAT('***** INTERNAL ERROR IN DPHEL2 ',
     1'AT BRANCH POINT 4581--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4582)
 4582 FORMAT('      AN UNEXPECTED END OF FILE WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4583)
 4583 FORMAT('      WHILE READING WITHIN THE TARGET SECTION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4584)
 4584 FORMAT('      WITHIN ONE OF THE DATAPLOT HELP FILES.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4585)IFILE
 4585 FORMAT('      IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4586)JSEC,ISTART
 4586 FORMAT('JSEC,ISTART = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO5000
 4589 CONTINUE
C
 4590 CONTINUE
C
      IF(NCPOSH.LE.0)GOTO4599
      WRITE(ICOUT,4591)(ICPOSH(J:J),J=1,NCPOSH)
 4591 FORMAT(80A1)
      CALL DPWRST('XXX','BUG ')
 4599 CONTINUE
C
C               **************************************
C               **  STEP 50--                       **
C               **  CLOSE        THIS HELP   FILE.  **
C               **************************************
C
 5000 CONTINUE
C
      ISTEPN='50'
      IF(IBUGH3.EQ.'ON'.OR.ISUBRO.EQ.'HEL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IENDFI='OFF'
      IREWIN='ON'
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGH3,ISUBRO,IERROR)
      IF(IERRFI.EQ.'YES')GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGH3.EQ.'OFF'.AND.ISUBRO.NE.'HEL2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHEL2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGH3,ISUBRO,IERROR
 9012 FORMAT('IBUGH3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFOSEC
 9013 FORMAT('IFOSEC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IHELMX,NUMLPR
 9014 FORMAT('IHELMX,NUMLPR = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ICRESP
 9015 FORMAT('ICRESP = ',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 ')
      WRITE(ICOUT,9051)ISKIP,ISTART,I2
 9051 FORMAT('ISKIP,ISTART,I2 = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)IHELSW
 9052 FORMAT('IHELSW = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)IHELCO,IHELAL
 9054 FORMAT('IHELCO,IHELAL = ',A12,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)NUMSEC
 9061 FORMAT('NUMSEC = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9062)JSEC,ITABLN(JSEC),ITABID(JSEC)
 9062 FORMAT('JSEC,ITABLN(JSEC),ITABID(JSEC) = ',2I8,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9063)ITABII
 9063 FORMAT('ITABII = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9081)NCPREH
 9081 FORMAT('NCPREH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREH.LE.0)GOTO9084
      DO9082I=1,NCPREH
      WRITE(ICOUT,9083)I,ICPREH(I:I)
 9083 FORMAT('I,ICPREH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9082 CONTINUE
 9084 CONTINUE
      WRITE(ICOUT,9086)NCPOSH
 9086 FORMAT('NCPOSH = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOSH.LE.0)GOTO9089
      DO9087I=1,NCPOSH
      WRITE(ICOUT,9088)I,ICPOSH(I:I)
 9088 FORMAT('I,ICPOSH(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9087 CONTINUE
 9089 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHEX2(X1,Y1,X2,Y2,
     1IFIG,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
C
C     PURPOSE--DRAW A HEXAGON
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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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
C-----NON-COMMON VARIABLES-------------------------------------
C
      CHARACTER*4 IFIG
      CHARACTER*4 IPATT2
C
      CHARACTER*4 ILINPA
      CHARACTER*4 ILINCO
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 ILINPA(*)
      DIMENSION ILINCO(*)
      DIMENSION PLINTH(*)
C
      DIMENSION AREGBA(*)
      DIMENSION IREBLI(*)
      DIMENSION IREBCO(*)
      DIMENSION PREBTH(*)
      DIMENSION IREFSW(*)
      DIMENSION IREFCO(*)
      DIMENSION IREPTY(*)
      DIMENSION IREPLI(*)
      DIMENSION IREPCO(*)
      DIMENSION PREPTH(*)
      DIMENSION PREPSP(*)
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.'HEX2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHEX2--')
      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)ILINPA(1),ILINCO(1),PLINTH(1)
   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(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 HEXAGON            **
C               *********************************
C
      DELX=X2-X1
      DELY=Y2-Y1
      LEN=SQRT((X2-X1)**2+(Y2-Y1)**2)
      ALEN=LEN
      R=ALEN/2.0
      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
C
      K=0
C
      X=0.0
      Y=0.0
      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
      K=K+1
      PX(K)=XP
      PY(K)=YP
C
      DO3010I=181,541,60
      IREV=541-I+181
      PHI2=IREV-1
      PHI2=PHI2*(2.0*3.1415926)/360.0
      X=R*COS(PHI2)+R
      Y=R*SIN(PHI2)
      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
      K=K+1
      PX(K)=XP
      PY(K)=YP
 3010 CONTINUE
C
      NP=K
C
C               ***********************
C               **  STEP 2--         **
C               **  FILL THE FIGURE  **
C               **  (IF CALLED FOR)  **
C               ***********************
C
      IF(IREFSW(1).EQ.'OFF')GOTO2190
      IPATT=IREPTY(1)
      IPATT2='SOLI'
      PTHICK=PREPTH(1)
      PXGAP=PREPSP(1)
      PYGAP=PREPSP(1)
      ICOLF=IREFCO(1)
      ICOLP=IREPCO(1)
      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=ILINPA(1)
      PTHICK=PLINTH(1)
      ICOL=ILINCO(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
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'HEX2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NP
 9014 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
      SUBROUTINE DPHEXA(IHARG,IARGT,ARG,NUMARG,
     1PXSTAR,PYSTAR,
     1PXEND,PYEND,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     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 HEXAGONS
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 DIAGONAL ENDS
C           OF THE HEXAGON.
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 HEXAGON 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 HEXAGON 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 HEXAGON 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                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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         --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 ILINPA
      CHARACTER*4 ILINCO
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 ILINPA(*)
      DIMENSION ILINCO(*)
      DIMENSION PLINTH(*)
C
      DIMENSION AREGBA(*)
      DIMENSION IREBLI(*)
      DIMENSION IREBCO(*)
      DIMENSION PREBTH(*)
      DIMENSION IREFSW(*)
      DIMENSION IREFCO(*)
      DIMENSION IREPTY(*)
      DIMENSION IREPLI(*)
      DIMENSION IREPCO(*)
      DIMENSION PREPTH(*)
      DIMENSION PREPSP(*)
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.'HEXA')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHEXA--')
      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)ILINPA(1),ILINCO(1),PLINTH(1)
   61 FORMAT('ILINPA(1),ILINCO(1),PLINTH(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='HEXA'
      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 DPHEXA--')
      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 HEXAGON ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)
 1136 FORMAT('      WITH ONE POINT AT THE POINT 20 20 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1137)
 1137 FORMAT('      AND WITH OPPOSITE POINT 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('      HEXAGON 20 20 40 60 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      HEXAGON 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 DPHEX2(X1,Y1,X2,Y2,
     1IFIG,
     1ILINPA,ILINCO,PLINTH,
     1AREGBA,
     1IREBLI,IREBCO,PREBTH,
     1IREFSW,IREFCO,
     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     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.'HEXA')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHEXA--')
      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 DPHIS2(Y,X,N,ICASPL,IRELAT,IDATSW,CLWID,XSTART,XSTOP,
CCCCC MARCH 1996.  ADD FOLLOWING LINE
     1XTEMP1,MAXOBV,
     1IRHSTG,IHSTCW,IASHWT,M,
     1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE
C                   1) A HISTOGRAM,
C                   2) A RELATIVE HISTOGRAM
C                      (THAT IS, WITH AREA = 1).
C                   3) A CUMULATIVE HISTOGRAM
C                   4) A RELATIVE CUMULATIVE HISTOGRAM
C                      (THAT IS, WITH MAX BAR HEIGHT = 1).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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     1978.
C     UPDATED         --MAY       1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --MARCH     1979.
C     UPDATED         --APRIL     1979.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --APRIL     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1988.  (RELATIVE HISTOGRAM AREA CORRECTION)
C     UPDATED         --JANUARY   1989.  DOUBLE PRECISION (MANY PLACES)
C     UPDATED         --JUNE      1994.  FIX RELATIVE HIST AREA
C     UPDATED         --MARCH     1996.  FIX RELATIVE HIST AREA BASED
C                                        ON IRHSTG SWITCH.
C     UPDATED         --DECEMBER  1999.  CHECK FOR POINTS OUTSIDE INTERVAL
C     UPDATED         --SEPTEMBER 2004.  SUPPORT FOR ALTERNATIVE
C                                        CLASS WIDTH ALGORITHMS
C                                        (IHSTCW)
C     UPDATED         --SEPTEMBER 2004.  SUPPORT FOR "AVERAGE SHIFTED
C                                        HISTOGRAM" (IASHWT)
C     UPDATED         --SEPTEMBER 2005.  NO ERROR IF ALL ELEMENTS THE
C                                        SAME
C     UPDATED         --NOVEMBER  2005.  FIX BUG INTRODUCED BY 9/2005
C                                        UPDATE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IRELAT
      CHARACTER*4 IDATSW
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
CCCCC MARCH 1996.  ADD FOLLOWING LINE
      CHARACTER*4 IRHSTG
      CHARACTER*4 IHSTCW
      CHARACTER*4 IASHWT
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 DDELI
      DOUBLE PRECISION DABSDE
      DOUBLE PRECISION DTOTWI
      DOUBLE PRECISION DD21
      DOUBLE PRECISION DD2N
      DOUBLE PRECISION DBETA
CCCCC DOUBLE PRECISION DBAMNJ
CCCCC DOUBLE PRECISION DBAMXJ
C
      EXTERNAL DBETA
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D2(*)
      DIMENSION XTEMP1(*)
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
      DATA PI /3.141593/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPHI'
      ISUBN2='S2  '
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.LT.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,31)
   31   FORMAT('***** ERROR IN DPHIS2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
   32   FORMAT('      THE NUMBER OF OBSERVATIONS 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
      ENDIF
C
CCCCC IF(N.GE.2)GOTO49
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,46)
CCC46 FORMAT('***** ERROR IN DPHIS2--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,47)
CCC47 FORMAT('      THE NUMBER OF OBSERVATIONS')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,48)
CCC48 FORMAT('      WAS EXACTLY EQUAL TO 1.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC IERROR='YES'
CCCCC GOTO9000
CCC49 CONTINUE
C
CCCCC SEPTEMBER 2005.  IF ALL ELEMENTS THE SAME, THEN PRINT WARNING
CCCCC                  AND HANDLE AS A SPECIAL CASE.
C
      HOLD=X(1)
      DO60I=1,N
        IF(X(I).NE.HOLD)GOTO69
   60 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)
   61 FORMAT('***** WARNING IN DPHIS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)
   62 FORMAT('      ALL INPUT HORIZONTAL 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 ')
CCCCC NOVEMBER 2005.  MOVE THIS LINE SINCE SECTION BELOW IS
CCCCC                 SPECIFICALLY FOR CASE WHERE ALL ELEMENTS
CCCCC                 ARE IDENTICAL.
CCC69 CONTINUE
C
      IF(IDATSW.EQ.'RAW')THEN
        N2=3
        X2(1)=HOLD-1.0
        X2(2)=HOLD
        X2(3)=HOLD+1.0
        IF(IRELAT.EQ.'ON')THEN
          Y2(1)=0.0
          Y2(2)=1.0
          Y2(3)=0.0
        ELSE
          Y2(1)=0.0
          Y2(2)=REAL(N)
          Y2(3)=0.0
        ENDIF
        NPLOTV=2
        GOTO9000
      ENDIF
C
   69 CONTINUE
C
      IF(IBUGG3.EQ.'OFF')GOTO80
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)
   70 FORMAT('***** AT THE BEGINNING OF DPHIS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IDATSW
   71 FORMAT('IDATSW = ',A4)
      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),X(I)
   74 FORMAT('I, Y(I), X(I) = ',I8,2E15.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
      IF(IDATSW.EQ.'RAW')GOTO110
      IF(IDATSW.EQ.'FREQ')GOTO150
C
  110 CONTINUE
      IF(ICASPL.EQ.'ASHR')THEN
        CALL DPBINA(X,N,CLWID,XSTART,XSTOP,M,
     1              XTEMP1,MAXOBV,
     1              IRELAT,IASHWT,IHSTCW,
     1              Y2,X2,N2,IBUGG3,IERROR)
        DO112I=1,N2
          D2(I)=1.0
  112   CONTINUE
        GOTO9000
      ELSE
        IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR.
     1     XSTOP.EQ.CPUMAX)THEN
           IWRIT2='OFF'
           CALL MEAN(X,N,IWRIT2,XMEAN,IBUGG3,IERROR)
           CALL SD(X,N,IWRIT2,XSD,IBUGG3,IERROR)
C
CCCCC SEPTEMBER 2004.  SUPPORT ALTERNATIVE ALGORITHMS FOR
CCCCC CLASS WIDTH.  THESE ALTERNATIVES GIVEN IN DAVID SCOTT,
CCCCC 1992, "MULTIVARIATE DENSITY ESTIMATION: THEORY, PRACTICE,
CCCCC AND VISUALIZATION", WILEY.
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(X,N,IWRIT2,XSKEW,IBUGG3,IERROR)
               CALL STMOM4(X,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(X,N,IWRIT2,XTEMP1,MAXOBV,XLOWQ,
     1                     IBUGG3,IERROR)
               CALL UPPQUA(X,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
      ENDIF
      GOTO180
C
  150 CONTINUE
      CALL SORT(X,N,D2)
      NM1=N-1
      DCLWID=D2(2)-D2(1)
      DO160I=1,NM1
      IP1=I+1
      DDELI=D2(IP1)-D2(I)
      IF(DDELI.LT.DCLWID)DCLWID=DDELI
  160 CONTINUE
      DD21=D2(1)
      DD2N=D2(N)
      DXSTAR=DD21-(DCLWID/2.0D0)
      DXSTOP=DD2N+(DCLWID/2.0D0)
      GOTO180
C
  180 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
      DO300J=1,NUMCLA
      D2(J)=0.0
  300 CONTINUE
C
      IF(IDATSW.EQ.'RAW')GOTO410
      IF(IDATSW.EQ.'FREQ')GOTO510
C
  410 CONTINUE
      IBELOW=0
      IABOVE=0
      DO420I=1,N
      DXI=X(I)
      IF(DXI.LT.DXSTAR)THEN
        IBELOW=IBELOW+1
        GOTO420
      ENDIF
      IF(DXI.GT.DXSTOP)THEN
        IABOVE=IABOVE+1
        GOTO420
      ENDIF
      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
      D2(J2)=D2(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=X(I)
      IF(DXI.EQ.DCLMXJ)D2(J)=D2(J)+1.0
  450 CONTINUE
      GOTO590
C
  510 CONTINUE
      IBELOW=0
      IABOVE=0
      DO520I=1,N
      DXI=X(I)
      IF(DXI.LT.DXSTAR)THEN
        IBELOW=IBELOW+1
        GOTO520
      ENDIF
      IF(DXI.GT.DXSTOP)THEN
        IABOVE=IABOVE+1
        GOTO520
      ENDIF
      DO530J=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)GOTO540
  530 CONTINUE
      GOTO520
  540 CONTINUE
      D2(J2)=D2(J2)+Y(I)
  520 CONTINUE
C
C     FOR THIS FREQUENCY DATA CASE,
C     TREAT THE SPECIAL CASE OF EQUALITY
C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
C     (ALTHOUGH THIS SHOULD NOT HAPPEN WITH THE IDATSW = 'FREQ' CASE.)
C
      J=NUMCLA
      DO550I=1,N
      DJ=J
      DCLMXJ=DXSTAR+DJ*DCLWID
      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
      DXI=X(I)
      IF(DXI.EQ.DCLMXJ)D2(J)=D2(J)+Y(I)
  550 CONTINUE
      GOTO590
C
  590 CONTINUE
      IF(IBELOW.GE.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1591)IBELOW,DXSTAR
 1591 FORMAT('***** WARNING: ',I8,' DATA POINTS ARE BELOW THE ',
     1       'MINIMUM CLASS VALUE OF ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(IABOVE.GE.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1691)IABOVE,DXSTOP
 1691 FORMAT('***** WARNING: ',I8,' DATA POINTS ARE ABOVE THE ',
     1       'MAXIMUM CLASS VALUE OF ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(IBUGG3.EQ.'OFF')GOTO595
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,591)
  591 FORMAT('***** IN THE MIDDLE    OF DPHIS2--')
      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=D2(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
C               **********************************
C               **  STEP 4--                    **
C               **  DETERMINE PLOT COORDINATES  **
C               **********************************
C
CCCCC IF(DBAWID.EQ.CPUMIN)DBAWID=DCLWID
C
      IF(ICASPL.EQ.'HIST')GOTO1100
      IF(ICASPL.EQ.'CUMH')GOTO1200
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011)
 1011 FORMAT('***** INTERNAL ERROR IN DPHIS2 ',
     1'AT BRANCH POINT 1011--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1012)
 1012 FORMAT('      ICASPL SHOULD BE EITHER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1013)
 1013 FORMAT('      HIST   OR    CUMH, BUT IS NEITHER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1014)ICASPL
 1014 FORMAT('      ICASPL = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1100 CONTINUE
      SUM=0.0
      DO1110J=1,NUMCLA
      FJ=D2(J)
      SUM=SUM+FJ
 1110 CONTINUE
      AN3=SUM
C
      DENOM=1.0
C     RELATIVE HISTOGRAM CORRECTION MADE FEBRUARY 26, 1988
CCCCC IF(IRELAT.EQ.'ON')DENOM=AN3         COMMENTED OUT JUNE 1994
CCCCC IF(IRELAT.EQ.'ON')DENOM=AN3*DCLWID  COMMENTED OUT FEB 1988
CCCCC THE FOLLOWING LINE FIXES THE RELATIVE HISTOGRAM AREA JUNE 1994
CCCCC IF(IRELAT.EQ.'ON')DENOM=AN3*DCLWID
CCCCC IF(IRELAT.EQ.'ON')DENOM=AN3
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
          DENOM=AN3
        ELSE
          DENOM=AN3*DCLWID
        ENDIF
      ENDIF
C
      DO1120J=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 DJ=J
CCCCC DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
CCCCC DBAMNJ=DCLMDJ-DBAWID/2.0D0
CCCCC DBAMXJ=DCLMDJ+DBAWID/2.0D0
      DJ=J
      DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
C
      FJ=D2(J)
C
CCCCC X2(K)=DBAMNJ
CCCCC X2(KP1)=DBAMNJ
CCCCC X2(KP2)=DBAMXJ
CCCCC X2(KP3)=DBAMXJ
      X2(K)=DCLMDJ
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
 1120 CONTINUE
CCCCC N2=KP3
      N2=K
      NPLOTV=2
C
      DO1130J=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)=1.0
CCCCC D2(KP1)=1.0
CCCCC D2(KP2)=1.0
CCCCC D2(KP3)=1.0
      D2(K)=1.0
C
 1130 CONTINUE
      GOTO9000
C
 1200 CONTINUE
      SUM=0.0
      DO1210J=1,NUMCLA
      FJ=D2(J)
      SUM=SUM+FJ
 1210 CONTINUE
      AN3=SUM
C
      DENOM=1.0
C     RELATIVE HISTOGRAM CORRECTION MADE FEBRUARY 26, 1988
CCCCC IF(IRELAT.EQ.'ON')DENOM=AN3
CCCCC IF(IRELAT.EQ.'ON')DENOM=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
          DENOM=AN3
        ELSE
          DENOM=AN3*DCLWID
        ENDIF
      ENDIF
C
C
      SUM=0.0
      DO1220J=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 DJ=J
CCCCC DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
CCCCC DBAMNJ=DCLMDJ-DBAWID/2.0
CCCCC DBAMXJ=DCLMDJ+DBAWID/2.0
      DJ=J
      DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
C
      FJ=D2(J)
      SUM=SUM+FJ
      CUMFJ=SUM
C
CCCCC X2(K)=DBAMNJ
CCCCC X2(KP1)=DBAMNJ
CCCCC X2(KP2)=DBAMXJ
CCCCC X2(KP3)=DBAMXJ
      X2(K)=DCLMDJ
C
CCCCC Y2(K)=0.0
CCCCC Y2(KP1)=CUMFJ/DENOM
CCCCC Y2(KP2)=CUMFJ/DENOM
CCCCC Y2(KP3)=0.0
      Y2(K)=CUMFJ/DENOM
C
 1220 CONTINUE
CCCCC N2=KP3
      N2=K
      NPLOTV=2
C
      DO1230J=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)=1.0
CCCCC D2(KP1)=1.0
CCCCC D2(KP2)=1.0
CCCCC D2(KP3)=1.0
      D2(K)=1.0
C
 1230 CONTINUE
      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 DPHIS2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR,N2
 9012 FORMAT('ICASPL,IRELAT,IERROR,N2 = ',A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IDATSW,AN3,DENOM
 9013 FORMAT('IDATSW,AN3,DENOM = ',A4,2X,E15.8,E15.8)
      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,9017)N,DCLWID,DXSTAR,DXSTOP
 9017 FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHIST(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1CLLIMI,CLWIDT,
CCCCC MARCH 1996.  ADD FOLLOWING LINE
     1IRHSTG,IHSTCW,IASHWT,
     1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE ONE OF THE FOLLOWING 4 PLOTS--
C              1) HISTOGRAM;
C              2) RELATIVE HISTOGRAM;
C              3) CUMULATIVE HISTOGRAM;
C              4) RELATIVE CUMULATIVE HISTOGRAM;
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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     1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --JULY      1978.
C     UPDATED         --OCTOBER   1978.
C     UPDATED         --APRIL     1979.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C     UPDATED         --MARCH     1996. ADD IRHSTG
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
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 IDATSW
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IHRIGH
      CHARACTER*4 IHRIG2
      CHARACTER*4 IERRO4
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
CCCCC MARCH 1996.  ADD FOLLOWING LINE
      CHARACTER*4 IRHSTG
CCCCC SEPTEMBER 2004.  ADD FOLLOWING LINE
      CHARACTER*4 IHSTCW
      CHARACTER*4 IASHWT
C
C---------------------------------------------------------------------
C
      DIMENSION CLLIMI(*)
      DIMENSION CLWIDT(*)
CCCCC DIMENSION BAWIDT(*)
C
      INCLUDE 'DPCOPA.INC'
      DIMENSION Y1(MAXOBV)
      DIMENSION X1(MAXOBV)
      DIMENSION XTEMP1(MAXOBV)
C
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),X1(1))
      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
      EQUIVALENCE (GARBAG(IGARB3),XTEMP1(1))
CCCCC END CHANGE
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='DPHI'
      ISUBN2='ST  '
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=2
      MINN2=1
C
      ICOLR=0
C
C               *******************************************
C               **  TREAT THE HISTOGRAM 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 DPHIST--')
      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.'HIST')GOTO110
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'HIST')GOTO120
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'HIST')GOTO130
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'RELA'.AND.IHARG(1).EQ.'CUMU'.AND.IHARG(2).EQ.'HIST')
     1GOTO140
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'CUMU'.AND.IHARG(1).EQ.'RELA'.AND.IHARG(2).EQ.'HIST')
     1GOTO140
      IF(NUMARG.GE.2.AND.
     1ICOM.EQ.'AVER'.AND.IHARG(1).EQ.'SHIF'.AND.IHARG(2).EQ.'HIST')
     1GOTO145
      IF(NUMARG.GE.1.AND.
     1ICOM.EQ.'ASH '.AND.IHARG(1).EQ.'HIST')
     1GOTO135
      IF(ICOM.EQ.'ASH ')GOTO115
C
      IFOUND='NO'
      GOTO9000
C
  110 CONTINUE
      ICASPL='HIST'
      IRELAT='OFF'
      GOTO180
C
  115 CONTINUE
      ICASPL='ASHR'
      IRELAT='ON'
      GOTO180
C
  120 CONTINUE
      ICASPL='HIST'
      IRELAT='ON'
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  130 CONTINUE
      ICASPL='CUMH'
      IRELAT='OFF'
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  135 CONTINUE
      ICASPL='ASHR'
      IRELAT='ON'
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  140 CONTINUE
      ICASPL='CUMH'
      IRELAT='ON'
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  145 CONTINUE
      ICASPL='ASHR'
      IRELAT='ON'
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO180
C
  180 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='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 DPHIST--')
      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 DPHIST')
      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 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
      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 DPHIST--')
      CALL DPWRST('XXX','BUG ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,552)
  552 FORMAT('      FOR A HISTOGRAM, ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,553)
  553 FORMAT('      FOR 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,554)
  554 FORMAT('      FOR 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,555)
  555 FORMAT('      FOR A RELATIVE CUMULATIVE HISTOGRAM, ')
      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')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 DPHIST--')
      CALL DPWRST('XXX','BUG ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,572)
  572 FORMAT('      FOR A HISTOGRAM, ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,573)
  573 FORMAT('      FOR 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,574)
  574 FORMAT('      FOR 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,575)
  575 FORMAT('      FOR A RELATIVE CUMULATIVE HISTOGRAM, ')
      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')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 IN THE 2 VARIABLES MUST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,582)
  582 FORMAT('      BE THE SAME.  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)
      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 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
      IHP='M   '
      IHP2='    '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')THEN
        IF(NLOCAL.LE.100)THEN
          M=4
        ELSEIF(NLOCAL.LE.1000)THEN
          M=8
        ELSE
          M=16
        ENDIF
      ELSE
        M=INT(VALUE(ILOCP)+0.5)
        IF(M.LE.0)M=1
        IF(M.GT.64)M=64
      ENDIF
C
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 DPHIS2(Y1,X1,NLOCAL,ICASPL,IRELAT,IDATSW,CLWID,XSTART,XSTOP,
CCCCC MARCH 1996.  ADD FOLLOWING LINE
     1XTEMP1,MAXOBV,
     1IRHSTG,IHSTCW,IASHWT,M,
     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 DPHIST--')
      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 DPHOCO(IANS2,N2,IVALID,VALCON,IBUGA3,IERROR)
C
C     PURPOSE--DETERMINE IF THE STRING DEFINED IN IANS2(.)
C              IS A VALID NUMBER REPRESENTATION
C              AND IF SO, COMPUTE THE VALUE OF THE NUMBER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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   1979.
C     UPDATED         --JULY      1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IANS2
      CHARACTER*4 IVALID
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IFLUNK
      CHARACTER*4 ITYPE2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION IANS2(*)
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='DPHO'
      ISUBN2='CO  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHOCO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N2
   52 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)(IANS2(I),I=1,N2)
   53 FORMAT('IANS2(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  STEP 1--                    **
C               **  INITIALIZE SOME VARIABLES.  **
C               **********************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IVALID='NO'
C
C               ********************************************************
C               **  STEP 7--                                          **
C               **  CONVERT (IF POSSIBLE) THE STRING INTO A FLOATING  **
C               **  POINT ARGUMENT.                                   **
C               **  OUTPUT THIS FLOATING POINT VALUE IN FLOAT.        **
C               ********************************************************
C
      ISTEPN='7'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      AMIN=-1000000.
      AMAX=+1000000.
      IFLUNK='NO'
      IVALID='YES'
      ITYPE2='NUMB'
      VALCON=CPUMIN
C
      ISTAR2=1
      ISTOP2=N2
C
      ILOC=0
      IDECPT=0
      DO3060I=ISTAR2,ISTOP2
      IF(IANS2(I).EQ.'.')ILOC=I
      IF(IANS2(I).EQ.'.')IDECPT=IDECPT+1
 3060 CONTINUE
      IF(IDECPT.GE.2)GOTO3900
      IF(IDECPT.EQ.1)GOTO3150
      DO3100I=ISTAR2,ISTOP2
      IREV=ISTOP2-(I-ISTAR2)
      IF(IANS2(IREV).EQ.' ')GOTO3100
      IF(IANS2(IREV).EQ.'0')GOTO3110
      IF(IANS2(IREV).EQ.'1')GOTO3110
      IF(IANS2(IREV).EQ.'2')GOTO3110
      IF(IANS2(IREV).EQ.'3')GOTO3110
      IF(IANS2(IREV).EQ.'4')GOTO3110
      IF(IANS2(IREV).EQ.'5')GOTO3110
      IF(IANS2(IREV).EQ.'6')GOTO3110
      IF(IANS2(IREV).EQ.'7')GOTO3110
      IF(IANS2(IREV).EQ.'8')GOTO3110
      IF(IANS2(IREV).EQ.'9')GOTO3110
      IFLUNK='YES'
      IF(IANS2(IREV).EQ.'+')GOTO3900
      IF(IANS2(IREV).EQ.'-')GOTO3900
      GOTO3900
 3100 CONTINUE
      IFLUNK='YES'
      GOTO3900
 3110 ILOC=IREV+1
 3150 CONTINUE
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3111)ILOC,IDECPT
 3111 FORMAT('ILOC = ',I8,'    IDECPT = ',I8)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C     SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE
C
      SIGN=1.0
      IDIGI=0
      ISIGN=0
      SUMI=0
      ILOCM1=ILOC-1
      IF(ILOCM1.LT.ISTAR2)GOTO3250
      DO3200I=ISTAR2,ILOCM1
      IREV=ILOCM1-(I-ISTAR2)
      IF(IANS2(IREV).EQ.' ')GOTO3200
      IF(IANS2(IREV).EQ.'0')GOTO3210
      IF(IANS2(IREV).EQ.'1')GOTO3211
      IF(IANS2(IREV).EQ.'2')GOTO3232
      IF(IANS2(IREV).EQ.'3')GOTO3213
      IF(IANS2(IREV).EQ.'4')GOTO3214
      IF(IANS2(IREV).EQ.'5')GOTO3215
      IF(IANS2(IREV).EQ.'6')GOTO3216
      IF(IANS2(IREV).EQ.'7')GOTO3217
      IF(IANS2(IREV).EQ.'8')GOTO3218
      IF(IANS2(IREV).EQ.'9')GOTO3219
      IF(IANS2(IREV).EQ.'+')GOTO3220
      IF(IANS2(IREV).EQ.'-')GOTO3221
      IFLUNK='YES'
      GOTO3900
 3210 ITERM=0
      GOTO3225
 3211 ITERM=1
      GOTO3225
 3232 ITERM=2
      GOTO3225
 3213 ITERM=3
      GOTO3225
 3214 ITERM=4
      GOTO3225
 3215 ITERM=5
      GOTO3225
 3216 ITERM=6
      GOTO3225
 3217 ITERM=7
      GOTO3225
 3218 ITERM=8
      GOTO3225
 3219 ITERM=9
      GOTO3225
 3220 ISIGN=ISIGN+1
      GOTO3200
 3221 ISIGN=ISIGN+1
      SIGN=-SIGN
      GOTO3200
 3225 IDIGI=IDIGI+1
      TERM=ITERM
      IEXP=IDIGI-1
      SUMI=SUMI+TERM*(10.0**IEXP)
 3200 CONTINUE
 3250 CONTINUE
      IF(ISIGN.GE.2)GOTO3900
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3255)IDIGI,SUMI
 3255 FORMAT('IDIGI = ',I8,'    SUMI = ',F20.10)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
C     THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE
C
      IDIGD=0
      SUMD=0.0
      ILOCP1=ILOC+1
      IF(ILOCP1.GT.ISTOP2)GOTO3350
      DO3300I=ILOCP1,ISTOP2
      IF(IANS2(I).EQ.' ')GOTO3300
      IF(IANS2(I).EQ.'0')GOTO3310
      IF(IANS2(I).EQ.'1')GOTO3311
      IF(IANS2(I).EQ.'2')GOTO3312
      IF(IANS2(I).EQ.'3')GOTO3333
      IF(IANS2(I).EQ.'4')GOTO3314
      IF(IANS2(I).EQ.'5')GOTO3315
      IF(IANS2(I).EQ.'6')GOTO3316
      IF(IANS2(I).EQ.'7')GOTO3317
      IF(IANS2(I).EQ.'8')GOTO3318
      IF(IANS2(I).EQ.'9')GOTO3319
      IFLUNK='YES'
      GOTO3900
 3310 ITERM=0
      GOTO3325
 3311 ITERM=1
      GOTO3325
 3312 ITERM=2
      GOTO3325
 3333 ITERM=3
      GOTO3325
 3314 ITERM=4
      GOTO3325
 3315 ITERM=5
      GOTO3325
 3316 ITERM=6
      GOTO3325
 3317 ITERM=7
      GOTO3325
 3318 ITERM=8
      GOTO3325
 3319 ITERM=9
      GOTO3325
 3325 IDIGD=IDIGD+1
      TERM=ITERM
      SUMD=SUMD+TERM/(10.0**IDIGD)
 3300 CONTINUE
 3350 CONTINUE
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3355)IDIGD,SUMD
 3355 FORMAT('IDIGD = ',I8,'    SUMD = ',F20.10)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IDIGT=IDIGI+IDIGD
      IF(IDIGT.LE.0)GOTO3900
      VALCON=SUMI+SUMD
      IF(SIGN.LT.0.0)VALCON=-VALCON
      IF(AMIN.LE.VALCON.AND.VALCON.LE.AMAX)GOTO3000
      GOTO3900
C
 3900 CONTINUE
      IF(IFLUNK.EQ.'YES')ITYPE2='WORD'
 3000 CONTINUE
 3999 CONTINUE
      GOTO8000
C
C               ******************************
C               **  STEP 7--                **
C               **  DEFINE IF VALID OR NOT  **
C               ******************************
C
 8000 CONTINUE
      IF(IFLUNK.EQ.'YES')IVALID='NO'
      IF(IFLUNK.EQ.'NO')IVALID='YES'
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHOCO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IVALID,VALCON
 9012 FORMAT('IVALID,VALCON = ',A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFLUNK,ITYPE2
 9013 FORMAT('IFLUNK,ITYPE2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IERROR
 9015 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHOMO(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE A HOMOGENEITY PLOT--
C              A PLOT OF SUBSET STANDARD DEVIATION VERSUS SUBSET MEAN
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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/7
C     ORIGINAL VERSION--MARCH     1986.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
      CHARACTER*4 IBUGG2
      CHARACTER*4 IBUGG3
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASEQ
CCCCC CHARACTER*4 IH
CCCCC CHARACTER*4 IH2
CCCCC CHARACTER*4 IERRO2
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IHHOR
      CHARACTER*4 IHHOR2
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),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
      IERROR='NO'
C
      ISUBN1='DPHO'
      ISUBN2='MO  '
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 HOMOGENEITY 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 DPHOMO--')
      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
      ICASPL='HOMO'
C
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO111
      GOTO119
C
  111 CONTINUE
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO119
C
  119 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               ***********************************************************
C               **  STEP 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=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 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 DPHOMO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,312)
  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,321)
  321 FORMAT('      (FOR WHICH A HOMOGENEITY PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,325)
  325 FORMAT('      WAS TO HAVE BEEN FORMED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,326)MINN2
  326 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,327)
  327 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,328)
  328 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,329)(IANS(I),I=1,IWIDTH)
  329 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 DPHOMO')
      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 (IT MUST), 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 AND                 **
C               **  STANDARD DEVIATIONS 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 I   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.2)GOTO530
      GOTO510
C
  510 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,511)
  511 FORMAT('***** ERROR IN DPHOMO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,512)
  512 FORMAT('      FOR A HOMOGENEITY PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,518)
  518 FORMAT('      THE NUMBER OF VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,519)
  519 FORMAT('      MUST BE EXACTLY 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 DPHOMO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,572)
  572 FORMAT('      FOR A HOMOGENEITY 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  (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 8--                                               **
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 DPHOM2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,
     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 DPHOMO--')
      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)ISIZE
 9014 FORMAT('ISIZE = ',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 DPHOM2(Y,X,N,NUMV2,ICASPL,ISIZE,
     1XIDTEM,TEMP,
     1Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE AN HOMOGENEITY PLOT
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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     1986.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
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
      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='DPHO'
      ISUBN2='M2  '
C
      I2=0
      AN=0.0
C
      N50=1
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 DPHOM2--')
      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 DPHOM2--')
      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 DPHOM2--')
      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 DPHOM2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)N,ICASPL,NUMV2
   71 FORMAT('N,ICASPL,NUMV2 = ',I8,2X,A4,I8)
      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
   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 HOMOGENEITY PLOT .       *
*
C               ********************************************************
C
      ISTEPN='1'
      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      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 DPHOM2   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 DPHOM2   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 4--                                     **
C               **  DETERMINE PLOT COORDINATES                   **
C               ***************************************************
C
 1100 CONTINUE
C
      ISTEPN='4'
      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      J=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
C
      IF(IBUGG3.EQ.'ON')WRITE(ICOUT,1121)ISET,XIDTEM(ISET),NI
 1121 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
      IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(NI.LE.1)GOTO1110
      CALL SORT(TEMP,NI,TEMP)
      IWRITE='OFF'
      SUM=0.0
      CALL MEAN(TEMP,NI,IWRITE,XMEAN,IBUGG3,IERROR)
      CALL SD(TEMP,NI,IWRITE,XSD,IBUGG3,IERROR)
      J=J+1
      Y2(J)=XSD
      X2(J)=XMEAN
      D2(J)=1.0
C
 1110 CONTINUE
C
      N2=J
      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 DPHOM2--')
      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
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHORI(IHARG,IARGT,ARG,NUMARG,
     1PDEFHG,
     1PTEXHG,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE HORIZONTAL GAP FOR TEXT CHARACTERS.
C              THE HORIZONTAL GAP FOR TEXT CHARACTERS WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE PTEXHG.
C     NOTE--THE HORIZONTAL GAP IS IN STANDARDIZED UNITS (0.0 TO 100.0).
C     NOTE--THE HORIZONTAL GAP IS THE BETWEEN-CHARACTER SPACING (DISTANCE)
C           FROM THE END OF ONE CHARACTER
C           TO THE BEGINNING OF THE NEXT CHARACTER.
C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
C                     --IARGT
C                     --ARG
C                     --NUMARG
C                     --PDEFHG
C                     --IBUGD2
C     OUTPUT ARGUMENTS--PTEXHG
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
      CHARACTER*4 IBUGD2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
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
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHORI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)PDEFHG
   53 FORMAT('PDEFHG = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NUMARG
   54 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NUMARG
      WRITE(ICOUT,56)I,IHARG(I),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
   90 CONTINUE
C
C               *************************************
C               **  TREAT THE HORIZONTAL GAP CASE  **
C               *************************************
C
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1150
      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'GAP')GOTO1150
      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'SPAC')GOTO1150
      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'DIST')GOTO1150
      IF(NUMARG.EQ.1.AND.IHARG(NUMARG).EQ.'LENG')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
C
      IF(NUMARG.GE.1.AND.IARGT(NUMARG).EQ.'NUMB')
     1GOTO1160
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN DPHORI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR HORIZONTAL GAP ',
     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 IT IS DESIRED THAT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HORIZONTAL SPACING ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      OF 2 (WHERE THE HORIZONTAL SCREEN UNITS RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1128)
 1128 FORMAT('      FROM 0 TO 100,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1130)
 1130 FORMAT('      THEN THE ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)
 1131 FORMAT('           HORIZONTAL SPACING 5 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      PTEXHG=PDEFHG
      GOTO1180
C
 1160 CONTINUE
      PTEXHG=ARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE HORIZONTAL SPACING (FOR TEXT CHARACTERS)  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)PTEXHG
 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHORI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)PTEXHG
 9013 FORMAT('PTEXHG = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHOSL(IHARG,NUMARG,IDEFHL,
     1IHOSLI,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE TYPE OF COMMUNICATIONS LINK
C              (E.G., NBS NETWORK, PHONE LINES, ETC.)
C              BETWEEN HOST AND TERMINAL.
C              THE HOST LINK INFORMATION
C              WILL BE PLACED IN THE VARIOUS ELEMENTS OF THE
C              IHOSLI(.) VECTOR.
C              AS MUCH DETAIL AS NECESSARY
C              MAY BE USED TO DESCRIBE
C              THE HOST LINK.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFHL (A  HOLLERITH VECTOR)
C     OUTPUT ARGUMENTS--IHOSLI (A HOLLERITH VECTOR
C                              WHICH CONTAINS THE HOST
C                              SPECIFICATIONS.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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 IDEFHL
      CHARACTER*4 IHOSLI
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IDEFHL(*)
      DIMENSION IHOSLI(*)
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
      GOTO1110
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1130
      GOTO1150
C
 1130 CONTINUE
      DO1135I=1,10
      IHOSLI(I)=IDEFHL(I)
 1135 CONTINUE
      GOTO1180
C
 1150 CONTINUE
 
      IF(IHARG(2).EQ.'OFF')GOTO1160
      IF(IHARG(2).EQ.'AUTO')GOTO1160
      IF(IHARG(2).EQ.'DEFA')GOTO1160
      GOTO1170
C
 1160 CONTINUE
      DO1165I=1,10
      IHOSLI(I)=IDEFHL(I)
 1165 CONTINUE
      GOTO1180
C
 1170 CONTINUE
      K=1
      DO1175I=1,10
      K=K+1
      IF(K.LE.NUMARG)IHOSLI(I)=IHARG(K)
      IF(K.GT.NUMARG)IHOSLI(I)=' '
 1175 CONTINUE
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)
 1185 FORMAT('THE HOST LINK (= COMMUNICATIONS LINK) ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)(IHOSLI(I),I=1,10)
 1186 FORMAT('HAS JUST BEEN SET TO ',
     1A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPHOST(IHARG,NUMARG,IDEFHO,
     1IHOST,IHOST1,IHOST2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE MANUFACTURER, MODEL, ETC. FOR THE
C              HOST COMPUTER.
C              THE HOST INFORMATION
C              WILL BE PLACED IN THE VARIOUS ELEMENTS OF THE
C              IHOST(.) VECTOR.
C              AS MUCH DETAIL (FOR EXAMPLE, MODEL NUMBER,
C              OPERATING SYSTEM, ETC.) MAY BE USED TO DESCRIBE
C              THE HOST COMPUTER.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFHO (A  HOLLERITH VECTOR)
C     OUTPUT ARGUMENTS--IHOST  (A HOLLERITH VECTOR
C                              WHICH CONTAINS THE HOST
C                              SPECIFICATIONS.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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 IDEFHO
      CHARACTER*4 IHOST
      CHARACTER*4 IHOST1
      CHARACTER*4 IHOST2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IDEFHO(*)
C
      DIMENSION IHOST(*)
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
      GOTO1110
C
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1130
      IF(IHARG(1).NE.'MANU')GOTO1120
      IF(IHARG(1).EQ.'MANU')GOTO1150
C
 1120 CONTINUE
      IF(IHARG(1).EQ.'ON')GOTO1130
      IF(IHARG(1).EQ.'OFF')GOTO1130
      IF(IHARG(1).EQ.'AUTO')GOTO1130
      IF(IHARG(1).EQ.'DEFA')GOTO1130
      GOTO1140
C
 1130 CONTINUE
      DO1135I=1,10
      IHOST(I)=IDEFHO(I)
 1135 CONTINUE
      GOTO1180
C
 1140 CONTINUE
      K=0
      DO1145I=1,10
      K=K+1
      IF(K.LE.NUMARG)IHOST(I)=IHARG(K)
      IF(K.GT.NUMARG)IHOST(I)=' '
 1145 CONTINUE
      GOTO1180
C
 1150 CONTINUE
      IF(IHARG(2).EQ.'ON')GOTO1160
      IF(IHARG(2).EQ.'OFF')GOTO1160
      IF(IHARG(2).EQ.'AUTO')GOTO1160
      IF(IHARG(2).EQ.'DEFA')GOTO1160
      GOTO1170
C
 1160 CONTINUE
      DO1165I=1,10
      IHOST(I)=IDEFHO(I)
 1165 CONTINUE
      GOTO1180
C
 1170 CONTINUE
      K=1
      DO1175I=1,10
      K=K+1
      IF(K.LE.NUMARG)IHOST(I)=IHARG(K)
      IF(K.GT.NUMARG)IHOST(I)=' '
 1175 CONTINUE
      GOTO1180
C
 1180 CONTINUE
      IHOST1=IHOST(1)
      IHOST2=IHOST(2)
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)(IHOST(I),I=1,10)
 1185 FORMAT('THE HOST HAS JUST BEEN SET TO ',
     1A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4,1X,A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPHRIZ(IHARG,NUMARG,IHORSW,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE HORIZONTAL SWITCH IHORSW
C              (DETERMINES WHETHER PLOTS DRAWN HORIZONTALLY OR
C              VERTICALLY.  USEFUL FOR SPIKES (TO DO DOT CHARTS
C              SUGGESTED BY CLEVLEAND), BAR CHARTS, DOING CHARTS
C              IN "PORTRAIT" MODE).
C              HANGING HISTOGRAMS).
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG
C     OUTPUT ARGUMENTS--IHORSW  ('ON'  OR 'OFF')
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--ALAN HECKERT
C                 COMPUTER SERVICES DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
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 TECHNOOGY.
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 IHORSW
      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.GE.2)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
      IHORSW='ON'
      GOTO1180
C
 1160 CONTINUE
      IHORSW='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)IHORSW
 1181 FORMAT('THE HORIZONTAL SWITCH HAS JUST BEEN TURNED ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPHTCC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--GENERATE A HOTELLING MULTIVARIATE CONTROL CHART --
C              ESSENTIALLY COMPUTES A HOTELLING T-SQUARE (1-SAMPLE)
C              STATISTIC FOR EACH SUBGROUP.  THESE HOTELLING VALUES
C              ARE PLOTTTED AS A CONTROL CHART.
C     FEBRUARY 2003:
C     SUPPORT FOUR DISTINCT CASES FOR HOTELLING CONTROL CHARTS.
C       1) PHASE I HOTELLING CONTROL CHART Y1 ... YK GROUP
C       2) PHASE I HOTELLING INDIVIDUAL CONTROL CHART Y1 ... YK
C       3) PHASE II HOTELLING CONTROL CHART Y1 ... YK GROUP HIST
C       4) PHASE II HOTELLING INDIVIDUAL CONTROL CHART Y1 ... YK GROUP
C     IF PHASE  OMITTED, ASSUME A PHASE I CHART.
C     WRITTEN BY--ALAN HECKERT
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
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 TECHNOOGY.
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/9
C     ORIGINAL VERSION--SEPTEMBER 1998.
C     UPDATED         --MARCH     2003. SUPPORT FOR 4 TYPES OF CHARTS
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 IH
      CHARACTER*4 IH2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 ICASEQ
      CHARACTER*4 IHRIGH
      CHARACTER*4 IHRIG2
      CHARACTER*4 IVARN1
      CHARACTER*4 IVARN2
      CHARACTER*4 IFLGGR
      CHARACTER*4 IFLGHI
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
C  MAXHOT IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
C  HOTELLING CHART
C
      PARAMETER(MAXHOT=15)
C
      DIMENSION IVARN1(MAXHOT)
      DIMENSION IVARN2(MAXHOT)
      DIMENSION ILIS(MAXHOT)
C
      DIMENSION X1(MAXOBV)
      DIMENSION XHIST(MAXOBV)
      DIMENSION XIDTEM(MAXOBV)
      DIMENSION XIDTE2(MAXOBV)
      DIMENSION TEMP(MAXOBV)
      DIMENSION XMEANS(MAXOBV)
      DIMENSION XGROUP(MAXOBV)
C
      DIMENSION INDEX(MAXOBV)
      DIMENSION NIJUNK(MAXOBV)
      DIMENSION IGRPST(MAXOBV)
C
      DOUBLE PRECISION DMEAN(MAXOBV)
C
      DIMENSION Z(MAXOBV,MAXHOT)
      DIMENSION ZHIST(MAXOBV,MAXHOT)
      DIMENSION ZMEANS(MAXOBV,MAXHOT)
      DIMENSION S(MAXHOT,MAXHOT)
C
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),Z(1,1))
C
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR11),ZHIST(1,1))
      EQUIVALENCE (G2RBAG(IGAR27),ZMEANS(1,1))
      EQUIVALENCE (G2RBAG(IGAR49),X1(1))
      EQUIVALENCE (G2RBAG(IGAR50),XHIST(1))
      EQUIVALENCE (G2RBAG(IGAR51),XIDTEM(1))
      EQUIVALENCE (G2RBAG(IGAR52),XIDTE2(1))
      EQUIVALENCE (G2RBAG(IGAR53),TEMP(1))
      EQUIVALENCE (G2RBAG(IGAR54),XMEANS(1))
      EQUIVALENCE (G2RBAG(IGAR55),S(1,1))
      EQUIVALENCE (G2RBAG(IGAR56),XGROUP(1))
C
      INCLUDE 'DPCOZD.INC'
      EQUIVALENCE (DGARBG(IDGAR1),DMEAN(1))
C
      INCLUDE 'DPCOZI.INC'
      EQUIVALENCE (IGARBG(IIGAR1),INDEX(1))
      EQUIVALENCE (IGARBG(IIGAR2),NIJUNK(1))
      EQUIVALENCE (IGARBG(IIGAR3),IGRPST(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='DPHT'
      ISUBN2='CC  '
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=2
      MINN2=1
C
      ICOLH=0
C
      IFLGGR='ON'
      IFLGHI='OFF'
C
C               **********************************************
C               **  TREAT THE HOTELLING CONTROL CHART CASE  **
C               **********************************************
C
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'HTCC')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHTCC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
   52 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,IAND1,IAND2
   53 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***************************
C               **  STEP 1--             **
C               **  EXTRACT THE COMMAND  **
C               ***************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASPL='HTCC'
C
CCCCC FEBRUARY 2003: CHECK FOR THE FOLLOWING:
CCCCC     HOTELLING CONTROL CHART (= PHASE I, GROUP)
CCCCC     MULTIVARIATE CONTROL CHART (= PHASE I, GROUP)
CCCCC     PHASE  HOTELLING CONTROL CHART
CCCCC     PHASE  HOTELLING CONTROL CHART
CCCCC     PHASE  HOTELLING INDIVIDUAL CONTROL CHART
CCCCC     PHASE  HOTELLING INDIVIDUAL CONTROL CHART
CCCCC THE WORDS "CONTROL" AND "CHART" ARE OPTIONAL.
C
      IF(ICOM.EQ.'PHAS')THEN
        IF(IHARG(1).EQ.'I'.OR.IHARG(1).EQ.'ONE'.OR.IHARG(1).EQ.'1')THEN
          ICASPL='HT1G'
          ILASTC=1
          IF(IHARG(2).EQ.'HOTE' .OR. IHARG(2).EQ.'MULT')ILASTC=2
          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
        ELSEIF(IHARG(1).EQ.'II'.OR.IHARG(1).EQ.'TWO'.OR.
     1         IHARG(1).EQ.'2')THEN
          ICASPL='HT2G'
          ILASTC=1
          IF(IHARG(2).EQ.'HOTE' .OR. IHARG(2).EQ.'MULT')ILASTC=2
          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
        ENDIF
      ELSEIF(ICOM.EQ.'HOTE' .OR. ICOM.EQ.'MULT')THEN
        IF(IHARG(1).EQ.'PHAS' .AND. (IHARG(2).EQ.'I' .OR.
     1     IHARG(2).EQ.'ONE' .OR. IHARG(2).EQ.'1'))THEN
          ILASTC=2
          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
          ICASPL='HT1G'
        ELSEIF(IHARG(1).EQ.'PHAS' .AND. (IHARG(2).EQ.'II' .OR.
     1     IHARG(2).EQ.'TWO' .OR. IHARG(2).EQ.'2'))THEN
          ILASTC=2
          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
          ICASPL='HT2G'
        ELSE
          ICASPL='HT1G'
        ENDIF
      ELSE
        IFOUND='NO'
        GOTO9000
      ENDIF
C
C  NOW CHECK FOR WORD "INDIVIDUAL"
C
      IF(IHARG(1).EQ.'INDI')THEN
        IF(ICASPL.EQ.'HT1G')ICASPL='HT1I'
        IF(ICASPL.EQ.'HT2G')ICASPL='HT2I'
        ILASTC=1
        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      ENDIF
C
C  NOW CHECK FOR WORD "CONTROL" OR WORD "CHART"
C
      IF(IHARG(1).EQ.'CONT')THEN
        ILASTC=1
        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      ENDIF
C
      IF(IHARG(1).EQ.'CHAR')THEN
        ILASTC=1
        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      ENDIF
C
      IFOUND='YES'
      IFLGGR='OFF'
      IF(ICASPL.EQ.'HT1G' .OR. ICASPL.EQ.'HT2G')IFLGGR='ON'
      IFLGHI='OFF'
      IF(ICASPL.EQ.'HT2I' .OR. ICASPL.EQ.'HT2G')IFLGHI='ON'
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               *****************************************
C               **  STEP 11--                          **
C               **  CHECK TO SEE THE TYPE SUBCASE      **
C               **  (BASED ON THE QUALIFIER)--         **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO1180
      DO1100J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO1110
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO1110
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO1120
 1100 CONTINUE
      GOTO1180
 1110 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO1190
 1120 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO1190
C
 1180 CONTINUE
      GOTO1190
C
 1190 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'HTCC')GOTO1195
      WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ
 1191 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1195 CONTINUE
C
C               **************************************************
C               **  STEP 12--                                   **
C               **  DETERMINE THE NUMBER OF VARIABLES           **
C               **  TO BE INCLUDED AS PLOT COMPONENTS           **
C               **  IF THE   TO   FEATURE IS USED IN THE        **
C               **  ARGUMENT LIST, TRANSLATE THE   TO           **
C               **  EXPLICIT VARIABLE NAMES                     **
C               **  MINIMUM NUMBER OF VARIABLES:                **
C               **     ICASPL=HT1G:   2 + 1 + 0 = 3             **
C               **     ICASPL=HT2G:   2 + 1 + 1 = 3             **
C               **     ICASPL=HT1I:   2 + 0 + 0 = 2             **
C               **     ICASPL=HT2I:   2 + 0 + 1 = 3             **
C               **************************************************
C
      ISTEPN='12'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      JMIN=1
      JMAX=ILOCQ-1
      CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXHOT,
     1IHNAME,IHNAM2,IUSE,NUMNAM,
     1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      MINVAR=2
      IF(IFLGGR.EQ.'ON')MINVAR=MINVAR+1
      IF(IFLGHI.EQ.'ON')MINVAR=MINVAR+1
C
      IF(NUMVAR.LT.MINVAR)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1211)
 1211   FORMAT('***** ERROR IN DPHTCC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1212)MINVAR
 1212   FORMAT('      THERE MUST BE AT LEAST ',I8,' VARIABLES ')
        CALL DPWRST('XXX','BUG ')
        NUMGRP=0
        IF(IFLGGR.EQ.'ON')NUMGRP=1
        NUMHIS=0
        IF(IFLGHI.EQ.'ON')NUMHIS=1
        WRITE(ICOUT,1214)NUMGRP,NUMHIS
 1214   FORMAT('      (AT LEAST TWO RESPONSE VARIABLES, ',I2,
     1         'GROUP ID VARIABLES, AND ',I2,' HISTORY VARIABLES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1221)
 1221   FORMAT('      FOR THE HOTELLING CONTROL CHART.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1223)NUMVAR
 1223   FORMAT('      ONLY ',I8,' VARIABLES WERE SPECIFIED.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
 1290 CONTINUE
C
C               ***************************************
C               **  STEP 13--                        **
C               **  CHECK THE VALIDITY OF EACH       **
C               **  OF THE VARIABLES.                **
C               **  ALSO CHECK TO ASSURE THAT EACH   **
C               **  OF THE VARIABLES HAS AT LEAST    **
C               **  2 OBSERVATIONS.                  **
C               ***************************************
C
      ISTEPN='13'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IFLAG=0
      DO1300I=1,NUMVAR
C
        IHRIGH=IVARN1(I)
        IHRIG2=IVARN2(I)
        IHWUSE='V'
        MESSAG='YES'
        CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
C
        NRIGHT=IN(ILOCV)
        IF(I.EQ.1)THEN
          NTEMP=NRIGHT
        ELSE
          IF(NRIGHT.NE.NTEMP)IFLAG=1
        ENDIF
        ILIS(I)=ILOCV
        IF(NRIGHT.GE.MINN2)GOTO1390
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1311)
 1311   FORMAT('***** ERROR IN DPHTCC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1312)
 1312   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1325)
 1325   FORMAT('      A HOTELLING CONTROL CHART WAS TO HAVE BEEN')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1326)MINN2
 1326   FORMAT('      FORMED MUST BE ',I8,' OR LARGER;')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1327)
 1327   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1328)
 1328   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
        CALL DPWRST('XXX','BUG ')
        IF(IWIDTH.GE.1)THEN
          WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,80))
 1329     FORMAT('      ',80A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
 1390 CONTINUE
C
 1300 CONTINUE
C
C
C               ******************************************************
C               **  STEP 1.4--                                      **
C               **  CHECK THAT VARIABLES HAVE THE SAME NUMBER OF    **
C               **  ELEMENTS.                                       **
C               ******************************************************
C
 1400 CONTINUE
      ISTEPN='1.4'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IFLAG.EQ.0)GOTO1490
C
 1410 CONTINUE
      WRITE(ICOUT,1411)
 1411 FORMAT('***** ERROR IN DPHTCC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1413)
 1413 FORMAT('      THE NUMBER OF OBSERVATIONS IN ALL VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1415)
 1415 FORMAT('      MUST BE THE SAME; SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      DO1417I=1,NUMVAR
        I2=ILIS(I)
        WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2)
 1416   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,
     1         ' OBSERVATIONS;')
        CALL DPWRST('XXX','BUG ')
 1417 CONTINUE
      WRITE(ICOUT,1420)
 1420 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)THEN
        WRITE(ICOUT,1421)(IANS(I),I=1,MIN(100,IWIDTH))
 1421   FORMAT('      ',100A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IERROR='YES'
      GOTO9000
C
 1490 CONTINUE
C
C               *************************************************
C               **  STEP 21--                                  **
C               **  BRANCH TO THE APPROPRIATE SUBCASE;         **
C               **  (BASED ON THE QUALIFIER)                   **
C               **  THEN FOR  EACH OF THE RESPONSE VARIABLES   **
C               **  EXTRACT THE DATA SUBSET                    **
C               **  (USUALLY ONLY 1 OBSERVATION)               **
C               **  AND ALSO EXTRACT THE                       **
C               **  MIN AND MAX FOR THE FULL VARIABLE          **
C               *************************************************
C
      ISTEPN='21'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO2110
      IF(ICASEQ.EQ.'SUBS')GOTO2120
      IF(ICASEQ.EQ.'FOR')GOTO2130
C
 2110 CONTINUE
      DO2115I=1,NRIGHT
      ISUB(I)=1
 2115 CONTINUE
      NQ=NRIGHT
      GOTO2190
C
 2120 CONTINUE
      NIOLD=NRIGHT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO2190
C
 2130 CONTINUE
      NIOLD=NRIGHT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO2190
C
 2190 CONTINUE
C
C               *************************************************
C               **  STEP 22--                                  **
C               **  FOR EACH OF THE RESPONSE VARIABLES,        **
C               **  EXTRACT THE DATA SUBSET                    **
C               **  (FREQUENTLY ONLY 1 OBSERVATION)            **
C               **  AND ALSO EXTRACT THE                       **
C               **  MIN AND MAX FOR THE FULL VARIABLE          **
C               *************************************************
C
      ISTEPN='22'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMRSP=NUMVAR
      IF(IFLGGR.EQ.'ON')NUMRSP=NUMRSP-1
      IF(IFLGHI.EQ.'ON')NUMRSP=NUMRSP-1
      NGROUP=0
      IF(IFLGGR.EQ.'ON')NGROUP=NUMRSP+1
      NHIST=0
      IF(IFLGHI.EQ.'ON')THEN
        NHIST=NUMRSP+1
        IF(IFLGGR.EQ.'ON')NHIST=NHIST+1
      ENDIF
C
      DO2200K=1,NUMVAR
        IHRIGH=IVARN1(K)
        IHRIG2=IVARN2(K)
C
        DO2210I=1,NUMNAM
          I2=I
          IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I).AND.
     1       IUSE(I).EQ.'V')GOTO2219
 2210   CONTINUE
        WRITE(ICOUT,2211)
 2211   FORMAT('***** INTERNAL ERROR IN DPHTCC AT POINT 2210--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2212)IHRIGH,IHRIG2
 2212   FORMAT('      THE VARIABLE ',A4,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2213)
 2213   FORMAT('      NOT NOW FOUND IN INTERNAL NAME LIST')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2214)
 2214   FORMAT('      ALTHOUGH IT WAS FOUND EARLIER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2215)
 2215   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
        CALL DPWRST('XXX','BUG ')
        IF(IWIDTH.GE.1)THEN
          WRITE(ICOUT,2216)(IANS(I),I=1,MIN(80,IWIDTH))
 2216     FORMAT('      ',80A1)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        IERROR='YES'
        GOTO9000
 2219   CONTINUE
C
        ILISTR=I2
        ICOLR=IVALUE(ILISTR)
        NRIGHT=IN(ILISTR)
C
        J=0
        IMAX=NRIGHT
        IF(NQ.LT.NRIGHT)IMAX=NQ
        IF(K.LE.NUMRSP)THEN
          DO2240I=1,IMAX
            IF(ISUB(I).EQ.0)GOTO2240
            J=J+1
            IJ=MAXN*(ICOLR-1)+I
            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
              WRITE(ICOUT,2241)I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX
 2241         FORMAT('I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX = ',8I8)
              CALL DPWRST('XXX','BUG ')
            ENDIF
            IF(ICOLR.LE.MAXCOL)Z(J,K)=V(IJ)
            IF(ICOLR.EQ.MAXCP1)Z(J,K)=PRED(I)
            IF(ICOLR.EQ.MAXCP2)Z(J,K)=RES(I)
            IF(ICOLR.EQ.MAXCP3)Z(J,K)=YPLOT(I)
            IF(ICOLR.EQ.MAXCP4)Z(J,K)=XPLOT(I)
            IF(ICOLR.EQ.MAXCP5)Z(J,K)=X2PLOT(I)
            IF(ICOLR.EQ.MAXCP6)Z(J,K)=TAGPLO(I)
 2240     CONTINUE
        ELSEIF(K.EQ.NGROUP)THEN
          DO2250I=1,IMAX
            IF(ISUB(I).EQ.0)GOTO2250
            J=J+1
            IJ=MAXN*(ICOLR-1)+I
            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
              WRITE(ICOUT,2251)I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX
 2251         FORMAT('I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX = ',8I8)
              CALL DPWRST('XXX','BUG ')
            ENDIF
            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)
 2250     CONTINUE
        ELSEIF(K.EQ.NHIST)THEN
          DO2260I=1,IMAX
            IF(ISUB(I).EQ.0)GOTO2260
            J=J+1
            IJ=MAXN*(ICOLR-1)+I
            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')THEN
              WRITE(ICOUT,2261)I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX
 2261         FORMAT('I,J,MAXN,ICOLR,IJ,NRIGHT,NQ,IMAX = ',8I8)
              CALL DPWRST('XXX','BUG ')
            ENDIF
            IF(ICOLR.LE.MAXCOL)XHIST(J)=V(IJ)
            IF(ICOLR.EQ.MAXCP1)XHIST(J)=PRED(I)
            IF(ICOLR.EQ.MAXCP2)XHIST(J)=RES(I)
            IF(ICOLR.EQ.MAXCP3)XHIST(J)=YPLOT(I)
            IF(ICOLR.EQ.MAXCP4)XHIST(J)=XPLOT(I)
            IF(ICOLR.EQ.MAXCP5)XHIST(J)=X2PLOT(I)
            IF(ICOLR.EQ.MAXCP6)XHIST(J)=TAGPLO(I)
 2260     CONTINUE
        ENDIF
        NLOCAL=J
        NSUB=NLOCAL
C
 2200 CONTINUE
      NZ=NUMVAR
C
      CCUSL=CPUMIN
      IH='USL '
      IH2='    '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IH,IH2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'NO')CCUSL=VALUE(ILOCP)
      IERROR='NO'
C
      CCLSL=CPUMAX
      IH='LSL '
      IH2='    '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IH,IH2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'NO')CCLSL=VALUE(ILOCP)
      IERROR='NO'
C
      ALPHA=0.05
      IH='ALPH'
      IH2='A   '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IH,IH2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'NO')THEN
        IF(VALUE(ILOCP).GT.0.0 .AND. VALUE(ILOCP).LT.0.50)
     1     ALPHA=VALUE(ILOCP)
      ENDIF
      IERROR='NO'
C
C               *******************************************************
C               **  STEP 31--                                        **
C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
C               **  DEFINE THE VECTOR D(.) SO THAT EACH ANDREW'S     **
C               **  CURVE HAS ITS OWNS TAG NUMBER.                   **
C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
C               *******************************************************
C
      ISTEPN='8'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'HTCC')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL DPHTC2(Z,ZHIST,ZMEANS,S,MAXOBV,MAXHOT,NLOCAL,NUMVAR,
     1X1,XHIST,XIDTEM,XIDTE2,TEMP,XMEANS,DMEAN,INDEX,NIJUNK,
     1IGRPST,XGROUP,
     1ICASPL,ICONT,CCUSL,CCLSL,ALPHA,
     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.'HTCC')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHTCC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFOUND,IERROR
 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NSUB
 9021 FORMAT('NSUB = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NSUB.LE.0)GOTO9024
      DO9022I=1,NSUB
      WRITE(ICOUT,9023)I,(Z(I,K),K=1,NUMVAR)
 9023 FORMAT('I,Z(I,K) = ',I8,20E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9024 CONTINUE
      WRITE(ICOUT,9041)NZ
 9041 FORMAT('NZ = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)NPLOTP
 9051 FORMAT('NPLOTP = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NPLOTP.LE.0)GOTO9054
      DO9052I=1,NPLOTP
      WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
 9053 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
      CALL DPWRST('XXX','BUG ')
 9052 CONTINUE
 9054 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHTC2(Z,ZHIST,ZMEANS,SPOOL,MAXROM,MAXHOT,N,NUMVAR,
     1X,XHIST,XIDTEM,XIDTE2,TEMP,XMEANS,DMEAN,INDEX,NIJUNK,
     1IGRPST,XGROUP,
     1ICASPL,ICONT,CCUSL,CCLSL,ALPHA,
     1Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE A HOTELLING MULTIVARIATE CONTROL CHART
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     REFERENCE--RYAN, "STATISTICAL METHODS FOR QUALITY CONTROL"
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/9
C     ORIGINAL VERSION--SEPTEMBER 1998.
C     UPDATED         --MARCH     2003. SUPPORT EXTENDED TO FOUR
C                                       CASES:
C                                       PHASE I GROUP
C                                       PHASE I INDIVIDUAL
C                                       PHASE II GROUP
C                                       PHASE II INDIVIDUAL
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICONT
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Z(MAXROM,MAXHOT)
      DIMENSION ZHIST(MAXROM,MAXHOT)
      DIMENSION ZMEANS(MAXROM,MAXHOT)
      DIMENSION SPOOL(MAXHOT,MAXHOT)
      DIMENSION X(*)
      DIMENSION XHIST(*)
      DIMENSION XGROUP(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION XMEANS(*)
      DIMENSION TEMP(*)
      DIMENSION INDEX(*)
      DIMENSION NIJUNK(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D2(*)
      DIMENSION IGRPST(*)
      DOUBLE PRECISION DMEAN(*)
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='DPHT'
      ISUBN2='C2  '
      IWRITE='OFF '
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.GE.2)GOTO39
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)
   31 FORMAT('***** ERROR IN DPHTC2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)
   32 FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST TWO;')
      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(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HTC2')THEN
        WRITE(ICOUT,70)
   70   FORMAT('AT THE BEGINNING OF DPHTC2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)N,NUMVAR,ICASPL,ICONT
   71   FORMAT('N,NUMVAR,ICASPL,ICONT = ',2I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO79I=1,N
          WRITE(ICOUT,73)I,X(I),XHIST(I),(Z(I,J),J=1,3)
   73     FORMAT('X(I),XHIST(I),Z(I,J=1,3) = ',I8,5F12.5)
          CALL DPWRST('XXX','BUG ')
   79   CONTINUE
      ENDIF
C
C               *******************************************
C               **  STEP 3.0--                           **
C               **  DETERMINE STATISTICS FOR THE ENTIRE  **
C               **  DATA SET                             **
C               *******************************************
C
 1000 CONTINUE
C
      ISTEPN='3.0'
      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NC1=NUMVAR
      IF(ICASPL.EQ.'HT1G' .OR. ICASPL.EQ.'HT2G')NC1=NC1-1
      IF(ICASPL.EQ.'HT2G' .OR. ICASPL.EQ.'HT2I')NC1=NC1-1
      NR1=N
      N2=N
C
      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'HTC2')THEN
        WRITE(ICOUT,80)
   80   FORMAT('AT THE BEGINNING OF DPHTC2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,81)NR1,NC1,N2
   81   FORMAT('NR1,NC1,N2 = ',3I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               **********************************************
C               **  STEP 5.1--                              **
C               **  TREAT THE PHASE I (GROUP) HOTELLING     **
C               **  CONTROL CHART CASE                      **
C               **********************************************
C
      IF(ICASPL.EQ.'HT1G')THEN
        ISTEPN='5.1'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        CALL VARPO2(Z,ZMEANS,SPOOL,MAXROM,MAXHOT,NR1,NC1,MAXHOT,
     1              X,XIDTEM,NIJUNK,NGROUP,DMEAN,IBUGG3,IERROR)
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5161)
 5161     FORMAT('**** HOTELLING PHASE I CONTROL CHART ',
     1           'FOR SUBGROUPS')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5164)
 5164     FORMAT('     COVARIANCE MATRIX MAXIMUM OF 5 COLUMNS ',
     1           'PRINTED)')
          CALL DPWRST('XXX','BUG ')
          DO5166J=1,NC1
            WRITE(ICOUT,5168)(SPOOL(J,L),L=1,MIN(NC1,5))
            CALL DPWRST('XXX','BUG ')
 5166     CONTINUE
 5168     FORMAT(6X,5E15.7)
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
C
        IF(1.0+RCOND.EQ.1.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5101)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5102)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5103)
          CALL DPWRST('XXX','ERRO ')
          IERROR='YES'
          GOTO9000
        ENDIF
 5101   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
     1         'OF THE POOLED COVARIANCE MATRIX.')
 5102   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1         ' OTHER COLUMNS.')
 5103   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
        IJOB=1
        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,XMEANS,IJOB)
C
        CALL GRPMEA(Z,ZMEANS,MAXROM,MAXHOT,NR1,NC1,
     1            X,XIDTEM,NIJUNK,N2,NGROUP,XMEANS,IBUGG3,IERROR)
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          DO5151J=1,NC1
            WRITE(ICOUT,5153)J,XMEANS(J)
 5153       FORMAT('     MEAN FOR VARIABLE ',I8,' = ',E15.7)
          CALL DPWRST('XXX','BUG  ')
 5151     CONTINUE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
        ISTEPN='51A'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NP=NUMVAR-1
        NK=NGROUP
        J=0
        DO5110ISET=1,NGROUP
c
          DO5120L=1,NC1
            TEMP(L)=ZMEANS(ISET,L) - XMEANS(L)
 5120     CONTINUE
          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
     1                XQUAD,IBUGG3,IERROR)
          NI=NIJUNK(ISET)
          ANI=REAL(NI)
C
          C=REAL(NK*NI*NP - NK*NP - NI*NP + NP)/
     1      REAL(NK*NI - NK - NP + 1)
          ALPHA=2.0*0.00135*REAL(NP)
          IDEG2=NK*NI-NK-NP+1
C
          IF(NI.LE.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5131)
 5131       FORMAT('***** INTERNAL ERROR IN DPHTC2--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5132)
 5132       FORMAT('NI FOR SOME CLASS = 0')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5133)ISET,XIDTEM(ISET),NI
 5133       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ELSEIF(IDEG2.LE.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5136)
 5136       FORMAT('***** ERROR IN DPHTC2--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5137)ISET
 5137       FORMAT('      ZERO OR NEGATIVE DEGREES OF FREEDOM FOR THE ',
     1             'F-CDF VALUE FOR SET ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5138)NI
 5138       FORMAT('      GROUP SIZE (NI)          = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5139)NK
 5139       FORMAT('      NUMBER OF SETS (NK)      = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5141)NP
 5141       FORMAT('      NUMBER OF VARIABLES (NP) = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5143)IDEG2
 5143       FORMAT('      DEGREES OF FREEDOM = NK*NI-NK-NP+1 = ',I8)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
C
          ALPHA2=1.0-ALPHA
          CALL FPPF(ALPHA2,NP,IDEG2,PPF)
C
          YTEMP=ANI*XQUAD
          YUPPER=C*PPF
C
          J=J+1
          Y2(J)=YTEMP
          X2(J)=XIDTEM(ISET)
          D2(J)=1.0
C
CCCCC     J=J+1
CCCCC     Y2(J)=0.0
CCCCC     X2(J)=XIDTEM(ISET)
CCCCC     D2(J)=2.0
C
          J=J+1
          Y2(J)=YUPPER
          X2(J)=XIDTEM(ISET)
          D2(J)=2.0
C
          IF(CCUSL.EQ.CPUMIN)GOTO5172
          J=J+1
          Y2(J)=CCUSL
          X2(J)=XIDTEM(ISET)
          D2(J)=3.0
 5172     CONTINUE
C
 5110   CONTINUE
        N2=J
        NPLOTV=3
C
C               **********************************************
C               **  STEP 5.2--                              **
C               **  TREAT THE PHASE II (GROUP) HOTELLING    **
C               **  CONTROL CHART CASE                      **
C               **********************************************
C
      ELSEIF(ICASPL.EQ.'HT2G')THEN
        ISTEPN='5.2'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC FIRST STEP: DETERMINE WHICH VALUES REPRESENT "HISTORICAL"
CCCCC AND WHICH REPRESENT "FUTURE".  THE ZHIST MATRIX WILL CONSIST
CCCCC OF THOSE GROUPS THAT ARE "HISTORICAL" AND ALSO THAT WERE NOT
CCCCC DISCARDED.  NOTE THAT IF EVEN ONE VALUE IN A GROUP IS DISCARDED,
CCCCC THEN ENTIRE GROUP IS DISCARDED.
C
        CALL DISTIN(X,NR1,IWRITE,TEMP,NGRP,IBUGG3,IERROR)
C
        IROW=0
        NA=0
        DO5209I=1,NGRP
          ISTAT=0
          AGROUP=TEMP(I)
          DO5201J=1,NR1
            IF(X(J).EQ.AGROUP)THEN
              ATEMP=XHIST(J)
              IF(ABS(ATEMP).LE.0.5)THEN
                CONTINUE
              ELSEIF(ATEMP.GT.0.5)THEN
                IF(ISTAT.EQ.0)ISTAT=1
              ELSEIF(ATEMP.LT.-0.5)THEN
                ISTAT=-1
              ENDIF
            ENDIF
 5201     CONTINUE
          IGRPST(I)=ISTAT
          IF(ISTAT.LT.0)NA=NA+1
          IF(ISTAT.EQ.0)THEN
            DO5203J=1,NR1
              IF(X(J).EQ.AGROUP)THEN
                IROW=IROW+1
                DO5205L=1,NC1
                  ZHIST(IROW,L)=Z(J,L)
                  XGROUP(IROW)=AGROUP
 5205           CONTINUE
              ENDIF
 5203       CONTINUE
          ENDIF
 5209   CONTINUE
        NHIST=IROW
C
        CALL VARPO2(ZHIST,ZMEANS,SPOOL,MAXROM,MAXHOT,NHIST,NC1,MAXHOT,
     1              XGROUP,XIDTEM,NIJUNK,NGROUP,DMEAN,IBUGG3,IERROR)
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5261)
 5261     FORMAT('**** HOTELLING PHASE II CONTROL CHART ',
     1           'FOR SUBGROUPS')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5263)NHIST
 5263     FORMAT('     NUMBER OF HISTORICAL OBSERVATIONS   = ',I8)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5264)
 5264     FORMAT('     COVARIANCE MATRIX (USING HISTORICAL ',
     1           'OBSERVATIONS, MAXIMUM OF 5 COLUMNS PRINTED)')
          CALL DPWRST('XXX','BUG ')
          DO5266J=1,NC1
            WRITE(ICOUT,5268)(SPOOL(J,L),L=1,MIN(NC1,5))
            CALL DPWRST('XXX','BUG ')
 5266     CONTINUE
 5268     FORMAT(6X,5E15.7)
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
C
        IF(1.0+RCOND.EQ.1.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5211)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5212)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5213)
          CALL DPWRST('XXX','ERRO ')
          IERROR='YES'
          GOTO9000
        ENDIF
 5211   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
     1         'OF THE POOLED COVARIANCE MATRIX.')
 5212   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1         ' OTHER COLUMNS.')
 5213   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
        IJOB=1
        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,XMEANS,IJOB)
C
C  CALL GRPMEA TWICE.  FIRST TIME TO GET MEAN OF MEANS
C  (XMEANS) BASED ON HISTORICAL DATA ONLY.  SECOND TIME TO GET GROUP
C  MEANS (ZMEANS) FOR ALL SUBGROUPS (HISTORICAL AND FUTURE).
C
        CALL GRPMEA(ZHIST,ZMEANS,MAXROM,MAXHOT,NHIST,NC1,
     1            XGROUP,XIDTEM,NIJUNK,N2,NGROUP,TEMP,IBUGG3,IERROR)
C
        CALL GRPMEA(Z,ZMEANS,MAXROM,MAXHOT,NR1,NC1,
     1            X,XIDTEM,NIJUNK,N2,NGROUP,XMEANS,IBUGG3,IERROR)
        DO5218J=1,NGROUP
          XMEANS(J)=TEMP(J)
 5218   CONTINUE
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          DO5251J=1,NC1
            WRITE(ICOUT,5253)J,XMEANS(J)
 5253       FORMAT('     MEAN FOR VARIABLE ',I8,' (USING HISTORICAL ',
     1             'OBSERVATIONS) = ',E15.7)
          CALL DPWRST('XXX','BUG ')
 5251     CONTINUE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        ISTEPN='52A'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        NP=NUMVAR-2
        NK=NGROUP
        ALPHA=2.0*0.00135*REAL(NP)
        ALPHA2=1.0-ALPHA
        J=0
        DO5290ISET=1,NGROUP
C
CCCCCC    DON'T PLOT HISTORICAL DATA
C
          DTAG=1.0
          IF(IGRPST(ISET).GT.0)DTAG=2.0
          IF(IGRPST(ISET).LT.0)GOTO5290
C
          DO5220L=1,NC1
            TEMP(L)=ZMEANS(ISET,L) - XMEANS(L)
 5220     CONTINUE
          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
     1                XQUAD,IBUGG3,IERROR)
          NI=NIJUNK(ISET)
          ANI=REAL(NI)
C
          C=REAL(NP*(NK-NA+1)*(NI-1))/REAL((NK-NA)*NI-NK+NA-NP+1)
          IDEG2=(NK-NA)*NI - NK + NA - NP + 1
C
          IF(NI.LE.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5231)
 5231       FORMAT('***** INTERNAL ERROR IN DPHTC2--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5232)
 5232       FORMAT('NI FOR SOME CLASS = 0')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5233)ISET,XIDTEM(ISET),NI
 5233       FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ELSEIF(IDEG2.LE.0)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5236)
 5236       FORMAT('***** ERROR IN DPHTC2--')
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5237)ISET
 5237       FORMAT('      ZERO OR NEGATIVE DEGREES OF FREEDOM FOR THE ',
     1             'F-CDF VALUE FOR SET ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5238)NI
 5238       FORMAT('      GROUP SIZE (NI)          = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5239)NK
 5239       FORMAT('      NUMBER OF SETS (NK)      = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5241)NP
 5241       FORMAT('      NUMBER OF VARIABLES (NP) = ',I8)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,5243)IDEG2
 5243       FORMAT('      DEGREES OF FREEDOM = NK*NI-NK-NP+1 = ',I8)
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
C
          CALL FPPF(ALPHA2,NP,IDEG2,PPF)
C
          YTEMP=ANI*XQUAD
          YUPPER=C*PPF
C
          J=J+1
          Y2(J)=YTEMP
          X2(J)=XIDTEM(ISET)
          D2(J)=DTAG
C
CCCCC     J=J+1
CCCCC     Y2(J)=0.0
CCCCC     X2(J)=XIDTEM(ISET)
CCCCC     D2(J)=3.0
C
          J=J+1
          Y2(J)=YUPPER
          X2(J)=XIDTEM(ISET)
          D2(J)=3.0
C
          IF(CCUSL.EQ.CPUMIN)GOTO5272
          J=J+1
          Y2(J)=CCUSL
          X2(J)=XIDTEM(ISET)
          D2(J)=4.0
 5272     CONTINUE
C
 5290   CONTINUE
        N2=J
        NPLOTV=3
C
C               **********************************************
C               **  STEP 5.3--                              **
C               **  TREAT THE PHASE I (INDIVIDUAL) HOTELLING**
C               **  CONTROL CHART CASE                      **
C               **********************************************
C
      ELSEIF(ICASPL.EQ.'HT1I')THEN
        ISTEPN='5.3'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        IWRITE='OFF'
C
        CALL COVMAT(Z,SPOOL,DMEAN,MAXROM,NR1,NUMVAR,MAXHOT)
        DO5303L=1,NUMVAR
          DO5305J=1,NR1
            TEMP(J)=Z(J,L)
 5305     CONTINUE
          CALL MEAN(TEMP,NR1,IWRITE,RIGHT,IBUGG3,IERROR)
          XMEANS(L)=RIGHT
 5303   CONTINUE
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5361)
 5361     FORMAT('**** HOTELLING PHASE I CONTROL CHART ',
     1           'FOR INDIVIDUAL OBSERVATIONS')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5364)
 5364     FORMAT('     COVARIANCE MATRIX (MAXIMUM OF 5 COLUMNS ',
     1           'PRINTED)')
          CALL DPWRST('XXX','BUG ')
          DO5366J=1,NC1
            WRITE(ICOUT,5368)(SPOOL(J,L),L=1,MIN(NC1,5))
            CALL DPWRST('XXX','BUG ')
 5366     CONTINUE
 5368     FORMAT(6X,5E15.7)
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          DO5351J=1,NC1
            WRITE(ICOUT,5353)J,XMEANS(J)
 5353       FORMAT('     MEAN FOR VARIABLE ',I8,' = ',E15.7)
            CALL DPWRST('XXX','BUG ')
 5351     CONTINUE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
C
        IF(1.0+RCOND.EQ.1.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5371)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5372)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5373)
          CALL DPWRST('XXX','ERRO ')
          IERROR='YES'
          GOTO9000
        ENDIF
 5371   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
     1         'OF THE COVARIANCE MATRIX.')
 5372   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1         ' OTHER COLUMNS.')
 5373   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
        IJOB=1
        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,ZMEANS,IJOB)
C
        ISTEPN='53A'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
          DO5381J=1,NC1
            WRITE(ICOUT,5383)J,(SPOOL(J,L),L=1,NC1)
            CALL DPWRST('XXX','ERRO ')
 5381     CONTINUE
 5383     FORMAT('SPOOL: ROW ',I8,' = ',15F15.7)
        ENDIF
C
        NP=NC1
        AM=REAL(NR1)
        AFACT=(AM-1.0)**2/AM
        A=REAL(NP)/2.0
        B=(AM-REAL(NP)-1.0)/2.0
        ALPHA2=ALPHA/2.0
        CALL BETPPF(ALPHA2,A,B,YLOWER)
        YLOWER=AFACT*YLOWER
        ALPHA2=1.0 - ALPHA/2.0
        CALL BETPPF(ALPHA2,A,B,YUPPER)
        YUPPER=AFACT*YUPPER
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
          WRITE(ICOUT,5391)ISET,XQUAD,AM,AFACT,ALPHA
 5391     FORMAT('ISET,XQUAD,AM,AFACT = ',I8,4F15.7)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5393)A,B,YLOWER,YUPPER
 5393     FORMAT('A,B,YLOWER,YUPPER = ',4F15.7)
          CALL DPWRST('XXX','ERRO ')
        ENDIF
C
        J=0
        DO5310ISET=1,NR1
C
          DO5320L=1,NC1
            TEMP(L)=Z(ISET,L) - XMEANS(L)
 5320     CONTINUE
          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
     1                XQUAD,IBUGG3,IERROR)
C
          YTEMP=XQUAD
C
          J=J+1
          Y2(J)=YTEMP
          X2(J)=REAL(ISET)
          D2(J)=1.0
C
CCCCC     J=J+1
CCCCC     Y2(J)=0.0
CCCCC     X2(J)=REAL(ISET)
CCCCC     D2(J)=2.0
C
          J=J+1
          Y2(J)=YUPPER
          X2(J)=REAL(ISET)
          D2(J)=2.0
C
          J=J+1
          Y2(J)=YLOWER
          X2(J)=REAL(ISET)
          D2(J)=3.0
C
          IF(CCUSL.EQ.CPUMIN)GOTO5352
          J=J+1
          Y2(J)=CCUSL
          X2(J)=REAL(ISET)
          D2(J)=4.0
 5352     CONTINUE
C
          IF(CCLSL.EQ.CPUMAX)GOTO5354
          J=J+1
          Y2(J)=CCLSL
          X2(J)=REAL(ISET)
          D2(J)=5.0
 5354     CONTINUE
C
 5310   CONTINUE
        N2=J
        NPLOTV=3
C
C               **********************************************
C               **  STEP 5.4--                              **
C               **  TREAT THE PHASE II (INDIVIDUAL) HOTELLING*
C               **  CONTROL CHART CASE                      **
C               **********************************************
C
      ELSEIF(ICASPL.EQ.'HT2I')THEN
        ISTEPN='5.4'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')
     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
        IWRITE='OFF'
C
C  USE X2 TO DETERMINE WHICH DATA POINTS ARE HISTORICAL AND
C  WHICH ARE FUTURE
C
        IROW=0
        DO5401I=1,NR1
          IF(ABS(XHIST(I)).LE.0.5)THEN
            IROW=IROW+1
            DO5402J=1,NC1
              ZHIST(IROW,J)=Z(I,J)
 5402       CONTINUE
          ENDIF
 5401   CONTINUE
        NHIST=IROW
C
        IF(NHIST.LE.2)THEN
          WRITE(ICOUT,5421)
 5421     FORMAT('**** ERROR FROM PHASE II HOTELLING INDIVIDUAL ',
     1           'CONTROL CHART')
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5423)NHIST
 5423     FORMAT('     INSUFFICIENT NUMBER OF HISTORICAL VALUES FOUND ',
     1           '(',I8,' FOUND)')
          CALL DPWRST('XXX','ERRO ')
          IERROR='YES'
          GOTO9000
        ENDIF
C
        CALL COVMAT(ZHIST,SPOOL,DMEAN,MAXROM,NHIST,NC1,MAXHOT)
C
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
          ISTEPN='54A'
          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
          WRITE(ICOUT,5487)NHIST
 5487     FORMAT('NHIST = ',I8)
          CALL DPWRST('XXX','ERRO ')
          DO5486J=1,NC1
            WRITE(ICOUT,5488)J,(SPOOL(J,L),L=1,MIN(NC1,15))
            CALL DPWRST('XXX','ERRO ')
 5486     CONTINUE
 5488     FORMAT('COV: ROW ',I8,' = ',15F15.7)
        ENDIF
C
        DO5403L=1,NC1
          DO5405J=1,NHIST
            TEMP(J)=ZHIST(J,L)
 5405     CONTINUE
          CALL MEAN(TEMP,NHIST,IWRITE,RIGHT,IBUGG3,IERROR)
          XMEANS(L)=RIGHT
 5403   CONTINUE
C
        IF(IFEEDB.EQ.'ON')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5461)
 5461     FORMAT('**** HOTELLING PHASE II CONTROL CHART ',
     1           'FOR INDIVIDUAL OBSERVATIONS')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5463)NHIST
 5463     FORMAT('     NUMBER OF HISTORICAL OBSERVATIONS   = ',I8)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5464)
 5464     FORMAT('     COVARIANCE MATRIX (USING HISTORICAL ',
     1           'OBSERVATIONS, MAXIMUM OF 5 COLUMNS PRINTED)')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          DO5466J=1,NC1
            WRITE(ICOUT,5468)(SPOOL(J,L),L=1,MIN(NC1,5))
            CALL DPWRST('XXX','BUG ')
 5466     CONTINUE
 5468     FORMAT(6X,5E15.7)
          DO5451J=1,NC1
            WRITE(ICOUT,5453)J,XMEANS(J)
 5453       FORMAT('     MEAN FOR VARIABLE ',I8,' (USING HISTORICAL ',
     1             'OBSERVATIONS) = ',E15.7)
          CALL DPWRST('XXX','BUG ')
 5451     CONTINUE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        CALL SGECO(SPOOL,MAXHOT,NC1,INDEX,RCOND,TEMP)
C
        IF(1.0+RCOND.EQ.1.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,5471)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5472)
          CALL DPWRST('XXX','ERRO ')
          WRITE(ICOUT,5473)
          CALL DPWRST('XXX','ERRO ')
          IERROR='YES'
          GOTO9000
        ENDIF
 5471   FORMAT('*** ERROR FROM DPHTC2: UNABLE TO COMPUTE THE INVERSE ',
     1         'OF THE COVARIANCE MATRIX.')
 5472   FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1         ' OTHER COLUMNS.')
 5473   FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
        IJOB=1
        CALL SGEDI(SPOOL,MAXHOT,NC1,INDEX,TEMP,ZMEANS,IJOB)
C
        ISTEPN='54B'
        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
          DO5481J=1,NC1
            WRITE(ICOUT,5483)J,(SPOOL(J,L),L=1,MIN(15,NC1))
            CALL DPWRST('XXX','ERRO ')
 5481     CONTINUE
 5483     FORMAT('SPOOL: ROW ',I8,' = ',15F15.7)
        ENDIF
C
C
        NP=NC1
        AM=REAL(NHIST)
        AFACT=REAL(NP)*(AM+1.0)*(AM-1.0)/(AM*AM - AM*REAL(NP))
        IDF1=NP
        IDF2=NHIST-NP
        ALPHA2=ALPHA/2.0
        CALL FPPF(ALPHA2,IDF1,IDF2,YLOWER)
        YLOWER=AFACT*YLOWER
        ALPHA2=1.0-ALPHA/2.0
        CALL FPPF(ALPHA2,IDF1,IDF2,YUPPER)
        YUPPER=AFACT*YUPPER
C
        J=0
        DO5410ISET=1,NR1
C
          DTAG=2.0
          IF(XHIST(ISET).LE.0.5)DTAG=1.0
          IF(XHIST(ISET).LT.-0.5)GOTO5410
C
          DO5420L=1,NC1
            TEMP(L)=Z(ISET,L) - XMEANS(L)
 5420     CONTINUE
          CALL QUAFRM(SPOOL,MAXHOT,MAXHOT,NC1,NC1,TEMP,IWRITE,
     1                XQUAD,IBUGG3,IERROR)
C
          YTEMP=XQUAD
C
          J=J+1
          Y2(J)=YTEMP
          X2(J)=REAL(ISET)
          D2(J)=DTAG
C
CCCCC     J=J+1
CCCCC     Y2(J)=0.0
CCCCC     X2(J)=REAL(ISET)
CCCCC     D2(J)=2.0
C
          J=J+1
          Y2(J)=YUPPER
          X2(J)=REAL(ISET)
          D2(J)=3.0
C
          J=J+1
          Y2(J)=YLOWER
          X2(J)=REAL(ISET)
          D2(J)=4.0
C
          IF(CCUSL.EQ.CPUMIN)GOTO5452
          J=J+1
          Y2(J)=CCUSL
          X2(J)=REAL(ISET)
          D2(J)=5.0
 5452     CONTINUE
C
          IF(CCLSL.EQ.CPUMAX)GOTO5454
          J=J+1
          Y2(J)=CCLSL
          X2(J)=REAL(ISET)
          D2(J)=6.0
 5454     CONTINUE
C
 5410   CONTINUE
        N2=J
        NPLOTV=3
C
      ENDIF
C
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'HTC2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPHTC2--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPHTM1(CAPTN,NCAP,IFLAG1,IFLAG2)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO INITIATE
C              THE HTML OUTPUT AND STARTS THE FIRST TABLE.
C              THE ONLY OPTIONAL ELEMENT IS THE CAPTION.
C     INPUT  ARGUMENTS--CAPTN  = THE CHARACTER STRING CONTAINING
C                                THE CAPTION.
C                     --NCAP   = THE INTEGER NUMBER THAT SPECIFIES
C                                THE NUMBER OF CHARACTERS IN THE
C                                CAPTION.
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--2005/2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      LOGICAL IFLAG1
      LOGICAL IFLAG2
C
      CHARACTER*(*) CAPTN
C
      CHARACTER*10 IFORMT
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
C  STEP 1: END ASIS MODE AND WRITE A HEADER
C
  999 FORMAT(1X)
 5001 FORMAT('
') IF(IFLAG1)THEN WRITE(ICOUT,5001) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C C STEP 2: START TABLE AND DEFINE A CAPTION C 5011 FORMAT('
    ') 5013 FORMAT('') 5015 FORMAT(' ') IF(IFLAG2)THEN IFORMT=' ' IFORMT(1:8)='(6X,A )' WRITE(IFORMT(6:7),'(I2)')NCAP WRITE(ICOUT,5011) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5013) CALL DPWRST('XXX','WRIT') IF(NCAP.GT.0)THEN WRITE(ICOUT,5015) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5019) CALL DPWRST('XXX','WRIT') ENDIF ENDIF C RETURN END SUBROUTINE DPHTM2(IFLAG1,IFLAG2,NHEAD) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C HTML OUTPUT. THIS ROUTINE IS USED TO CLOSE THE C CURRENT TABLE AND TERMINATE THE HTML OUTPUT. 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C LOGICAL IFLAG1 LOGICAL IFLAG2 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 C STEP 1: END THE CURRENT TABLE C 999 FORMAT(1X) 5191 FORMAT('
    ') 5019 FORMAT('
    ') 5193 FORMAT('
') IF(IFLAG1)THEN WRITE(ICOUT,5191) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5193) CALL DPWRST('XXX','WRIT') ENDIF C C STEP 2: RESET "ASIS" MODE C 5199 FORMAT('
')
      IF(IFLAG2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5199)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPHTM3(IVALUE,NCHAR,AVALUE,NUMDIG,IWIDT1,IWIDT2)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
C              ONE ROW OF A TABLE WHERE:
C
C                 COLUMN 1: A TEXT STRING
C                 COLUMN 2: A NUMERIC VALUE
C
C              IF NCHAR = 0, A SINGLE SPACE WILL BE INSERTED,
C              IF NUMDIG = 0, AN INTEGER FORMAT WILL BE USED,
C              IF NUMDIG = -1, A SINGLE SPACE WILL BE INSERTED,
C              IF NUMDIG = -2, A DEFAULT FORMAT WILL BE USED.
C               
C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
C                                 THE CHARACTER VALUE.
C                     --NCHAR   = THE INTEGER NUMBER THAT SPECIFIES
C                                 THE NUMBER OF CHARACTERS IN THE
C                                 CHARACTER STRING.
C                     --AVALUE  = THE NUMERIC VALUE TO BE PRINTED.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) IVALUE
C
      CHARACTER*10 IFORMT
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
C  STEP 3: DEFINE A DATA ROW
C
  999 FORMAT(1X)
 5041 FORMAT('   ')
 5043 FORMAT('      ')
 5047 FORMAT('      ')
 5049 FORMAT('      ')
 5031 FORMAT('         ',G15.7)
 5033 FORMAT('         ',I8)
 5035 FORMAT('          ')
 5039 FORMAT('   ')
C
      WRITE(ICOUT,5041)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5043)IWIDT1
      CALL DPWRST('XXX','WRIT')
      IF(NCHAR.GT.0)THEN
        IFORMT=' '
        IFORMT(1:8)='(9X,A  )'
        WRITE(IFORMT(6:7),'(I2)')NCHAR
        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
        CALL DPWRST('XXX','WRIT')
      ELSE
        WRITE(ICOUT,5035)
        CALL DPWRST('XXX','WRIT')
      ENDIF
      WRITE(ICOUT,5047)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5049)IWIDT2
      CALL DPWRST('XXX','WRIT')
      IF(NUMDIG.GT.0)THEN
        IFORMT=' '
        IFORMT(1:10)='(9X,F15. )'
        WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG,9)
        WRITE(ICOUT,IFORMT)AVALUE
        CALL DPWRST('XXX','WRIT')
      ELSEIF(NUMDIG.EQ.0)THEN
        WRITE(ICOUT,5033)INT(AVALUE+0.5)
        CALL DPWRST('XXX','WRIT')
      ELSEIF(NUMDIG.EQ.-1)THEN
        WRITE(ICOUT,5035)
        CALL DPWRST('XXX','WRIT')
      ELSEIF(NUMDIG.EQ.-2)THEN
        WRITE(ICOUT,5031)AVALUE
        CALL DPWRST('XXX','WRIT')
      ENDIF
      WRITE(ICOUT,5047)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5039)
      CALL DPWRST('XXX','WRIT')
C
      RETURN
      END
      SUBROUTINE DPHTM4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
C              A HEADER ROW FOR A TABLE.  YOU CAN ALSO OPTIONALLY
C              ADD A RULE LINE BEFORE OR AFTER THE HEADER.
C
C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING ARRAY
C                                 CONTAINING THE TEXT FOR THE
C                                 HEADER VALUES.
C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
C                                 THE NUMBER OF CHARACTERS IN THE
C                                 HEADER VALUES.
C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
C                                 THE NUMBER OF HEADER VALUES.
C                     --IFLAG1  = A LOGICAL VALUE THAT SPECIFIES
C                                 WHETHER A RULE LINE IS DRAWN BEFORE
C                                 THE HHEADER.
C                     --IFLAG2  = A LOGICAL VALUE THAT SPECIFIES
C                                 WHETHER A RULE LINE IS DRAWN AFTER
C                                 THE HHEADER.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) IVALUE(NHEAD)
      INTEGER NCHAR(NHEAD)
C
      PARAMETER (MAXHED=50)
      INTEGER IWIDTH(MAXHED)
      INTEGER NUMDIG(MAXHED)
      CHARACTER*8 ALIGN(MAXHED)
      CHARACTER*8 VALIGN(MAXHED)
      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
C
      LOGICAL IFLAG1
      LOGICAL IFLAG2
C
      CHARACTER*10 IFORMT
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
C  STEP 3: DEFINE A DATA ROW
C
  999 FORMAT(1X)
C
C  FOLLOWING ADDS A RULE LINE BEFORE THE HEADER LINE
C
 5021 FORMAT('   ')
 5061 FORMAT('      ')
 5062 FORMAT('          
')
 5047 FORMAT('      ')
 5039 FORMAT('   ')
      IF(IFLAG1)THEN
        WRITE(ICOUT,5021)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5061)NHEAD
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5062)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C  GENERATE A HEADER LINE
C
 5023 FORMAT('      ')
 5027 FORMAT('      ')
 5029 FORMAT('      ')
      IF(NHEAD.GE.1)THEN
        WRITE(ICOUT,5021)
        CALL DPWRST('XXX','WRIT')
        DO100I=1,NHEAD
          WRITE(ICOUT,5023)ALIGN(I),VALIGN(I),IWIDTH(I)
          CALL DPWRST('XXX','WRIT')
          IFORMT=' '
          IFORMT(1:8)='(9X,A  )'
          WRITE(IFORMT(6:7),'(I2)')NCHAR(I)
          WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I))
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5027)
          CALL DPWRST('XXX','WRIT')
  100   CONTINUE
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C  FOLLOWING ADDS A RULE LINE AFTER THE HEADER LINE
C
      IF(IFLAG2)THEN
        WRITE(ICOUT,5021)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5061)NHEAD
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5062)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPHTM5(IVALUE,NCHAR,AVALUE,NHEAD)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
C              A DATA ROW FOR A TABLE.  THE FIRST FIELD CAN
C              BE A TEXT VALUE (FOR A ROW LABEL).
C
C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
C                                 THE TEXT FOR THE FIRST COLUMN.
C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
C                                 THE NUMBER OF CHARACTERS IN THE
C                                 FIRST TEXT FIELD.
C                     --AVALUE  = A REAL ARRAY CONTAINING THE DATA
C                                 TO BE GENERATED.
C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
C                                 THE NUMBER OF NUMERIC VALUES.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005/2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) IVALUE
      REAL AVALUE(NHEAD)
      INTEGER NCHAR
C
      PARAMETER (MAXHED=50)
      INTEGER IWIDTH(MAXHED)
      INTEGER NUMDIG(MAXHED)
      CHARACTER*8 ALIGN(MAXHED)
      CHARACTER*8 VALIGN(MAXHED)
      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
C
      CHARACTER*10 IFORMT
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
C  STEP 3: DEFINE A DATA ROW
C
  999 FORMAT(1X)
C
C  GENERATE A DATA LINE
C
 5021 FORMAT('   ')
 5039 FORMAT('   ')
 5023 FORMAT('      ')
 5024 FORMAT('         ')
 5025 FORMAT('         ')
 5027 FORMAT('      ')
 5029 FORMAT('      ')
C
      IF(NCHAR.GT.0)THEN
        WRITE(ICOUT,5021)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5023)ALIGN(1),VALIGN(1),IWIDTH(1)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5024)
        CALL DPWRST('XXX','WRIT')
        IFORMT=' '
        IFORMT(1:8)='(9X,A  )'
        WRITE(IFORMT(6:7),'(I2)')NCHAR
        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5025)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5027)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
 5031 FORMAT('         ',G15.7)
 5033 FORMAT('         ',I8)
 5035 FORMAT('          ')
      IF(NHEAD.GE.1)THEN
        WRITE(ICOUT,5021)
        CALL DPWRST('XXX','WRIT')
        DO100I=1,NHEAD
          WRITE(ICOUT,5023)ALIGN(I+1),VALIGN(I+1),IWIDTH(I+1)
          CALL DPWRST('XXX','WRIT')
          IF(NUMDIG(I).GT.0)THEN
            IFORMT=' '
            IFORMT(1:10)='(9X,F15. )'
            WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG(I),9)
            WRITE(ICOUT,IFORMT)AVALUE(I)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.0)THEN
            WRITE(ICOUT,5033)INT(AVALUE(I)+0.5)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.-1)THEN
            WRITE(ICOUT,5035)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.-2)THEN
            WRITE(ICOUT,5031)AVALUE(I)
            CALL DPWRST('XXX','WRIT')
          ENDIF
          WRITE(ICOUT,5027)
          CALL DPWRST('XXX','WRIT')
  100   CONTINUE
        WRITE(ICOUT,5039)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPHTM6(NHEAD)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO DRAW A RULE
C              LINE SPANNING NHEAD COLUMNS.
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--2005/2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
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
C  FOLLOWING ADDS A RULE LINE
C
 5021 FORMAT('   ')
 5061 FORMAT('      ')
 5062 FORMAT('          
')
 5047 FORMAT('      ')
 5039 FORMAT('   ')
      WRITE(ICOUT,5021)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5061)NHEAD
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5062)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5047)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,5039)
      CALL DPWRST('XXX','WRIT')
      RETURN
      END
      SUBROUTINE DPHTM7(IVALUE,NCHAR,AVALUE,NHEAD,IVAL2,NCHAR2)
C
C     PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING
C              HTML OUTPUT.  THIS ROUTINE IS USED TO GENERATE
C              A DATA ROW FOR A TABLE.  THE FIRST AND LAST FIELDS
C              CAN BE A TEXT VALUE (FOR A ROW LABEL).
C
C     INPUT  ARGUMENTS--IVALUE  = THE CHARACTER STRING CONTAINING
C                                 THE TEXT FOR THE FIRST COLUMN.
C                     --NCHAR   = THE INTEGER ARRAY THAT SPECIFIES
C                                 THE NUMBER OF CHARACTERS IN THE
C                                 FIRST TEXT FIELD.
C                     --AVALUE  = A REAL ARRAY CONTAINING THE DATA
C                                 TO BE GENERATED.
C                     --NHEAD   = THE INTEGER VALUE THAT SPECIFIES
C                                 THE NUMBER OF NUMERIC VALUES.
C                     --IVAL2   = THE CHARACTER STRING CONTAINING
C                                 THE TEXT FOR THE LAST COLUMN.
C                     --NCHAR2  = THE INTEGER ARRAY THAT SPECIFIES
C                                 THE NUMBER OF CHARACTERS IN THE
C                                 LAST TEXT FIELD.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/11
C     ORIGINAL VERSION--NOVEMBER  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) IVALUE
      CHARACTER*(*) IVAL2
      REAL AVALUE(NHEAD)
      INTEGER NCHAR
C
      PARAMETER (MAXHED=50)
      INTEGER IWIDTH(MAXHED)
      INTEGER NUMDIG(MAXHED)
      CHARACTER*8 ALIGN(MAXHED)
      CHARACTER*8 VALIGN(MAXHED)
      COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN
C
      CHARACTER*10 IFORMT
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
C  STEP 3: DEFINE A DATA ROW
C
  999 FORMAT(1X)
C
C  GENERATE A DATA LINE
C
 5021 FORMAT('   ')
 5039 FORMAT('   ')
 5023 FORMAT('      ')
 5024 FORMAT('         ')
 5025 FORMAT('         ')
 5027 FORMAT('      ')
 5029 FORMAT('      ')
C
      WRITE(ICOUT,5021)
      CALL DPWRST('XXX','WRIT')
C
      IF(NCHAR.GT.0)THEN
        WRITE(ICOUT,5023)ALIGN(1),VALIGN(1),IWIDTH(1)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5024)
        CALL DPWRST('XXX','WRIT')
        IFORMT=' '
        IFORMT(1:8)='(9X,A  )'
        WRITE(IFORMT(6:7),'(I2)')NCHAR
        WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5025)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5027)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
 5031 FORMAT('         ',G15.7)
 5033 FORMAT('         ',I8)
 5035 FORMAT('          ')
      IF(NHEAD.GE.1)THEN
        DO100I=1,NHEAD
          WRITE(ICOUT,5023)ALIGN(I+1),VALIGN(I+1),IWIDTH(I+1)
          CALL DPWRST('XXX','WRIT')
          IF(NUMDIG(I).GT.0)THEN
            IFORMT=' '
            IFORMT(1:10)='(9X,F15. )'
            WRITE(IFORMT(9:9),'(I1)')MIN(NUMDIG(I),9)
            WRITE(ICOUT,IFORMT)AVALUE(I)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.0)THEN
            WRITE(ICOUT,5033)INT(AVALUE(I)+0.5)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.-1)THEN
            WRITE(ICOUT,5035)
            CALL DPWRST('XXX','WRIT')
          ELSEIF(NUMDIG(I).EQ.-2)THEN
            WRITE(ICOUT,5031)AVALUE(I)
            CALL DPWRST('XXX','WRIT')
          ENDIF
          WRITE(ICOUT,5027)
          CALL DPWRST('XXX','WRIT')
  100   CONTINUE
      ENDIF
C
      IF(NCHAR2.GT.0)THEN
        WRITE(ICOUT,5023)ALIGN(NHEAD+2),VALIGN(NHEAD+2),
     1                   IWIDTH(NHEAD+2)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5024)
        CALL DPWRST('XXX','WRIT')
        IFORMT=' '
        IFORMT(1:8)='(9X,A  )'
        WRITE(IFORMT(6:7),'(I2)')NCHAR2
        WRITE(ICOUT,IFORMT)IVAL2(1:NCHAR2)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5025)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5027)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      WRITE(ICOUT,5039)
      CALL DPWRST('XXX','WRIT')
C
      RETURN
      END
      SUBROUTINE DPHW(ICOM,IHARG,IARGT,ARG,NUMARG,
     1PDEFHE,PDEFWI,
     1PTEXHE,PTEXWI,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE HEIGHT AND WIDTH FOR TEXT CHARACTERS.
C              THE HEIGHT FOR TEXT CHARACTERS WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE HEIGHT.
C              THE WIDTH FOR TEXT CHARACTERS WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE WIDTH.
C     INPUT  ARGUMENTS--ICOM (A CHARACTER VARIABLE).
C                     --IHARG  (A  CHARACTER VECTOR)
C                     --IARGT
C                     --ARG
C                     --NUMARG
C                     --PDEFHE
C                     --PDEFWI
C                     --IBUGD2
C     OUTPUT ARGUMENTS--PTEXHE
C                     --PTEXWI
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
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
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICOM
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
      CHARACTER*4 IBUGD2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
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
      IF(IBUGD2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPHW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ICOM
   52 FORMAT('ICOM = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NUMARG,PDEFHE,PDEFWI
   53 FORMAT('NUMARG,PDEFHE,PDEFWI = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)PTEXHE,PTEXWI
   54 FORMAT('PTEXHE,PTEXWI = ',2E15.7)
      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
   90 CONTINUE
C
C               ***************************************
C               **  TREAT THE HEIGHT AND WIDTH CASE  **
C               ***************************************
C
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1150
      IF(IHARG(1).EQ.'ON')GOTO1150
      IF(IHARG(1).EQ.'OFF')GOTO1150
      IF(IHARG(1).EQ.'AUTO')GOTO1150
      IF(IHARG(1).EQ.'DEFA')GOTO1150
      IF(IHARG(NUMARG).EQ.'?')GOTO8100
C
      IF(NUMARG.GE.2.AND.
     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
     1GOTO1160
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN DPHW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR HW OR WH ',
     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 IT IS DESIRED THAT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      THE TEXT CHARACTERS HAVE A HEIGHT OF 5')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      AND A WIDTH OF 3')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1128)
 1128 FORMAT('      (WHERE THE SCREEN UNITS RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1129)
 1129 FORMAT('      FROM 0 TO 100, AND WHERE THE HEIGHT AND WIDTH ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1130)
 1130 FORMAT('      EXCLUDES THE BETWEEN-LINE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1131)
 1131 FORMAT('     AND BETWEEN-CHARACTER GAP),')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1132)
 1132 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1133)
 1133 FORMAT('      HW 5 3 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1134)
 1134 FORMAT('      WH 3 5 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      PTEXHE=PDEFHE
      PTEXWI=PDEFWI
      GOTO1180
C
 1160 CONTINUE
      IF(ICOM.EQ.'HW')PTEXHE=ARG(1)
      IF(ICOM.EQ.'HW')PTEXWI=ARG(2)
      IF(ICOM.EQ.'WH')PTEXWI=ARG(1)
      IF(ICOM.EQ.'WH')PTEXHE=ARG(2)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE HEIGHT (FOR TEXT CHARACTERS)  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)PTEXHE
 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)
 1183 FORMAT('THE WIDTH  (FOR TEXT CHARACTERS)  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)PTEXWI
 1184 FORMAT('HAS JUST BEEN SET TO ',E15.7)
      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)PTEXHE
 8111 FORMAT('THE CURRENT (TEXT) HEIGHT IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8112)PTEXWI
 8112 FORMAT('THE CURRENT (TEXT) WIDTH  IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8121)PDEFHE
 8121 FORMAT('THE DEFAULT (TEXT) HEIGHT IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8122)PDEFWI
 8122 FORMAT('THE DEFAULT (TEXT) WIDTH  IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGD2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPHW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)PTEXHE,PTEXWI
 9013 FORMAT('PTEXHE,PTEXWI = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END