      SUBROUTINE DPDB80(ISTRIN,JMAX,IBUGS2,ISUBRO,IERROR)
C
C     PURPOSE--DETERMINE THE LAST NON-BLANK
C              CHARACTER IN THE CHARACTER*80
C              VARIABLE   ISTRIN    .
C              (THIS IS USEFUL FOR   DEBLANKING   A STRING.)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--86/1
C     ORIGINAL VERSION--DECEMBER  1985.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*80 ISTRIN
      CHARACTER*4 IBUGS2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
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='DPDB'
      ISUBN2='80  '
C
      IERROR='NO'
      JMAX=0
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DB80')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDB80--')
      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)(ISTRIN(J:J),J=1,80)
   54 FORMAT('(ISTRIN(J:J),J=1,80) = ',80A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)JMAX
   55 FORMAT('JMAX = ',I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************
C               **  STEP 1--            **
C               **  DETERMINE THE LAST  **
C               **  NON-BLANK CHARACTER **
C               **************************
C
      ISTEPN='1'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'DB80')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1100I=1,80
      IREV=80-I+1
      IF(ISTRIN(IREV:IREV).EQ.' ')GOTO1100
      GOTO1150
 1100 CONTINUE
      JMAX=0
      GOTO1190
 1150 CONTINUE
      JMAX=IREV
      GOTO1190
 1190 CONTINUE
C
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DB80')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDB80--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGS2,ISUBRO,IERROR
 9013 FORMAT('IBUGS2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)(ISTRIN(J:J),J=1,80)
 9014 FORMAT('(ISTRIN(J:J),J=1,80) = ',80A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)JMAX
 9015 FORMAT('JMAX = ',I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDCNT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE A DEX CONTOUR PLOT--
C              THE COMMAND HAS THE FOLLOWING FORMAT:
C                  DEX CONTOUR PLOT Z X1 X2 YCONT
C              WHERE X1 AND X2 ARE RESTRICTED TO HAVING VALUES
C              IN THE (-1,1) INTERVAL.
C     EXAMPLE--DEX CONTOUR PLOT Z X1 X2
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--99/12
C     ORIGINAL VERSION--DECEMBER      1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
      CHARACTER*4 IBUGG2
      CHARACTER*4 IBUGG3
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHRI11
      CHARACTER*4 IHRI12
      CHARACTER*4 IHRI21
      CHARACTER*4 IHRI22
      CHARACTER*4 IHRI31
      CHARACTER*4 IHRI32
      CHARACTER*4 IHRI41
      CHARACTER*4 IHRI42
      CHARACTER*4 IH
      CHARACTER*4 IH1
      CHARACTER*4 IH2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
C
      CHARACTER*4 IREPU
      CHARACTER*4 IRESU
C
      CHARACTER*4 ICASEQ
C
      CHARACTER*4 ISUBN0
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Z(MAXOBV)
      DIMENSION X1(MAXOBV)
      DIMENSION X2(MAXOBV)
      DIMENSION YCONT(MAXOBV)
      DIMENSION U1JUNK(MAXOBV)
      DIMENSION ZTEMP(MAXOBV)
      DIMENSION TEMP1(MAXOBV)
      DIMENSION X1TEMP(MAXOBV)
      DIMENSION X2TEMP(MAXOBV)
      DIMENSION PRED2(MAXOBV)
      DIMENSION RES2(MAXOBV)
C
      INCLUDE 'DPCOZZ.INC'
      EQUIVALENCE (GARBAG(IGARB1),Z(1))
      EQUIVALENCE (GARBAG(IGARB2),X1(1))
      EQUIVALENCE (GARBAG(IGARB3),X2(1))
      EQUIVALENCE (GARBAG(IGARB4),YCONT(1))
      EQUIVALENCE (GARBAG(IGARB5),TEMP1(1))
      EQUIVALENCE (GARBAG(IGARB6),U1JUNK(1))
      EQUIVALENCE (GARBAG(IGARB7),PRED2(1))
      EQUIVALENCE (GARBAG(IGARB8),RES2(1))
      EQUIVALENCE (GARBAG(IGARB9),X1TEMP(1))
      EQUIVALENCE (GARBAG(IGAR10),X2TEMP(1))
      EQUIVALENCE (GARBAG(JGAR11),ZTEMP(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHO.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
      IERROR='NO'
      IFOUND='NO'
C
      ISUBN1='DPDC'
      ISUBN2='NT  '
C
      ICASPL='DCON'
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=6
      MINN2=1
C
      ICOLH=0
C
C               ****************************************
C               **  TREAT THE DEX CONTOUR PLOT CASE   **
C               ****************************************
C
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDCNT--')
      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 ')
      WRITE(ICOUT,54)MAXN
   54 FORMAT('MAXN = ',I8)
      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.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONT'.AND.
     1   IHARG(2).EQ.'PLOT')GOTO112
      GOTO119
C
  112 CONTINUE
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO119
C
  119 CONTINUE
      IFOUND='YES'
      GOTO190
C
  190 CONTINUE
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               **  AT LEAST 1 REQUIRED                              **
C               *******************************************************
C
      ISTEPN='2'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     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 2.1--                         **
C               **  CHECK TO SEE THE TYPE CASE--       **
C               **    1) UNQUALIFIED (THAT IS, FULL);  **
C               **    2) SUBSET/EXCEPT; OR             **
C               **    3) FOR.                          **
C               *****************************************
C
      ISTEPN='2.1'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO2190
      DO2100J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO2110
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO2110
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO2120
 2100 CONTINUE
      GOTO2190
 2110 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO2190
 2120 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO2190
 2190 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO2195
      WRITE(ICOUT,2191)NUMARG,ILOCQ
 2191 FORMAT('NUMARG,ILOCQ = ',2I8)
      CALL DPWRST('XXX','BUG ')
 2195 CONTINUE
C
C               **************************************************
C               **  STEP 2.2--                                  **
C               **  DETERMINE THE NUMBER OF VARIABLES           **
C               **  TO BE INCLUDED AS PLOT COMPONENTS           **
C               **************************************************
C
      ISTEPN='2.2'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMV2=ILOCQ-1
      IF(NUMV2.EQ.4)GOTO2290
C
      WRITE(ICOUT,2211)
 2211 FORMAT('***** ERROR IN DPDCNT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2212)
 2212 FORMAT('      ILLEGAL SYNTAX--THE NUMBER OF VARIABLES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2213)
 2213 FORMAT('      TO BE INCLUDED AS ARGUMENTS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2214)
 2214 FORMAT('      IN A DEX CONTOUR PLOT COMMAND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2215)
 2215 FORMAT('      MUST BE EXACTLY 4;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2216)NUMV2
 2216 FORMAT('      SUCH WAS NOT THE CASE HERE.  NUMV2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2217)
 2217 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2218)(IANS(I),I=1,MIN(80,IWIDTH))
 2218 FORMAT(80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2290 CONTINUE
C
C               ***************************************
C               **  STEP 2.3                         **
C               **  CHECK THE VALIDITY OF EACH       **
C               **  OF THE VARIABLES.                **
C               ***************************************
C
      ISTEPN='2.3'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2300I=1,NUMV2
      IH1=IHARG(I)
      IH2=IHARG2(I)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IH1,IH2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IF(I.EQ.1)THEN
        ICOL1=IVALUE(ILOCV)
        N1=IN(ILOCV)
        IHRI11=IH1
        IHRI12=IH2
      ENDIF
      IF(I.EQ.2)THEN
        ICOL2=IVALUE(ILOCV)
        N2=IN(ILOCV)
        IHRI21=IH1
        IHRI22=IH2
      ENDIF
      IF(I.EQ.3)THEN
        ICOL3=IVALUE(ILOCV)
        N3=IN(ILOCV)
        IHRI31=IH1
        IHRI32=IH2
      ENDIF
      IF(I.EQ.4)THEN
        ICOL4=IVALUE(ILOCV)
        N4=IN(ILOCV)
        IHRI41=IH1
        IHRI42=IH2
      ENDIF
 2300 CONTINUE
C
C               **************************************************
C               **  STEP 2.4--                                  **
C               **  CHECK THAT FIRST THREE ARGUMENTS            **
C               **  HAVE THE SAME NUMBER OF OBSERVATIONS.       **
C               **************************************************
C
      ISTEPN='2.4'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N2.NE.N1.OR.N3.NE.N1.OR.N1.NE.N2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2411)
 2411   FORMAT('***** ERROR IN DPDCNT--FOR A DEX CONTOUR PLOT,')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2413)
 2413   FORMAT('      THE FIRST THREE VARIABLES MUST HAVE THE SAME')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2415)
 2415   FORMAT('      NUMER OF ELEMENTS;  SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2421)N1
 2421   FORMAT('THE FIRST  VARIABLE HAD ',I8,' ELEMENTS;')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2422)N2
 2422   FORMAT('THE SECOND VARIABLE HAD ',I8,' ELEMENTS;')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2423)N3
 2423   FORMAT('THE THIRD  VARIABLE HAD ',I8,' ELEMENTS;')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2427)
 2427   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
        CALL DPWRST('XXX','BUG ')
        IF(IWIDTH.GE.1)WRITE(ICOUT,2428)(IANS(I),I=1,MIN(80,IWIDTH))
 2428   FORMAT('      ',80A1)
        IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************************
C               **  STEP 2.5--                                      **
C               **  CHECK THAT VARIABLES HAVE AT LEAST 1 ELEMENT    **
C               ******************************************************
C
 4100 CONTINUE
      ISTEPN='2.5'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N1.GE.1.AND.N4.GE.1)GOTO2590
C
 2510 CONTINUE
      WRITE(ICOUT,2511)
 2511 FORMAT('***** ERROR IN DPDCNT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2513)
 2513 FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE VARIABLES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2514)
 2514 FORMAT('      MUST BE AT LEAST 1;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2515)
 2515 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2516)IHRI11,IHRI12,N1
 2516 FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2517)IHRI41,IHRI42,N4
 2517 FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2520)
 2520 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2521)(IANS(I),I=1,MIN(100,IWIDTH))
 2521 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2590 CONTINUE
C
C               *************************************************
C               **  STEP 3--                                   **
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               *************************************************
C
      ISTEPN='3'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO3010
      IF(ICASEQ.EQ.'SUBS')GOTO3020
      IF(ICASEQ.EQ.'FOR')GOTO3030
C
 3010 CONTINUE
      DO3015I=1,N1
      ISUB(I)=1
 3015 CONTINUE
      NQ=N1
      GOTO3050
C
 3020 CONTINUE
      NIOLD=N1
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO3050
C
 3030 CONTINUE
      NIOLD=N1
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO3050
C
 3050 CONTINUE
      J=0
      IMAX=N1
      IF(NQ.LT.N1)IMAX=NQ
      DO3060I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO3060
      J=J+1
C
      IJ=MAXN*(ICOL1-1)+I
      IF(ICOL1.LE.MAXCOL)Z(J)=V(IJ)
      IF(ICOL1.EQ.MAXCP1)Z(J)=PRED(I)
      IF(ICOL1.EQ.MAXCP2)Z(J)=RES(I)
      IF(ICOL1.EQ.MAXCP3)Z(J)=YPLOT(I)
      IF(ICOL1.EQ.MAXCP4)Z(J)=XPLOT(I)
      IF(ICOL1.EQ.MAXCP5)Z(J)=X2PLOT(I)
      IF(ICOL1.EQ.MAXCP6)Z(J)=TAGPLO(I)
C
      IJ=MAXN*(ICOL2-1)+I
      IF(ICOL2.LE.MAXCOL)X1(J)=V(IJ)
      IF(ICOL2.EQ.MAXCP1)X1(J)=PRED(I)
      IF(ICOL2.EQ.MAXCP2)X1(J)=RES(I)
      IF(ICOL2.EQ.MAXCP3)X1(J)=YPLOT(I)
      IF(ICOL2.EQ.MAXCP4)X1(J)=XPLOT(I)
      IF(ICOL2.EQ.MAXCP5)X1(J)=X2PLOT(I)
      IF(ICOL2.EQ.MAXCP6)X1(J)=TAGPLO(I)
C
      IJ=MAXN*(ICOL3-1)+I
      IF(ICOL3.LE.MAXCOL)X2(J)=V(IJ)
      IF(ICOL3.EQ.MAXCP1)X2(J)=PRED(I)
      IF(ICOL3.EQ.MAXCP3)X2(J)=RES(I)
      IF(ICOL3.EQ.MAXCP3)X2(J)=YPLOT(I)
      IF(ICOL3.EQ.MAXCP4)X2(J)=XPLOT(I)
      IF(ICOL3.EQ.MAXCP5)X2(J)=X2PLOT(I)
      IF(ICOL3.EQ.MAXCP6)X2(J)=TAGPLO(I)
C
 3060 CONTINUE
      NZ=J
C
      J=0
      IMAX=N4
      DO3070I=1,IMAX
      J=J+1
C
      IJ=MAXN*(ICOL4-1)+I
      IF(ICOL3.LE.MAXCOL)YCONT(J)=V(IJ)
      IF(ICOL3.EQ.MAXCP1)YCONT(J)=PRED(I)
      IF(ICOL3.EQ.MAXCP3)YCONT(J)=RES(I)
      IF(ICOL3.EQ.MAXCP3)YCONT(J)=YPLOT(I)
      IF(ICOL3.EQ.MAXCP4)YCONT(J)=XPLOT(I)
      IF(ICOL3.EQ.MAXCP5)YCONT(J)=X2PLOT(I)
      IF(ICOL3.EQ.MAXCP6)YCONT(J)=TAGPLO(I)
C
 3070 CONTINUE
 
C
C               *******************************************************
C               **  STEP 8--                                         **
C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
C               *******************************************************
C
      ISTEPN='5'
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO5099
      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      WRITE(ICOUT,5001)NLOCAL,ICASPL
 5001 FORMAT('NLOCAL,ICASPL=',I5,1X,A4)
      CALL DPWRST('XXX','BUG ')
 5099 CONTINUE
C
      CALL DPDCN2(Z,X1,X2,YCONT,NZ,N4,ICASPL,NUMV2,
     1PRED2,RES2,ZTEMP,U1JUNK,TEMP1,X1TEMP,X2TEMP,
     1Y,X,D,X3D,
     1B1,B2,B12,STATVA,NCDF,CUTL95,CUTU95,
     1IDCPDI,IDCPFI,
     1N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
      NPLOTP=N2
C
C               ***************************************
C               **  STEP 9--                         **
C               **  UPDATE INTERNAL DATAPLOT TABLES  **
C               ***************************************
C
 7000 CONTINUE
C
      ISTEPN='9'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DCNT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICOLPR=MAXCP1
      ICOLRE=MAXCP2
      IREPU='OFF'
      IRESU='OFF'
      CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NZ,
     1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,ILOCN,IBUGG3,IERROR)
C
      ISUBN0='DCNT'
      IBUGG2='OFF'
      IBUGG3='OFF'
C
      IH='B1  '
      IH2='    '
      VALUE0=B1
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='B2  '
      IH2='    '
      VALUE0=B2
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='B12 '
      IH2='    '
      VALUE0=B12
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='STAT'
      IH2='VAL '
      VALUE0=STATVA
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='STAT'
      IH2='NU  '
      VALUE0=REAL(NCDF)
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='CUTL'
      IH2='OW95'
      VALUE0=CUTL95
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
      IH='CUTU'
      IH2='PP95'
      VALUE0=CUTU95
      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
     1IANS,IWIDTH,IBUGG2,IERROR)
C
C
C               *****************
C               **  STEP 9--   **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DCNT')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDCNT--')
      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,NLOCAL,ICASPL,IAND1,IAND2
 9014 FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)NLOCAL
 9041 FORMAT('NLOCAL = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)NPLOTP
 9051 FORMAT('NPLOTP = ',I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDCN2(Z,X1,X2,YCONT,NZ,NCONT,ICASPL,NUMV2,
     1PRED,RES,ZTEMP,U1JUNK,TEMP1,X1TEMP,X2TEMP,
     1Y,X,D,X3D,
     1B1,B2,B12,TESTST,NCDF,CUTOF1,CUTOF2,
     1IDCPDI,IDCPFI,
     1N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE
C              A DEX CONTOUR PLOT
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--99/12
C     ORIGINAL VERSION--DECEMBER  1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IDCPDI
      CHARACTER*4 IDCPFI
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICONC
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Z(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION YCONT(*)
C
      DIMENSION PRED(*)
      DIMENSION RES(*)
      DIMENSION ZTEMP(*)
      DIMENSION U1JUNK(*)
      DIMENSION TEMP1(*)
      DIMENSION X1TEMP(*)
      DIMENSION X2TEMP(*)
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION D(*)
      DIMENSION X3D(*)
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='DPDC'
      ISUBN2='N2  '
      IWRITE='OFF'
C
      IERROR='NO'
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(NZ.GE.1)GOTO39
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,31)
   31 FORMAT('***** ERROR IN DPDCN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)
   32 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,33)
   33 FORMAT('      MUST BE AT LEAST 1;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,34)NZ
   34 FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
   39 CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DCN2')GOTO90
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)
   71 FORMAT('***** AT THE BEGINNING OF DPDCN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV,NUMV2
   72 FORMAT('ICASPL,NZ,N2,NPLOTV,NUMV2 = ',A4,2X,4I8)
      CALL DPWRST('XXX','BUG ')
      IF(NZ.LE.0)GOTO83
   81 CONTINUE
   83 CONTINUE
   90 CONTINUE
C
C               ****************************************
C               **  STEP 4--                          **
C               **  PLOT INNER SAMPLING SQUARE        **
C               **  AND A CENTER POINT (IF IT EXISTS) **
C               ****************************************
C
      ITAG=0
      N2=0
C
      ITAG=ITAG+1
      ATOL=0.00001
      J=0
      DO510I=1,NZ
        X1VAL=ABS(X1(I)-(-1.0))
        X2VAL=ABS(X2(I)-(-1.0))
        IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  510 CONTINUE
      NPTS=J
      IF(NPTS.GT.0)THEN
        CALL MEAN(ZTEMP,NPTS,IWRITE,YMM,IBUGG3,IERROR)
        N2=N2+1
        X(N2)=-1.1
        Y(N2)=-1.2
        D(N2)=REAL(ITAG)
        X3D(N2)=YMM
      ENDIF
C
      J=0
      DO520I=1,NZ
        X1VAL=ABS(X1(I)-(1.0))
        X2VAL=ABS(X2(I)-(-1.0))
        IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  520 CONTINUE
      NPTS=J
      IF(NPTS.GT.0)THEN
        CALL MEAN(ZTEMP,NPTS,IWRITE,YPM,IBUGG3,IERROR)
        N2=N2+1
        X(N2)=1.1
        Y(N2)=-1.2
        D(N2)=REAL(ITAG)
        X3D(N2)=YPM
      ENDIF
C
      J=0
      DO530I=1,NZ
        X1VAL=ABS(X1(I)-(-1.0))
        X2VAL=ABS(X2(I)-(1.0))
        IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  530 CONTINUE
      NPTS=J
      IF(NPTS.GT.0)THEN
        CALL MEAN(ZTEMP,NPTS,IWRITE,YMP,IBUGG3,IERROR)
        N2=N2+1
        X(N2)=-1.1
        Y(N2)=1.1
        D(N2)=REAL(ITAG)
        X3D(N2)=YMP
      ENDIF
C
      J=0
      DO540I=1,NZ
        X1VAL=ABS(X1(I)-(1.0))
        X2VAL=ABS(X2(I)-(1.0))
        IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  540 CONTINUE
      NPTS=J
      IF(NPTS.GT.0)THEN
        CALL MEAN(ZTEMP,NPTS,IWRITE,YPP,IBUGG3,IERROR)
        N2=N2+1
        X(N2)=1.1
        Y(N2)=1.1
        D(N2)=REAL(ITAG)
        X3D(N2)=YPP
      ENDIF
C
      ATOL=0.00001
      J=0
      DO400I=1,NZ
        X1VAL=ABS(X1(I))
        X2VAL=ABS(X2(I))
        IF(ABS(X1VAL).LE.ATOL.AND.ABS(X2VAL).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  400 CONTINUE
      NCENT=J
      IF(NCENT.GT.0)THEN
        CALL MEAN(ZTEMP,NCENT,IWRITE,YCP,IBUGG3,IERROR)
        CALL SD(ZTEMP,NCENT,IWRITE,YSD,IBUGG3,IERROR)
        N2=N2+1
        X(N2)=0.1
        Y(N2)=0.1
        D(N2)=REAL(ITAG)
        X3D(N2)=YCP
C
        N2=N2+1
        ITAG=ITAG+1
        X(N2)=0.0
        Y(N2)=0.0
        D(N2)=REAL(ITAG)
      ENDIF
C
      ITAG=ITAG+1
      N2=N2+1
      X(N2)=-1.0
      Y(N2)=-1.0
      D(N2)=REAL(ITAG)
      X3D(N2)=0.0
      N2=N2+1
      X(N2)=1.0
      Y(N2)=-1.0
      D(N2)=REAL(ITAG)
      X3D(N2)=0.0
      N2=N2+1
      X(N2)=1.0
      Y(N2)=1.0
      D(N2)=REAL(ITAG)
      X3D(N2)=0.0
      N2=N2+1
      X(N2)=-1.0
      Y(N2)=1.0
      D(N2)=REAL(ITAG)
      X3D(N2)=0.0
      N2=N2+1
      X(N2)=-1.0
      Y(N2)=-1.0
      D(N2)=REAL(ITAG)
      X3D(N2)=0.0
C
C
C               ****************************************
C               **  STEP 1--                          **
C               **  EXTRACT POINTS WHERE X1, X2 ARE   **
C               **  EQUAL TO +/- 1.                   **
C               **  COMPUTE B1, B2, B12               **
C               ****************************************
C
      ATOL=0.00001
      J=0
      DO100I=1,NZ
        X1VAL=ABS(X1(I))
        X2VAL=ABS(X2(I))
        IF(ABS(X1VAL-1.0).LE.ATOL.AND.ABS(X2VAL-1.0).LE.ATOL)THEN
          J=J+1
          X1TEMP(J)=X1(I)
          X2TEMP(J)=X2(I)
          ZTEMP(J)=Z(I)
        ENDIF
  100 CONTINUE
      IF(J.LE.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN DPDCN2--')
        WRITE(ICOUT,113)
  113   FORMAT('      NONE OF THE X1, X2 PAIRS EQUAL TO +/- 1')
        IERROR='YES'
        GOTO9000
      ENDIF
      NEDGE=J
C
      CALL MEAN(ZTEMP,NEDGE,IWRITE,AMU,IBUGG3,IERROR)
      AMEDGE=AMU
      DO120I=1,NEDGE
        TEMP1(I)=Z(I)*X1TEMP(I)
  120 CONTINUE
      CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
      B1=2.0*AMU2
C
      DO130I=1,NEDGE
        TEMP1(I)=Z(I)*X2TEMP(I)
  130 CONTINUE
      CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
      B2=2.0*AMU2
C
      DO140I=1,NEDGE
        TEMP1(I)=Z(I)*X1TEMP(I)*X2TEMP(I)
  140 CONTINUE
      CALL MEAN(TEMP1,NEDGE,IWRITE,AMU2,IBUGG3,IERROR)
      B12=2.0*AMU2
C
C               ****************************************
C               **  STEP 2--                          **
C               **  COMPUTE RESIDUALS, PREDICTED      **
C               **  VALUES EVERYWHERE                 **
C               ****************************************
C
      DO210I=1,NZ
        PRED(I)=AMU+0.5*(B1*X1(I)+B2*X2(I)+B12*X1(I)*X2(I))
        RES(I)=Z(I)-PRED(I)
  210 CONTINUE
C
C               ****************************************
C               **  STEP 3--                          **
C               **  GENERATE THE CONTOUR VALUES       **
C               ****************************************
C
      AVAL=-2.0
      AINC=0.05
      DO310I=1,81
        U1JUNK(I)=AVAL
        AVAL=AVAL+AINC
  310 CONTINUE
C
      
      CALL SORT(YCONT,NCONT,YCONT)
      IF(IDCPDI.EQ.'MINI')THEN
        IFRST=1
        ILAST=NCONT
        INC=1
      ELSE
        IFRST=NCONT
        ILAST=1
        INC=-1
      ENDIF
C
      DO330ICONT=IFRST,ILAST,INC
        Y0=YCONT(ICONT)
        ATEMP=2.0*(Y0-AMU)
        ITAG=ITAG+1
        DO320I=1,81
          ANUM=ATEMP-B1*U1JUNK(I)
          ADEN=B2+B12*U1JUNK(I)
          AVAL=ANUM/ADEN
          IF(AVAL.GE.-2.0 .AND.AVAL.LE.2.0)THEN
            N2=N2+1
            Y(N2)=ANUM/ADEN
            X(N2)=U1JUNK(I)
            D(N2)=REAL(ITAG)
            X3D(N2)=0.0
          ENDIF
  320   CONTINUE
  330 CONTINUE
C
C               ****************************************
C               **  STEP 6--                          **
C               **  GENERATE THE T-TEST FOR CURVATURE **
C               ****************************************
C
      IF(NCENT.GE.2.AND.NEDGE.GE.1)THEN
        STATNM=0.0
        STATDN=0.0
        TESTST=0.0
        NCDF=0
        STATNM=AMEDGE-YCP
        AJUNK1=1.0/REAL(NEDGE)
        AJUNK2=1.0/REAL(NCENT)
        STATDN=YSD*SQRT(AJUNK1+AJUNK2)
        IF(STATDN.EQ.0.0)GOTO699
        TESTST=STATNM/STATDN
        NCDF=NCENT-1
        AP=0.975
        CALL TPPF(AP,NCDF,CUTOF2)
        CUTOF1=-CUTOF2
        ICONC='NO'
        IF(TESTST.LT.CUTOF1 .OR. TESTST.GT.CUTOF2)ICONC='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,611)
  611   FORMAT('----- DEX CONTOUR PLOT TEST FOR CURVATURE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,613)NCENT
  613   FORMAT('      NUMBER OF CENTER POINTS             =  ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,615)YCP
  615   FORMAT('      MEAN OF CENTER POINTS                =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,617)YSD
  617   FORMAT('      STANDARD DEVIATION OF CENTER POINTS  =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,623)NEDGE
  623   FORMAT('      NUMBER OF EDGE POINTS                =  ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,625)AMEDGE
  625   FORMAT('      MEAN OF EDGE POINTS                  =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,631)TESTST
  631   FORMAT('      CURVATURE CHECK: T TEST STATISTIC    =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,633)NCDF
  633   FORMAT('      T DEGREES OF FREEDOM                 =  ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,635)CUTOF1
  635   FORMAT('      LOWER T CRITICAL VALUE               =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,637)CUTOF2
  637   FORMAT('      UPPER T CRITICAL VALUE               =  ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IF(ICONC.EQ.'NO')THEN
        WRITE(ICOUT,641)
  641   FORMAT('      CONCLUSION: THERE IS NO CURVATURE')
        CALL DPWRST('XXX','BUG ')
        ELSE
        WRITE(ICOUT,643)
  643   FORMAT('      CONCLUSION: THERE IS  CURVATURE')
        CALL DPWRST('XXX','BUG ')
        ENDIF
  699   CONTINUE
      ELSE
        NDF=0
        TESTST=0.0
        CUTOF1=0.0
        CUTOF2=0.0
      ENDIF
 8000 CONTINUE
      NPLOTV=3
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DCN2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDCN2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ICASPL,NZ,N2,IERROR
 9012 FORMAT('ICASPL,NZ,N2,IERROR = ',A4,2I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N2
 9013 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NZ.LE.0)GOTO9023
      DO9021I=1,NZ
      WRITE(ICOUT,9022)I,Z(I),X1(I),X2(I)
 9022 FORMAT('I,Z(I),X1(I),X2(I) = ',I8,4E12.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9023 CONTINUE
      WRITE(ICOUT,9031)N2,NPLOTV
 9031 FORMAT('N2,NPLOTV = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9035I=1,N2
      WRITE(ICOUT,9036)I,Y(I),X(I),D(I)
 9036 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2)
      CALL DPWRST('XXX','BUG ')
 9035 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDECL(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IDEFDC,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IBUGO2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE COLOR STATUS (ON/OFF) FOR AN OUTPUT DEVICE.
C              THE COLOR (ON/OFF) FOR DEVICE I
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C              VECTOR IDCOLO(.).
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                     --IDEFDC
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDCONT (A CHARACTER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              COLOR (ON/OFF) FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IDEFDC
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
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)GOTO9000
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140
      GOTO9000
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1120
      IF(IHARG(2).EQ.'ON')GOTO1120
      IF(IHARG(2).EQ.'OFF')GOTO1125
      IF(IHARG(2).EQ.'AUTO')GOTO1120
      IF(IHARG(2).EQ.'DEFA')GOTO1127
      GOTO1120
C
 1120 CONTINUE
      IHOLD='ON'
      GOTO1130
C
 1125 CONTINUE
      IHOLD='OFF'
      GOTO1130
C
 1127 CONTINUE
      IHOLD=IDEFDC
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDCOLO(I)=IHOLD
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IHOLD
 1136 FORMAT('THE COLOR FOR ALL DEVICES HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO9000
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDECL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... COLOR COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 COLOR ON')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDECL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... COLOR COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1160 CONTINUE
      IF(NUMARG.LE.2)GOTO1170
      IF(IHARG(3).EQ.'ON')GOTO1170
      IF(IHARG(3).EQ.'OFF')GOTO1175
      IF(IHARG(3).EQ.'AUTO')GOTO1170
      IF(IHARG(3).EQ.'DEFA')GOTO1177
      GOTO1170
C
 1170 CONTINUE
      IHOLD='ON'
      GOTO1180
C
 1175 CONTINUE
      IHOLD='OFF'
      GOTO1180
C
 1177 CONTINUE
      IHOLD=IDEFDC
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDCOLO(I)=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDECN(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IDEFCN,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IBUGO2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE CONTINUITY STATUS (ON/OFF) FOR AN OUTPUT DEVICE.
C              A DEVICE IS CONSIDERED CONTINUOUS IF IT IS CAPABLE
C              OF DRAWING A CONTINUOUS LINE SEGMENT.
C              FOR EXAMPLE, THE TEKTRONIX 4014 IS CONTINUOUS;
C              THE TEXAS INSTRUMENT SILENT 700 IS NOT CONTINUOUS.
C              THE CONTINUITY (ON/OFF) FOR DEVICE I
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C              VECTOR IDCONT(.).
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                     --IDEFCN
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDCONT (A CHARACTER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              CONTINUITY (ON/OFF) FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IDEFCN
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
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)GOTO9000
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CONT')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CONT')GOTO1140
      GOTO9000
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1120
      IF(IHARG(2).EQ.'ON')GOTO1120
      IF(IHARG(2).EQ.'OFF')GOTO1125
      IF(IHARG(2).EQ.'AUTO')GOTO1120
      IF(IHARG(2).EQ.'DEFA')GOTO1127
      GOTO1120
C
 1120 CONTINUE
      IHOLD='ON'
      GOTO1130
C
 1125 CONTINUE
      IHOLD='OFF'
      GOTO1130
C
 1127 CONTINUE
      IHOLD=IDEFCN
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDCONT(I)=IHOLD
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IHOLD
 1136 FORMAT('THE CONTINUITY FOR ALL DEVICES HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO9000
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDECN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... CONTINUITY COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 CONTINUITY ON')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDECN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... CONTINUITY COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1160 CONTINUE
      IF(NUMARG.LE.2)GOTO1170
      IF(IHARG(3).EQ.'ON')GOTO1170
      IF(IHARG(3).EQ.'OFF')GOTO1175
      IF(IHARG(3).EQ.'AUTO')GOTO1170
      IF(IHARG(3).EQ.'DEFA')GOTO1177
      GOTO1170
C
 1170 CONTINUE
      IHOLD='ON'
      GOTO1180
C
 1175 CONTINUE
      IHOLD='OFF'
      GOTO1180
C
 1177 CONTINUE
      IHOLD=IDEFCN
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDCONT(I)=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDECO(IANS,IWIDTH,IHARG,NUMARG,
     1IDEFCM,IWIDDC,IDEFC,IBUGS2,IFOUND,IERROR)
C
C     PURPOSE--EXTRACT THE STRING TO BE USED AS A DEFAULT COMMAND;
C              SAVE THIS STRING FOR USE IN MAIN
C              WHEN NO MATCH FORUND FOR A GIVEN COMMAND.
C     NOTE--A CHECK IS CONTAINED HEREIN WHICH RESTRICTS
C           THE MAXIMUM NUMBER OF CHARACTERS IN THE DEFAULT
C           COMMAND TO BE 40 CHARACTERS.
C     INPUT  ARGUMENTS--IANS   (A  HOLLERITH VECTOR)
C                     --IWIDTH
C                     --IHARG  (A  HOLLERITH VECTOR)
C                     --NUMARG
C     OUTPUT ARGUMENTS--IDEFCM
C                     --IWIDDC
C                     --IDEFC
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--JUNE       1981.
C     UPDATED         --SEPTEMBER  1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IANS
      CHARACTER*4 IHARG
      CHARACTER*4 IDEFCM
      CHARACTER*4 IDEFC
      CHARACTER*4 IBUGS2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IANS(*)
      DIMENSION IHARG(*)
C
      DIMENSION IDEFC(*)
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(IBUGS2.NE.'ON')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDECO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IDEFCM,IWIDDC
   53 FORMAT('IDEFCM,IWIDDC = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)(IDEFC(I),I=1,IWIDDC)
   54 FORMAT('IDEFC(.)--',120A1)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *******************************************
C               **  STEP 1--                             **
C               **  DETERMINE THE SECOND WORD (COMMAND)  **
C               **  IN THE ASSUMED COMMAND STRING        **
C               **  (DEFAULT COMMNAD)                    **
C               *******************************************
C
      DO100I=1,IWIDTH
      I2=I
      IP1=I+1
      IP2=I+2
      IP3=I+3
      IP4=I+4
      IP5=I+5
      IP6=I+6
      IF(IANS(I).EQ.'C'.AND.IANS(IP1).EQ.'O'
     1.AND.IANS(IP2).EQ.'M'.AND.IANS(IP3).EQ.'M'
     1.AND.IANS(IP4).EQ.'A'.AND.IANS(IP5).EQ.'N'
     1.AND.IANS(IP6).EQ.'D')
     1GOTO190
C
  100 CONTINUE
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR IN DPDECO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
  102 FORMAT('      THE WORD   COMMAND   NOT FOUND.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO800
  190 CONTINUE
C
C               **********************************************************
C               **  STEP 2--                                            **
C               **  DEFINE THE START POSITION (ISTART) FOR THE STRING.  **
C               **  DEFINE THE STOP POSITION (ISTOP) FOR THE STRING.  **
C               ********************************************************
C
      IFOUND='YES'
      ISTART=I2+8
      ISTOP=0
      IF(ISTART.GT.IWIDTH)GOTO329
      DO320I=ISTART,IWIDTH
      IREV=IWIDTH-I+ISTART
      IF(IANS(IREV).NE.' ')GOTO325
  320 CONTINUE
      GOTO329
  325 CONTINUE
      ISTOP=IREV
  329 CONTINUE
C
C               *****************************************
C               **  STEP 4--                           **
C               **  COPY OVER THE STRING OF INTEREST.  **
C               *****************************************
C
      IF(NUMARG.LE.1)GOTO359
      IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'ON')GOTO359
      IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'OFF')GOTO359
      IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'AUTO')GOTO359
      IF(NUMARG.LE.2.AND.IHARG(NUMARG).EQ.'DEFA')GOTO359
C
      IF(ISTART.GT.ISTOP)GOTO359
      IF(ISTOP.EQ.0)GOTO359
      J=0
      DO350I=ISTART,ISTOP
      J=J+1
      IDEFC(J)=IANS(I)
      IF(J.GE.40)GOTO355
  350 CONTINUE
  355 CONTINUE
      IDEFCM='ON'
      IWIDDC=J
      GOTO800
  359 CONTINUE
C
C               ************************************
C               **  STEP 5--                      **
C               **  TREAT THE EMPTY-STRING CASE.  **
C               ************************************
C
      IDEFCM='OFF'
      IWIDDC=0
      DO410I=1,40
      IDEFC(I)='    '
  410 CONTINUE
      GOTO800
C
C               ***************************
C               **  STEP 6--             **
C               **  PRINT OUT A MESSAGE  **
C               ***************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO819
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)
  811 FORMAT('THE DEFAULT COMMAND HAS JUST BEEN SET TO')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDDC.EQ.0)WRITE(ICOUT,999)
      IF(IWIDDC.EQ.0)CALL DPWRST('XXX','BUG ')
      IF(IWIDDC.GE.1)WRITE(ICOUT,812)(IDEFC(I),I=1,IWIDDC)
  812 FORMAT(10X,120A1)
      IF(IWIDDC.GE.1)CALL DPWRST('XXX','BUG ')
  819 CONTINUE
      GOTO9000
C
C               ****************
C               **  STEP 7--  **
C               **  EXIT      **
C               ****************
C
 9000 CONTINUE
      IF(IBUGS2.NE.'ON')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDECO--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IDEFCM,IWIDDC
 9012 FORMAT('IDEFCM,IWIDDC(1) = ',A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)(IDEFC(I),I=1,IWIDDC)
 9013 FORMAT('IDEFC(.) --',120A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IFOUND,IERROR
 9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEDE(IHARG,IARG,NUMARG,IDEDED,
     1IDEXDE,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE DESIGN OF EXPERIMENT PLOT DEPTH
C              INTO THE INTERACTION TERMS
C              1 = MAIN EFFECTS ONLY
C              2 = UP TO 2-TERM INTERACTIONS
C              3 = UP TO 3-TERM INTERACTIONS
C              ETC.
C     INPUT  ARGUMENTS--IHARG  (A HOLLARITH VECTOR)
C                     --IARG    (AN INTEGER VECTOR)
C                     --NUMARG
C                     --IDEDED
C     OUTPUT ARGUMENTS--IDEXDE
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/5
C     ORIGINAL VERSION--MAY       1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IARG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
      IF(NUMARG.LE.0)GOTO1900
C
 1100 CONTINUE
      IF(NUMARG.EQ.1)GOTO1150
      IF(IHARG(2).EQ.'ON')GOTO1150
      IF(IHARG(2).EQ.'OFF')GOTO1150
      IF(IHARG(2).EQ.'AUTO')GOTO1150
      IF(IHARG(2).EQ.'DEFA')GOTO1150
      GOTO1160
C
 1150 CONTINUE
      IHOLD=IDEDED
      GOTO1180
C
 1160 CONTINUE
      IHOLD=IARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDEXDE=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE DESIGN OF EXPERIMENT DEPTH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('(INTO THE INTERACTION TERMS)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IHOLD
 1183 FORMAT('HAS JUST BEEN SET TO ',I8)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1900
C
 1199 CONTINUE
C
 1900 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEDL(Y,X,PX,NP,NUMSET,
     1ICASPL,ICAS3D,
     1ISPISW,ASPIBA,MAXSPI,
     1IBARSW,ABARBA,ABARWI,MAXBAR,XDELMN,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
     1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
     1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
     1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
     1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
     1IHORSW)
C
C     PURPOSE--COMPUTE ACTUAL DATA LIMITS
C              FOR POTENTIAL USE IN SETTING
C              LIMITS FOR ALL 4 FRAME LINES
C     NOTE--IN THE EVENT THAT THE FRAME LIMITS HAVE BEEN FIXED
C           (AS OPPOSED TO FLOATING),
C           THEN COMPUTE THE ACTUAL DATA LIMITS ONLY FOR THOSE
C           DATA POINTS RESIDING WITHIN THE FIXED LIMITS.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 IX1MIN
      CHARACTER*4 IX1MAX
      CHARACTER*4 IY1MIN
      CHARACTER*4 IY1MAX
C
      CHARACTER*4 IX2MIN
      CHARACTER*4 IX2MAX
      CHARACTER*4 IY2MIN
      CHARACTER*4 IY2MAX
C
      CHARACTER*4 ISPISW
      CHARACTER*4 IBARSW
C
      CHARACTER*4 IBAR
      CHARACTER*4 ISAVE
C
      CHARACTER*4 IHORSW
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION PX(*)
C
      DIMENSION ISPISW(*)
      DIMENSION ASPIBA(*)
      DIMENSION IBARSW(*)
      DIMENSION ABARBA(*)
      DIMENSION ABARWI(*)
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
      DEL=-999.0
      AWIDTH=-999.0
      BAMIN=-999.0
      BAMAX=-999.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEDL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NP,NUMSET
   52 FORMAT('NP,NUMSET = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)MAXSPI,MAXBAR
   53 FORMAT('MAXSPI,MAXBAR = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ICASPL,ICAS3D,XDELMN
   54 FORMAT('ICASPL,ICAS3D,XDELMN = ',A4,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO59
      DO55I=1,3
      WRITE(ICOUT,56)I,X(I),Y(I)
   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      NPM2=NP-2
      DO57I=NPM2,NP
      WRITE(ICOUT,58)I,X(I),Y(I)
   58 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   57 CONTINUE
   59 CONTINUE
      WRITE(ICOUT,61)GX1MIN,GY1MIN,GX1MAX,GY1MAX
   61 FORMAT('GX1MIN,GY1MIN,GX1MAX,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)GX2MIN,GY2MIN,GX2MAX,GY2MAX
   62 FORMAT('GX2MIN,GY2MIN,GX2MAX,GY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IX1MIN,IY1MIN,IX1MAX,IY1MAX
   63 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IX2MIN,IY2MIN,IX2MAX,IY2MAX
   64 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)DX1MIN,DY1MIN,DX1MAX,DY1MAX
   65 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)DX2MIN,DY2MIN,DX2MAX,DY2MAX
   66 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      IMAX=NUMSET
      IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
      DO71I=1,IMAX
      WRITE(ICOUT,72)I,ISPISW(I),ASPIBA(I)
   72 FORMAT('I,ISPISW(I),ASPIBA(I) = ',I8,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
   71 CONTINUE
      IMAX=NUMSET
      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
      DO73I=1,IMAX
      WRITE(ICOUT,74)I,IBARSW(I),ABARBA(I),ABARWI(I)
   74 FORMAT('I,IBARSW(I),ABARBA(I),ABARWI(I)= ',I8,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
   73 CONTINUE
      WRITE(ICOUT,79)IHORSW
   79 FORMAT('IHORSW=',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,89)IBUGG4,ISUBG4,IERRG4
   89 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***********************************************************
C               **  STEP 1--                                             **
C               **  IF ANY OF THE BAR SWITCHES ARE ON,                   **
C               **  DETERMINE THE MINIMUM NON-ZERO DIFFERENCE            **
C               **  (XDELMN) BETWEEN X-VARIABLE VALUES.                  **
C               **  THIS VALUE (XDELMN) IS USED TO DEFINE THE BAR WIDTH  **
C               **  IN BAR PLOTS WHEN THE WIDTH IS ALLOWED TO "FLOAT"    **
C               **  WITH THE DATA.                                       **
C               **  THIS VALUE IS USED IN THE DPDRBA SUBROUTINE.         **
C               ***********************************************************
C
      ISAVE=IBARSW(1)
      IBAR='OFF'
      IF(ICASPL.EQ.'HIST')IBARSW(1)='ON'
      IF(ICASPL.EQ.'CUMH')IBARSW(1)='ON'
      IF(ICASPL.EQ.'BARP')IBARSW(1)='ON'
      IF(ICASPL.EQ.'ROOT')IBARSW(1)='ON'
      IF(ICASPL.EQ.'CUMR')IBARSW(1)='ON'
      IF(ICASPL.EQ.'BIHI')IBARSW(1)='ON'
      XDELMN=CPUMAX
      IF(NUMSET.LE.0)GOTO1090
      IMAX=NUMSET
      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
      DO1010I=1,IMAX
      IF(IBARSW(I).EQ.'ON')GOTO1019
 1010 CONTINUE
      GOTO1090
 1019 CONTINUE
      IBAR='ON'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1012
      WRITE(ICOUT,1011)IHORSW,NP,IBAR
 1011 FORMAT('IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1012 CONTINUE
C
C  SEPTEMBER, 1987: IF HORIZONTAL SWITCH IS ON, REVERSE
      IF(IHORSW.EQ.'ON')GOTO1092
C  END CHANGE
      CALL DPSORT(X,NP,PX)
      IF(NP.LE.1)GOTO1090
      DO1020I=2,NP
      IM1=I-1
      DEL=PX(I)-PX(IM1)
      IF(DEL.LE.0.0)GOTO1020
      IF(DEL.LT.XDELMN)XDELMN=DEL
 1020 CONTINUE
      GOTO1090
C  SEPTEMBER, 1987 CHANGE
 1092 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1032
      WRITE(ICOUT,1031)IHORSW,NP,IBAR
 1031 FORMAT('HORIZONTAL CASE,IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1032 CONTINUE
C
      CALL DPSORT(Y,NP,PX)
      IF(NP.LE.1)GOTO1090
      DO1095I=2,NP
      IM1=I-1
      DEL=PX(I)-PX(IM1)
      IF(DEL.LE.0.0)GOTO1095
      IF(DEL.LT.XDELMN)XDELMN=DEL
 1095 CONTINUE
 1090 CONTINUE
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO1022
      WRITE(ICOUT,1021)IHORSW,NP,IBAR
 1021 FORMAT('IHORSW,NP,IBAR=',A4,2X,I4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1022 CONTINUE
C  END CHANGE
C
C               **********************************************
C               **  STEP 2--                                **
C               **  DETERMINE ACTUAL LIMITS FOR X VARIABLE  **
C               **********************************************
C
      TXMIN=CPUMAX
      TXMAX=CPUMIN
C
      XMIN=CPUMAX
      XMAX=CPUMIN
      IF(NP.LE.0)GOTO1119
      DO1110I=1,NP
      IF(IX1MIN.EQ.'FIXE'.AND.X(I).LT.GX1MIN)GOTO1110
      IF(IX1MAX.EQ.'FIXE'.AND.X(I).GT.GX1MAX)GOTO1110
CCCCC JULY 1996.  FOLLOWING CODE EXCLUDES VALUES THAT ARE
CCCCC "OUT OF RANGE" ON THE Y-AXIS.  SPECIAL CASE WHERE UPPER AND
CCCCC LOWER LIMIT ARE EQUAL, INCLUDE ALL VALUES.
      IF(GY1MIN.NE.GY1MAX)THEN
        IF(IY1MIN.EQ.'FIXE'.AND.Y(I).LT.GY1MIN)GOTO1110
        IF(IY1MAX.EQ.'FIXE'.AND.Y(I).GT.GY1MAX)GOTO1110
      ENDIF
      IF(X(I).LT.XMIN)XMIN=X(I)
      IF(X(I).GT.XMAX)XMAX=X(I)
 1110 CONTINUE
      TXMIN=XMIN
      TXMAX=XMAX
 1119 CONTINUE
C
      BWMIN=CPUMAX
      BWMAX=CPUMIN
      IF(NUMSET.LE.0)GOTO1139
      IMAX=NUMSET
      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
      DO1130I=1,IMAX
      IF(IBARSW(I).EQ.'OFF')GOTO1130
      AWIDTH=ABARWI(I)
      IF(ABARWI(I).EQ.CPUMIN)AWIDTH=XDELMN
      IF(AWIDTH.GT.BWMAX)BWMAX=AWIDTH
 1130 CONTINUE
      BAMIN=XMIN
      BAMAX=XMAX
      IF(XMIN.NE.CPUMAX.AND.BWMAX.NE.CPUMIN)BAMIN=XMIN-BWMAX/2.0
CCCCC IF(XMAX.NE.CPUMIN.AND.BWMIN.NE.CPUMAX)BAMAX=XMAX+BWMAX/2.0
      IF(XMAX.NE.CPUMIN.AND.BWMAX.NE.CPUMIN)BAMAX=XMAX+BWMAX/2.0
      IF(BAMIN.LT.TXMIN)TXMIN=BAMIN
      IF(BAMAX.GT.TXMAX)TXMAX=BAMAX
 1139 CONTINUE
C
      DX1MIN=TXMIN
      DX2MIN=TXMIN
      DX1MAX=TXMAX
      DX2MAX=TXMAX
      IF(DX1MIN.EQ.CPUMAX)DX1MIN=X(1)
      IF(DX2MIN.EQ.CPUMAX)DX2MIN=X(1)
      IF(DX1MAX.EQ.CPUMIN)DX1MAX=X(1)
      IF(DX2MAX.EQ.CPUMIN)DX2MAX=X(1)
C
C               **********************************************
C               **  STEP 3--                                **
C               **  DETERMINE ACTUAL LIMITS FOR Y VARIABLE  **
C               **********************************************
C
      TYMIN=CPUMAX
      TYMAX=CPUMIN
C
      YMIN=CPUMAX
      YMAX=CPUMIN
      IF(NP.LE.0)GOTO1119
      DO1210I=1,NP
CCCCC JULY 1996.  FOLLOWING CODE EXCLUDES VALUES THAT ARE
CCCCC "OUT OF RANGE" ON THE Y-AXIS.  SPECIAL CASE WHERE UPPER AND
CCCCC LOWER LIMIT ARE EQUAL, INCLUDE ALL VALUES.
      IF(GX1MIN.NE.GX1MAX)THEN
        IF(IX1MIN.EQ.'FIXE'.AND.X(I).LT.GX1MIN)GOTO1210
        IF(IX1MAX.EQ.'FIXE'.AND.X(I).GT.GX1MAX)GOTO1210
      ENDIF
      IF(IY1MIN.EQ.'FIXE'.AND.Y(I).LT.GY1MIN)GOTO1210
      IF(IY1MAX.EQ.'FIXE'.AND.Y(I).GT.GY1MAX)GOTO1210
      IF(Y(I).LT.YMIN)YMIN=Y(I)
      IF(Y(I).GT.YMAX)YMAX=Y(I)
 1210 CONTINUE
      TYMIN=YMIN
      TYMAX=YMAX
 1219 CONTINUE
C
      SBMIN=CPUMAX
      SBMAX=CPUMIN
      IF(NUMSET.LE.0)GOTO1229
      IMAX=NUMSET
      IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
      DO1220I=1,IMAX
      IF(ISPISW(I).EQ.'OFF')GOTO1220
      IF(ASPIBA(I).LT.SBMIN)SBMIN=ASPIBA(I)
      IF(ASPIBA(I).GT.SBMAX)SBMAX=ASPIBA(I)
 1220 CONTINUE
      IF(SBMIN.LT.TYMIN)TYMIN=SBMIN
      IF(SBMAX.GT.TYMAX)TYMAX=SBMAX
 1229 CONTINUE
C
      BBMIN=CPUMAX
      BBMAX=CPUMIN
      IF(NUMSET.LE.0)GOTO1239
      IMAX=NUMSET
      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
      DO1230I=1,IMAX
      IF(IBARSW(I).EQ.'OFF')GOTO1230
      IF(ABARBA(I).LT.BBMIN)BBMIN=ABARBA(I)
      IF(ABARBA(I).GT.BBMAX)BBMAX=ABARBA(I)
 1230 CONTINUE
      IF(BBMIN.LT.TYMIN)TYMIN=BBMIN
      IF(BBMAX.GT.TYMAX)TYMAX=BBMAX
 1239 CONTINUE
C
      DY1MIN=TYMIN
      DY2MIN=TYMIN
      DY1MAX=TYMAX
      DY2MAX=TYMAX
      IF(DY1MIN.EQ.CPUMAX)DY1MIN=Y(1)
      IF(DY2MIN.EQ.CPUMAX)DY2MIN=Y(1)
      IF(DY1MAX.EQ.CPUMIN)DY1MAX=Y(1)
      IF(DY2MAX.EQ.CPUMIN)DY2MAX=Y(1)
C
 8000 CONTINUE
      IBARSW(1)=ISAVE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEDL')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEDL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NP,NUMSET
 9012 FORMAT('NP,NUMSET = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)MAXSPI,MAXBAR
 9013 FORMAT('MAXSPI,MAXBAR = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ICASPL,ICAS3D,XDELMN,AWIDTH
 9014 FORMAT('ICASPL,ICAS3D,XDELMN,AWIDTH = ',A4,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NP.LE.3)GOTO9019
      DO9015I=1,3
      WRITE(ICOUT,9016)I,X(I),Y(I)
 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      NPM2=NP-2
      DO9017I=NPM2,NP
      WRITE(ICOUT,9018)I,X(I),Y(I)
 9018 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9017 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)GX1MIN,GY1MIN,GX1MAX,GY1MAX
 9021 FORMAT('GX1MIN,GY1MIN,GX1MAX,GY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)GX2MIN,GY2MIN,GX2MAX,GY2MAX
 9022 FORMAT('GX2MIN,GY2MIN,GX2MAX,GY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)IX1MIN,IY1MIN,IX1MAX,IY1MAX
 9023 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)IX2MIN,IY2MIN,IX2MAX,IY2MAX
 9024 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)DX1MIN,DY1MIN,DX1MAX,DY1MAX
 9025 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)DX2MIN,DY2MIN,DX2MAX,DY2MAX
 9026 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      IMAX=NUMSET
      IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
      DO9031I=1,IMAX
      WRITE(ICOUT,9032)I,ISPISW(I),ASPIBA(I)
 9032 FORMAT('I,ISPISW(I),ASPIBA(I) = ',I8,2X,A4,2X,E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
      IMAX=NUMSET
      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
      DO9033I=1,IMAX
      WRITE(ICOUT,9034)I,IBARSW(I),ABARBA(I),ABARWI(I)
 9034 FORMAT('I,IBARSW(I),ABARBA(I),ABARWI(I)= ',I8,2X,A4,2X,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9033 CONTINUE
      WRITE(ICOUT,9041)XMIN,XMAX,BWMIN,BWMAX
 9041 FORMAT('XMIN,XMAX,BWMIN,BWMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)BAMIN,BAMAX,TXMIN,TXMAX
 9042 FORMAT('BAMIN,BAMAX,TXMIN,TXMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)YMIN,YMAX,SBMIN,SBMAX
 9043 FORMAT('YMIN,YMAX,SBMIN,SBMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)BBMIN,BBMAX,TYMIN,TYMAX
 9044 FORMAT('BBMIN,BBMAX,TYMIN,TYMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9051)IBAR,DEL,XDELMN,ISAVE
 9051 FORMAT('IBAR,DEL,XDELMN,ISAVE = ',A4,2E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9059)IBUGG4,ISUBG4,IERRG4
 9059 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEFI(IHARG,IHARG2,IHARLC,IHARL2,NUMARG,
     1ICOM3,ICOM4,ICOM5,NUMCOM,NCOM5,
     1ICPREP,NCPREP,ICPOST,NCPOST,
     1ICPREH,NCPREH,ICPOSH,NCPOSH,
     1IBUGS2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--CREATE USER-DEFINED COMMANDS.
C     INPUT  ARGUMENTS--IHARG    (A CHARACTER VECTOR)
C                     --IHARG2  (A CHARACTER VECTOR)
C                     --IHARLC  (A CHARACTER VECTOR)
C                     --IHARL2  (A CHARACTER VECTOR)
C                     --NUMARG
C      OUTPUT ARGUMENTS--ICOM3
C                        ICOM4
C                        ICOM5
C                        NUMCOM
C                        NCOM5
C                        IFOUND
C                        IERROR
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--86/6
C     ORIGINAL VERSION--FEBRUARY  1986.
C     UPDATED         --AUGUST    1986.
C     UPDATED         --SEPTEMBER 1987. (PREHELP AND POSTHELP)
C
C-----NON-COMMON VARIABLES----------------------------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IHARLC
      CHARACTER*4 IHARL2
C
      CHARACTER*4 ICOM3
      CHARACTER*4 ICOM4
      CHARACTER*40 ICOM5
C
      CHARACTER*40 ICPREP
      CHARACTER*40 ICPOST
      CHARACTER*40 ICPREH
      CHARACTER*40 ICPOSH
C
      CHARACTER*40 ICOM5J
      CHARACTER*4 IC4
      CHARACTER*1 IC1
      CHARACTER*4 IC4LC
      CHARACTER*1 IC1LC
      CHARACTER*40 ISTRIN
C
      CHARACTER*4 IBUGS2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IHARLC(*)
      DIMENSION IHARL2(*)
      DIMENSION ICOM3(*)
      DIMENSION ICOM4(*)
      DIMENSION ICOM5(*)
      DIMENSION NCOM5(*)
C
C-----COMMON----------------------------------------------------------
C
      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='DPDE'
      ISUBN2='FI  '
C
      IFOUND='YES'
      IERROR='NO'
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF DPDEFI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGS2,ISUBRO
   53 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)NUMARG
   55 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMARG.LE.0)GOTO59
      DO56I=1,NUMARG
      WRITE(ICOUT,57)I,IHARG(I),IHARLC(I)
   57 FORMAT('I,IHARG(I),IHARLC(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   56 CONTINUE
   59 CONTINUE
      WRITE(ICOUT,61)NUMCOM
   61 FORMAT('NUMCOM = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMCOM.LE.0)GOTO65
      DO62I=1,NUMCOM
CCCCC WRITE(ICOUT,63)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I)
CCC63 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1I8,2X,A4,2X,A4,I8,A40)
   62 CONTINUE
   65 CONTINUE
      WRITE(ICOUT,66)IFOUND,IERROR
   66 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)NCPREP
   71 FORMAT('NCPREP = ',A4)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREP.LE.0)GOTO74
      DO72I=1,NCPREP
      WRITE(ICOUT,73)I,ICPREP(I:I)
   73 FORMAT('I,ICPREP(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   74 CONTINUE
      WRITE(ICOUT,76)NCPOST
   76 FORMAT('NCPOST = ',A4)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOST.LE.0)GOTO79
      DO77I=1,NCPOST
      WRITE(ICOUT,78)I,ICPOST(I:I)
   78 FORMAT('I,ICPOST(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
   77 CONTINUE
   79 CONTINUE
      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 THE ELEMENT NUMBER FOR THE COMMAND.**
C               **  IS IT AN EXISTING USER-DEFINED COMMAND?      **
C               **  IS IT A NEW USER-DEFINED COMMAND?            **
C               ***************************************************
C
      IF(NUMARG.LE.0)GOTO1180
C
      I2=1
      IF(NUMCOM.LE.0)GOTO1190
      DO1100I=1,NUMCOM
      I2=I
      IF(IHARG(1).EQ.ICOM3(I).AND.IHARG2(1).EQ.ICOM4(I))GOTO1190
 1100 CONTINUE
      I2=NUMCOM+1
      GOTO1190
C
 1180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('***** ERROR IN SUBROUTINE DPDEFI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      WHEN USING THE DEFINE COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)
 1183 FORMAT('      YOU MUST HAVE SOME ENTRY')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)
 1184 FORMAT('      AFTER THE WORD    DEFINE   ;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)
 1185 FORMAT('      BUT NONE WAS GIVEN HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)NUMARG
 1186 FORMAT('      NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1190 CONTINUE
C
C               *************************************************
C               **  STEP 12--                                  **
C               **  EXTRACT THE NAME OF THE COMMAND.           **
C               *************************************************
C
      ICOM3(I2)=IHARG(1)
      ICOM4(I2)=IHARG2(1)
C
C               ***************************************************
C               **  STEP 12--                                    **
C               **  EXTRACT THE ASCII SEQUENCE.                  **
C               ***************************************************
C
      ISTRIN(1:40)='                                        '
      ICOM5(I2)=ISTRIN(1:40)
      NCOM5(I2)=0
C
      J=0
      IF(NUMARG.LE.1)GOTO1290
      DO1200I=2,NUMARG
      J=J+1
C
      IC4=IHARG(I)
      IC1=IC4(1:1)
C
      IC4LC=IHARLC(I)
      IC1LC=IC4LC(1:1)
C
      IF(IC4(2:4).EQ.'   ')GOTO1210
      IF(IC4(1:3).EQ.'ESC')IC1LC=IESCC
      IF(IC4(1:3).EQ.'ESC')GOTO1210
C
      IF(IC4(1:3).EQ.'NUL')IC1LC=INULC
      IF(IC4(1:3).EQ.'SOH')IC1LC=ISOHC
      IF(IC4(1:3).EQ.'STX')IC1LC=ISTXC
      IF(IC4(1:3).EQ.'ETX')IC1LC=IETXC
      IF(IC4(1:3).EQ.'EOT')IC1LC=IEOTC
      IF(IC4(1:3).EQ.'ENQ')IC1LC=IENQC
      IF(IC4(1:3).EQ.'ACK')IC1LC=IACKC
      IF(IC4(1:3).EQ.'BEL')IC1LC=IBELC
      IF(IC4(1:2).EQ.'BS')IC1LC=IBSC
      IF(IC4(1:3).EQ.'HTX')IC1LC=IHTC
      IF(IC4(1:2).EQ.'LF')IC1LC=ILFC
      IF(IC4(1:2).EQ.'VT')IC1LC=IVTC
      IF(IC4(1:2).EQ.'FF')IC1LC=IFFC
      IF(IC4(1:2).EQ.'CR')IC1LC=ICRC
      IF(IC4(1:2).EQ.'SO')IC1LC=ISOC
      IF(IC4(1:2).EQ.'SI')IC1LC=ISIC
      IF(IC4(1:3).EQ.'DLE')IC1LC=IDLEC
      IF(IC4(1:3).EQ.'DC1')IC1LC=IDC1C
      IF(IC4(1:3).EQ.'DC2')IC1LC=IDC2C
      IF(IC4(1:3).EQ.'DC3')IC1LC=IDC3C
      IF(IC4(1:3).EQ.'DC4')IC1LC=IDC4C
      IF(IC4(1:3).EQ.'NAK')IC1LC=INAKC
      IF(IC4(1:3).EQ.'SYN')IC1LC=ISYNC
      IF(IC4(1:3).EQ.'ETB')IC1LC=IETBC
      IF(IC4(1:3).EQ.'CAN')IC1LC=ICANC
      IF(IC4(1:2).EQ.'EM')IC1LC=IEMC
      IF(IC4(1:3).EQ.'SUB')IC1LC=ISUBC
CCCCC IF(IC4(1:3).EQ.'ESC')IC1LC=IESCC
      IF(IC4(1:2).EQ.'FS')IC1LC=IFSC
      IF(IC4(1:2).EQ.'GS')IC1LC=IGSC
      IF(IC4(1:2).EQ.'RS')IC1LC=IRSC
      IF(IC4(1:2).EQ.'US')IC1LC=IUSC
      IF(IC4(1:3).EQ.'SPA')IC1LC=' '
      IF(IC4(1:2).EQ.'SP')IC1LC=' '
      IF(IC4(1:3).EQ.'BLA')IC1LC=' '
      IF(IC4(1:2).EQ.'BL')IC1LC=' '
C
 1210 CONTINUE
      ISTRIN(J:J)=IC1LC
 1200 CONTINUE
C
 1290 CONTINUE
      ICOM5(I2)=ISTRIN(1:40)
      NCOM5(I2)=J
      IF(I2.GT.NUMCOM)NUMCOM=I2
C
C               ***************************************************
C               **  STEP 13--                                    **
C               **  CHECK FOR THE USER-COMMAND   PREPLOT         **
C               **  IF FOUND, COPY IT.                           **
C               **  CHECK FOR THE USER-COMMAND   POSTPLOT        **
C               **  IF FOUND, COPY IT.                           **
C               ***************************************************
C
      IF(IHARG(1).EQ.'PREP'.AND.IHARG2(1).EQ.'LOT')GOTO1310
      IF(IHARG(1).EQ.'POST'.AND.IHARG2(1).EQ.'PLOT')GOTO1320
      GOTO1390
 1310 CONTINUE
      NCPREP=NCOM5(I2)
      ICPREP(1:40)=ICOM5(I2)
      GOTO1390
 1320 CONTINUE
      NCPOST=NCOM5(I2)
      ICPOST(1:40)=ICOM5(I2)
      GOTO1390
 1390 CONTINUE
C
C               ***************************************************
C               **  STEP 14--                                    **
C               **  CHECK FOR THE USER-COMMAND   PREHELP         **
C               **  IF FOUND, COPY IT.                           **
C               **  CHECK FOR THE USER-COMMAND   POSTHELP        **
C               **  IF FOUND, COPY IT.                           **
C               ***************************************************
C
      IF(IHARG(1).EQ.'PREH'.AND.IHARG2(1).EQ.'ELP')GOTO1410
      IF(IHARG(1).EQ.'POST'.AND.IHARG2(1).EQ.'HELP')GOTO1420
      GOTO1490
 1410 CONTINUE
      NCPREH=NCOM5(I2)
      ICPREH(1:40)=ICOM5(I2)
      GOTO1490
 1420 CONTINUE
      NCPOSH=NCOM5(I2)
      ICPOSH(1:40)=ICOM5(I2)
      GOTO1490
 1490 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF DPDEFI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGS2,ISUBRO
 9013 FORMAT('IBUGS2,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NUMARG
 9015 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NUMARG.LE.0)GOTO9019
      DO9016I=1,NUMARG
      WRITE(ICOUT,9017)I,IHARG(I),IHARLC(I)
 9017 FORMAT('I,IHARG(I),IHARLC(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9016 CONTINUE
 9019 CONTINUE
      WRITE(ICOUT,9021)I2,NUMCOM
 9021 FORMAT('I2,NUMCOM = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)I2,ICOM3(I2),ICOM4(I2),NCOM5(I2)
 9022 FORMAT('I2,ICOM3(I2),ICOM4(I2),NCOM5(I2)  = ',
     1I8,2X,A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      IMAX=NCOM5(I)
      IF(IMAX.LE.0)GOTO9033
      ICOM5J=ICOM5(I)
      DO9031I=1,IMAX
      WRITE(ICOUT,9032)I,ICOM5J(I:I)
 9032 FORMAT('I,ICOM5J(I:I) = ',I8,2X,A1,2X)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      IF(NUMCOM.LE.0)GOTO9043
      DO9041I=1,NUMCOM
CCCCC WRITE(ICOUT,9042)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I)
C9042 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ',
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC1I8,2X,A4,2X,A4,I8,A40)
 9041 CONTINUE
 9043 CONTINUE
      WRITE(ICOUT,9051)IFOUND,IERROR
 9051 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9061)IC4,IC1
 9061 FORMAT('IC4,IC1 = ',A4,2X,A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9062)IC4LC,IC1LC
 9062 FORMAT('IC4LC,IC1LC = ',A4,2X,A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9071)NCPREP
 9071 FORMAT('NCPREP = ',A4)
      CALL DPWRST('XXX','BUG ')
      IF(NCPREP.LE.0)GOTO9074
      DO9072I=1,NCPREP
      WRITE(ICOUT,9073)I,ICPREP(I:I)
 9073 FORMAT('I,ICPREP(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9072 CONTINUE
 9074 CONTINUE
      WRITE(ICOUT,9076)NCPOST
 9076 FORMAT('NCPOST = ',A4)
      CALL DPWRST('XXX','BUG ')
      IF(NCPOST.LE.0)GOTO9079
      DO9077I=1,NCPOST
      WRITE(ICOUT,9078)I,ICPOST(I:I)
 9078 FORMAT('I,ICPOST(I:I) = ',I8,2X,A1,4X)
      CALL DPWRST('XXX','BUG ')
 9077 CONTINUE
 9079 CONTINUE
      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 DPDEFL(ICASPL,ICAS3D,
     1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
     1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
     1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
     1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
     1NMJX1T,NMJX2T,NMJY1T,NMJY2T)
C
C     PURPOSE--TRANSFORM OBSERVED DATA LIMITS
C              OR GIVEN LIMITS
C              INTO ACTUAL FRAME LIMITS
C              (WHICH MAY OR MAY NOT BE NEAT--
C              DEPENDING ON THE SPECIFICATION)
C              FOR ALL 4 FRAME LINES.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 IX1MIN
      CHARACTER*4 IX1MAX
      CHARACTER*4 IY1MIN
      CHARACTER*4 IY1MAX
C
      CHARACTER*4 IX2MIN
      CHARACTER*4 IX2MAX
      CHARACTER*4 IY2MIN
      CHARACTER*4 IY2MAX
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IX2TSC
      CHARACTER*4 IY1TSC
      CHARACTER*4 IY2TSC
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.'DEFL')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEFL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)DX1MIN,DY1MIN,DX1MAX,DY1MAX
   52 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)DX2MIN,DY2MIN,DX2MAX,DY2MAX
   53 FORMAT('DX2MIN,DY2MIN,DX2MAX,DY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)GX1MIN,DY1MIN,GX1MAX,DY1MAX
   54 FORMAT('GX1MIN,DY1MIN,GX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)GX2MIN,DY2MIN,GX2MAX,DY2MAX
   55 FORMAT('GX2MIN,DY2MIN,GX2MAX,DY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IX1MIN,IY1MIN,IX1MAX,IY1MAX
   56 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)IX2MIN,IY2MIN,IX2MAX,IY2MAX
   57 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)IX1TSC,IX2TSC,IY1TSC,IY2TSC
   58 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   61 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)FX2MIN,FX2MAX,FY2MIN,FY2MAX
   62 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)ICASPL,ICAS3D
   63 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)NMJX1T,NMJX2T,NMJY1T,NMJY2T
   64 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ******************************************************
C               **  STEP 1--                                        **
C               **  DETERMINE FRAME LIMITS ON BOTTOM HORIZONTAL AXIS  **
C               ******************************************************
C
      CALL DPDEF2(DX1MIN,DX1MAX,GX1MIN,GX1MAX,IX1MIN,IX1MAX,IX1TSC,
     1FX1MIN,FX1MAX,NMJX1T)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  DETERMINE FRAME LIMITS ON TOP  HORIZONTAL   AXIS  **
C               ******************************************************
C
      CALL DPDEF2(DX2MIN,DX2MAX,GX2MIN,GX2MAX,IX2MIN,IX2MAX,IX2TSC,
     1FX2MIN,FX2MAX,NMJX2T)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  DETERMINE FRAME LIMITS ON LEFT    VERTICAL AXIS  **
C               ******************************************************
C
      CALL DPDEF2(DY1MIN,DY1MAX,GY1MIN,GY1MAX,IY1MIN,IY1MAX,IY1TSC,
     1FY1MIN,FY1MAX,NMJY1T)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 4--                                        **
C               **  DETERMINE FRAME LIMITS ON RIGHT   VERTICAL   AXIS  **
C               ******************************************************
C
      CALL DPDEF2(DY2MIN,DY2MAX,GY2MIN,GY2MAX,IY2MIN,IY2MAX,IY2TSC,
     1FY2MIN,FY2MAX,NMJY2T)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEFL')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEFL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)DX1MIN,DY1MIN,DX1MAX,DY1MAX
 9012 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)DX1MIN,DY1MIN,DX1MAX,DY1MAX
 9013 FORMAT('DX1MIN,DY1MIN,DX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)GX1MIN,DY1MIN,GX1MAX,DY1MAX
 9014 FORMAT('GX1MIN,DY1MIN,GX1MAX,DY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)GX2MIN,DY2MIN,GX2MAX,DY2MAX
 9015 FORMAT('GX2MIN,DY2MIN,GX2MAX,DY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IX1MIN,IY1MIN,IX1MAX,IY1MAX
 9016 FORMAT('IX1MIN,IY1MIN,IX1MAX,IY1MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IX2MIN,IY2MIN,IX2MAX,IY2MAX
 9017 FORMAT('IX2MIN,IY2MIN,IX2MAX,IY2MAX = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)IX1TSC,IX2TSC,IY1TSC,IY2TSC
 9018 FORMAT('IX1TSC,IX2TSC,IY1TSC,IY2TSC = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9021 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)FX2MIN,FX2MAX,FY2MIN,FY2MAX
 9022 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)ICASPL,ICAS3D
 9023 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)NMJX1T,NMJX2T,NMJY1T,NMJY2T
 9024 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEF2(DMIN,DMAX,GMIN,GMAX,IMIN,IMAX,ITICSC,
     1FMIN,FMAX,NUMMAJ)
C
C     PURPOSE--TRANSFORM OBSERVED DATA LIMITS
C              OR GIVEN LIMITS
C              INTO ACTUAL FRAME LIMITS
C              (WHICH MAY OR MAY NOT BE NEAT--
C              DEPENDING ON THE SPECIFICATION)
C              FOR A SINGLE FRAME LINE.
C     NOTE--ALGORITHM SUGGESTED BY WALTER LIGGETT
C           NATIONAL BUREAU OF STANDARDS
C     INTERESTING TEST PROBLEMS--156 AND 234
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED         --???       19??.  WEIBULL SCALE
C     UPDATED         --JUNE      1990.  NORMAL SCALE
C     UPDATED         --JULY      1996.  ALLOW UPPER AND LOWER BOUND
C                                        TO BE EQUAL
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 IMIN
      CHARACTER*4 IMAX
      CHARACTER*4 ITICSC
C
      DIMENSION WEIB21(25)
CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990
      DIMENSION ANORM(27)
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-----DATA STATEMENTS---------------------------------------------------
C
      DATA WEIB21( 1),WEIB21( 2),WEIB21( 3),WEIB21( 4),WEIB21( 5),
     1     WEIB21( 6),WEIB21( 7),WEIB21( 8),WEIB21( 9),WEIB21(10),
     1     WEIB21(11),WEIB21(12),WEIB21(13),WEIB21(14),WEIB21(15),
     1     WEIB21(16),WEIB21(17),WEIB21(18),WEIB21(19),WEIB21(20),
     1     WEIB21(21)
     1/0.000001,0.00001,0.0001,0.001,0.01,0.1,
     1 0.5,1.0,5.0,10.0,20.0,30.0,40.0,50.0,
     1 60.0,70.0,80.0,90.0,95.0,99.0,99.9/
C
CCCCC THE FOLLOWING DATA STATEMENT WAS ADDED JUNE 1990
      DATA ANORM( 1),ANORM( 2),ANORM( 3),ANORM( 4),ANORM( 5),
     1     ANORM( 6),ANORM( 7),ANORM( 8),ANORM( 9),ANORM(10),
     1     ANORM(11),ANORM(12),ANORM(13),ANORM(14),ANORM(15),
     1     ANORM(16),ANORM(17),ANORM(18),ANORM(19),ANORM(20),
     1     ANORM(21),ANORM(22),ANORM(23),ANORM(24),ANORM(25),
     1     ANORM(26),ANORM(27)
     1/0.000001,0.00001,0.0001,0.001,0.01,0.1,0.5,
     1 1.0,5.0,10.0,20.0,30.0,40.0,
     1 50.0,
     1 60.0,70.0,80.0,90.0,95.0,99.0,
     1 99.5,99.9,99.99,99.999,99.9999,99.99999,99.999999/
C
C-----START POINT-----------------------------------------------------
C
      RTMINP=(-999.0)
      RTMAXP=(-999.00)
      ANUM=0.0
      EXPMIN=0.0
      EXPMAX=0.0
      IEXMIN=0
      IEXMAX=0
      AEXMIN=0.0
      AEXMAX=0.0
      DELMIN=0.0
      DELMAX=0.0
      ATMIN=0.0
      ATMAX=0.0
      IEXP=0
      IRTMIN=0
      IRTMAX=0
      RTMIN=0.0
      RTMAX=0.0
      ANMIN=0.0
      ANMAX=0.0
C
      AHUNDR=100.0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEF2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)DMIN,DMAX
   52 FORMAT('DMIN,  DMAX   = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)GMIN,GMAX
   53 FORMAT('GMIN,  GMAX   = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IMIN,IMAX
   54 FORMAT('IMIN,  IMAX   = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ITICSC
   55 FORMAT('ITICSC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)NUMMAJ
   56 FORMAT('NUMMAJ = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *******************************************************
C               **  STEP 1--                                         **
C               **  AS A STARTER FOR THE LINEAR, LOG,
C               **  WEIBULL, AND NORMAL CASES,
C               **  TREAT THE FIXED OR FLOATING CASE                 **
C               *******************************************************
C
      FMINOL=FMIN
      FMAXOL=FMAX
C
      AMIN=DMIN
      AMAX=DMAX
      IF(IMIN.EQ.'FIXE')AMIN=GMIN
      IF(IMAX.EQ.'FIXE')AMAX=GMAX
C
      IF(AMIN.LT.AMAX)GOTO1190
      HOLD=AMIN
      AMAX=AMIN
      AMIN=HOLD
 1190 CONTINUE
C
C               *****************************************
C               **  STEP 2--                           **
C               **  TREAT THE LOG SCALE CASE           **
C               **  (WHICH WILL AUTOMATICALLY BE NEAT  **
C               **  WITH FULL CYCLES RESULTING)        **
C               *****************************************
C
      IF(ITICSC.EQ.'LOG')GOTO1200
      GOTO1290
C
 1200 CONTINUE
      IF(AMIN.LE.0.0)ANUM=AMIN
      IF(AMIN.LE.0.0)GOTO1210
      IF(AMAX.LE.0.0)ANUM=AMAX
      IF(AMAX.LE.0.0)GOTO1210
      GOTO1219
C
 1210 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** ERROR IN DPDEF2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      WHILE COMPUTING FRAME LIMITS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      FOR A LOG SCALE PLOT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      THE LOG OF A NON-POSITIVE NUMBER ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      WAS ENCOUNTERED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)ANUM
 1216 FORMAT('      THE NUMBER = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)
 1217 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1218)
 1218 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1219 CONTINUE
C
      IF(AMIN.EQ.AMAX)THEN
        EXPMIN=ALOG10(AMIN)
        IF(EXPMIN.LT.0.0)EXPMIN=EXPMIN-1.0
        IEXMIN=EXPMIN
        FMIN=10.0**IEXMIN
        FMAX=FMIN
        GOTO9000
      ENDIF
C
      EXPMIN=ALOG10(AMIN)
      IF(EXPMIN.LT.0.0)EXPMIN=EXPMIN-1.0
      EXPMAX=ALOG10(AMAX)
      IEXMIN=EXPMIN
      IEXMAX=EXPMAX
      AEXMIN=IEXMIN
      AEXMAX=IEXMAX
      DELMIN=EXPMIN-AEXMIN
      DELMAX=EXPMAX-AEXMAX
      IF(DELMAX.GE.0.00001)IEXMAX=IEXMAX+1
      IF(IEXMAX.EQ.IEXMIN)IEXMAX=IEXMIN+1
C
      FMIN=10.0**IEXMIN
      FMAX=10.0**IEXMAX
      GOTO9000
C
 1290 CONTINUE
C
C               *****************************************
C               **  STEP 3--                           **
C               **  TREAT THE WEIBULL SCALE CASE       **
C               **  (WHICH WILL AUTOMATICALLY BE NEAT) **
C               *****************************************
C
      IF(ITICSC.EQ.'WEIB')GOTO1300
      GOTO1390
C
 1300 CONTINUE
      IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)ANUM=AMIN
      IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)GOTO1310
      IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)ANUM=AMAX
      IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)GOTO1310
      GOTO1319
C
 1310 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN DPDEF2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      WHILE COMPUTING FRAME LIMITS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1313)
 1313 FORMAT('      FOR A WEIBULL SCALE PLOT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1314)
 1314 FORMAT('      THE LOG OF A NUMBER OUTSIDE OF ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1315)
 1315 FORMAT('      THE    0 TO 100 RANGE    WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1316)ANUM
 1316 FORMAT('      THE NUMBER = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1317)
 1317 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1318)
 1318 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1319 CONTINUE
C
      NUMMA2=NUMMAJ
      IF(NUMMAJ.LE.16)NUMMA2=16
      IF(NUMMAJ.GE.21)NUMMA2=21
C
      I1=1+(21-NUMMA2)
      I2=21
C
      FMIN=WEIB21(I1)
      FMAX=WEIB21(I2)
C
      GOTO9000
C
 1390 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1990
C               *****************************************
C               **  STEP 4--                           **
C               **  TREAT THE NORMAL SCALE CASE        **
C               **  (WHICH WILL AUTOMATICALLY BE NEAT) **
C               *****************************************
C
      IF(ITICSC.EQ.'NORM')GOTO1400
      GOTO1490
C
 1400 CONTINUE
CCCCC IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)ANUM=AMIN
CCCCC IF(AMIN.LE.0.0.OR.AMIN.GE.AHUNDR)GOTO1410
CCCCC IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)ANUM=AMAX
CCCCC IF(AMAX.LE.0.0.OR.AMAX.GE.AHUNDR)GOTO1410
      GOTO1419
C
 1410 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1411)
 1411 FORMAT('***** ERROR IN DPDEF2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1412)
 1412 FORMAT('      WHILE COMPUTING FRAME LIMITS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1413)
 1413 FORMAT('      FOR A NORMAL SCALE PLOT,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1414)
 1414 FORMAT('      A NUMBER OUTSIDE OF ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1415)
 1415 FORMAT('      THE    0 TO 100 RANGE    WAS ENCOUNTERED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1416)ANUM
 1416 FORMAT('      THE NUMBER = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1417)
 1417 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1418)
 1418 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1419 CONTINUE
C
      NUMMA2=NUMMAJ
      IF(NUMMAJ.LE.15)NUMMA2=15
      IF(NUMMAJ.GE.27)NUMMA2=27
      IHALF=NUMMA2/2
      I1=14-IHALF
      I2=14+IHALF
      IF(I1.LE.1)I1=1
      IF(I2.GE.27)I2=27
C
      FMIN=ANORM(I1)
      FMAX=ANORM(I2)
C
      GOTO9000
C
 1490 CONTINUE
C
C               ************************************
C               **  STEP 34--                      **
C               **  TREAT THE EQUALITY CASE       **
C               **  WHICH WILL AUTOMATICALLY GET  **
C               **  ARTIFICIAL, NON-EQUAL LIMITS  **
C               ************************************
C
      IF(AMIN.EQ.AMAX)GOTO4400
      GOTO4490
C
 4400 CONTINUE
      IF(AMIN.EQ.0.0)ATMIN=-1.0
      IF(AMIN.EQ.0.0)ATMAX=1.0
      IF(AMIN.LT.0.0)ATMIN=1.05*AMIN
      IF(AMIN.LT.0.0)ATMAX=0.95*AMIN
      IF(AMIN.GT.0.0)ATMIN=0.95*AMIN
      IF(AMIN.GT.0.0)ATMAX=1.05*AMIN
      FMIN=ATMIN
      FMAX=ATMAX
      GOTO9000
C
 4490 CONTINUE
C
C               ***************************************
C               **  STEP 35--                         **
C               **  COMPUTE NEAT, NON-LOG    LIMITS  **
C               ***************************************
C
      ATMIN=AMIN
      ATMAX=AMAX
      IEXP=0
 4500 CONTINUE
      ATDEL=ATMAX-ATMIN
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,4505)ATMIN,ATMAX,ATDEL,IEXP
 4505 FORMAT('ATMIN,ATMAX,ATDEL,IEXP = ',3E15.7,I8)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(ATDEL.LT.1.0)GOTO4510
      IF(ATDEL.GT.10.0)GOTO4520
      GOTO4530
C
 4510 CONTINUE
      ATMIN=ATMIN*10.0
      ATMAX=ATMAX*10.0
      IEXP=IEXP+1
      GOTO4500
C
 4520 CONTINUE
      ATMIN=ATMIN/10.0
      ATMAX=ATMAX/10.0
      IEXP=IEXP-1
      GOTO4500
C
 4530 CONTINUE
      CALL DPDEF3(ATMIN,ATMAX,RTMIN,RTMAX)
C
 4590 CONTINUE
      DENOM=10.0**IEXP
      ANMIN=RTMIN/DENOM
      ANMAX=RTMAX/DENOM
C
      FMIN=AMIN
      FMAX=AMAX
      IF(IMIN.EQ.'FLOA')FMIN=ANMIN
      IF(IMAX.EQ.'FLOA')FMAX=ANMAX
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEF2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)DMIN,DMAX
 9012 FORMAT('DMIN,  DMAX   = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)GMIN,GMAX
 9013 FORMAT('GMIN,  GMAX   = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IMIN,IMAX
 9014 FORMAT('IMIN,  IMAX   = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ITICSC
 9015 FORMAT('ITICSC = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)FMIN,FMAX
 9016 FORMAT('FMIN,  FMAX   = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)NUMMAJ
 9017 FORMAT('NUMMAJ = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)EXPMIN,EXPMAX
 9021 FORMAT('EXPMIN,EXPMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IEXMIN,IEXMAX
 9022 FORMAT('IEXMIN,IEXMAX = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)IEXP
 9031 FORMAT('IEXP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)ATMIN,ATMAX
 9032 FORMAT('ATMIN, ATMAX  = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IRTMIN,IRTMAX
 9033 FORMAT('IRTMIN,IRTMAX = ',4X,I8,4X,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)RTMIN,RTMAX
 9034 FORMAT('RTMIN, RTMAX  = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)ANMIN,ANMAX
 9035 FORMAT('ANMIN,ANMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)AMIN,AMAX,EXPMIN,EXPMAX,IEXMIN,IEXMAX
 9036 FORMAT('AMIN,AMAX,EXPMIN,EXPMAX,IEXMIN,IEXMAX = ',4E15.7,2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)AEXMIN,AEXMAX,DELMIN,DELMAX
 9037 FORMAT('AEXMIN,AEXMAX,DELMIN,DELMAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)AMIN,ATMIN,IRTMIN,RTMIN,RTMINP,ANMIN,FMIN
 9041 FORMAT('AMIN,ATMIN,IRTMIN,RTMIN,RTMINP,ANMIN,FMIN = ',
     12E11.3,I8,4E11.3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)AMAX,ATMAX,IRTMIN,RTMAX,RTMAXP,ANMAX,FMAX
 9042 FORMAT('AMAX,ATMAX,IRTMAX,RTMAX,RTMAXP,ANMAX,FMAX = ',
     12E11.3,I8,4E11.3)
      CALL DPWRST('XXX','BUG ')
      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 DPDEF3(ATMIN,ATMAX,RTMIN,RTMAX)
C
C     PURPOSE--TRANSFORM LIMITS (WHICH ARE SUCH
C              THAT THERE DIFFERENCE IS BETWEEN 1 AND 10)
C              INTO NEAT LIMITS.
C     NOTE--ALGORITHM SUGGESTED BY WALTER LIGGETT
C           NATIONAL BUREAU OF STANDARDS
C     INTERESTING TEST PROBLEMS--156 AND 234
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICMIN
      CHARACTER*4 ICMAX
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
      IRTMIN=(-999)
      IRTMAX=(-999)
      RTMINP=(-999.0)
      RTMAXP=(-999.0)
C
      EPS=0.00001
      ONEMEP=1.0-EPS
      ONEPEP=1.0+EPS
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF3')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEF3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ATMIN,ATMAX
   52 FORMAT('ATMIN,ATMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)EPS
   53 FORMAT('EPS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
 1100 CONTINUE
      CALL CKINTE(ATMIN,EPS,ONEMEP,ONEPEP,ICMIN,IRTMIN)
      CALL CKINTE(ATMAX,EPS,ONEMEP,ONEPEP,ICMAX,IRTMAX)
      RTMIN=IRTMIN
      RTMAX=IRTMAX
      IF(ICMIN.EQ.'YES'.AND.ICMAX.EQ.'YES')GOTO9000
C
 1120 CONTINUE
      IF(ICMIN.EQ.'YES')GOTO1129
      IRTMIN=ATMIN
      IF(ATMIN.LT.0.0)IRTMIN=ATMIN-1.0
      RTMIN=IRTMIN
CCCCC RTMINP=RTMIN+0.5
CCCCC IF(RTMINP.LE.ATMIN)RTMIN=RTMINP
 1129 CONTINUE
C
 1130 CONTINUE
      IF(ICMAX.EQ.'YES')GOTO1139
      IRTMAX=ATMAX+1.0
      IF(ATMAX.LT.0.0)IRTMAX=ATMAX
      RTMAX=IRTMAX
CCCCC RTMAXP=RTMAX-0.5
CCCCC IF(RTMAXP.GE.ATMAX)RTMAX=RTMAXP
 1139 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DEF3')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEF3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)ATMIN,IRTMIN,RTMINP,RTMIN
 9021 FORMAT('ATMIN,IRTMIN,RTMINP,RTMIN = ',
     1E15.7,I8,E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)ATMAX,IRTMAX,RTMAXP,RTMAX
 9022 FORMAT('ATMAX,IRTMAX,RTMAXP,RTMAX = ',
     1E15.7,I8,E15.7,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)EPS,ONEMEP,ONEPEP
 9025 FORMAT('EPS,ONEMEP,ONEPEP = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)ICMIN,ICMAX
 9026 FORMAT('ICMIN,ICMAX = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4
 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
CCCCC DEBUG TRACE,INIT
CCCCC AT 90
CCCCC TRACE ON
      END
      SUBROUTINE DPDEFN(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IBUGO2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--SHOW DEVICE FONTS.  THIS COMMAND IS INTENDED
C              FOR DEVICES WHICH SUPPORT VARIOUS HARDWARE FONTS
C              (RIGHT NOW, LIMITED TO POSTSCRIPT).
C     INPUT  ARGUMENTS--ICOM   (A  CHARACTER VECTOR)
C                     --IHARG  (A  CHARACTER VECTOR)
C                     --IHARG2 (A CHARACTER VECTOR)
C                     --IARGT  (A CHARACTER VECTOR)
C                     --IARG   (A CHARACTER VECTOR)
C                     --NUMARG
C     OUTPUT ARGUMENTS--
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --SEPTEMBER 1993.  FIX MULTI-LINE FORMATS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICOM
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*40 ICPREH
      CHARACTER*4 IRESP
      CHARACTER*40 IPSTAL(100)
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCODV.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
      DATA (IPSTAL(I),I=1,15)/
     1 'TIMES ROMAN',
     2 'TIMES ITALIC',
     3 'TIMES BOLD',
     4 'TIMES BOLD ITALIC',
     5 'HELVETICA',
     6 'HELVETICA OBLIQUE',
     7 'HELVETICA BOLD',
     8 'HELVETICA BOLD OBLIQUE',
     9 'COURIER',
     * 'COURIER OBLIQUE',
     1 'COURIER BOLD',
     2 'COURIER BOLD OBLIQUE',
     3 'AVANT GARDE',
     4 'AVANT GARDE BOOK OBLIQUE',
     5 'AVANT GARDE DEMI'/
      DATA (IPSTAL(I),I=16,30)/
     1 'AVANT GARDE DEMI OBLIQUE',
     2 'BOOK DEMI',
     3 'BOOK DEMI ITALIC',
     4 'BOOK LIGHT',
     5 'BOOK LIGHT ITALIC',
     6 'HELVETICA NARROW',
     7 'HELVETICA NARROW BOLD',
     8 'HELVETICA NARROW BOLD OBLIQUE',
     9 'HELVETICA NARROW OBLIQUE',
     * 'CENTURY',
     1 'CENTURY BOLD',
     2 'CENTURY ITALIC',
     3 'CENTURY BOLD ITALIC',
     4 'PALATINO',
     5 'PALATINO BOLD'/
      DATA (IPSTAL(I),I=31,45)/
     1 'PALATINO ITALIC',
     2 'PALATINO BOLD ITALIC',
     3 'ZAPF',
     4 'SYMBOL',
     5 ' ',
     6 ' ',
     7 ' ',
     8 ' ',
     9 ' ',
     * ' ',
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' '/
      DATA (IPSTAL(I),I=46,60)/
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' ',
     6 ' ',
     7 ' ',
     8 ' ',
     9 ' ',
     * ' ',
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' '/
      DATA (IPSTAL(I),I=61,75)/
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' ',
     6 ' ',
     7 ' ',
     8 ' ',
     9 ' ',
     * ' ',
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' '/
      DATA (IPSTAL(I),I=76,90)/
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' ',
     6 ' ',
     7 ' ',
     8 ' ',
     9 ' ',
     * ' ',
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' '/
      DATA (IPSTAL(I),I=91,100)/
     1 ' ',
     2 ' ',
     3 ' ',
     4 ' ',
     5 ' ',
     6 ' ',
     7 ' ',
     8 ' ',
     9 ' ',
     * ' '/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
      IBUGG4='OFF'
      ISUBG4='-999'
C
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEFN')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF DPDEFN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGO2
   53 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFOUND,IERROR
   60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
         WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
   71    FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1   I8,2X,A4,2X,A4,2X,A4,2X,I8)
         CALL DPWRST('XXX','BUG ')
   70 CONTINUE
   90 CONTINUE
C
      IF(ICOM.EQ.'POST')GOTO4100
C
C  *****************************************
C  **  POSTSCRIPT CASE                    **
C  *****************************************
C
 4100 CONTINUE
C
      IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'SHOW')GOTO4800
      IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'LIST')GOTO4800
      IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'PRIN')GOTO4800
      IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'DEFA')GOTO4500
      IF(IHARG(1).EQ.'FONT'.AND. IHARG(2).EQ.'    ')GOTO4800
      IF(IHARG(1).EQ.'FONT')GOTO4110
      IF(IHARG(1).EQ.'SHOW')GOTO4800
      IF(IHARG(1).EQ.'LIST')GOTO4800
      IF(IHARG(1).EQ.'PRIN')GOTO4800
      GOTO9000
C
 4110 CONTINUE
      IARGFN=3
      GOTO4190
C
 4120 CONTINUE
      IARGFN=2
      GOTO4190
C
 4190 CONTINUE
      IFOUND='YES'
      IF(IHARG(IARGFN).EQ.'    ')GOTO4800
      IF(IHARG(IARGFN).EQ.'AUTO')GOTO4500
      IF(IHARG(IARGFN).EQ.'DEFA')GOTO4500
      IF(IHARG(IARGFN).EQ.'ON  ')GOTO4500
      IF(IHARG(IARGFN).EQ.'LIST')GOTO4800
      IF(IHARG(IARGFN).EQ.'SHOW')GOTO4800
      IF(IHARG(IARGFN).EQ.'PRIN')GOTO4800
      GOTO4600
C
C  SET DEFAULT POSTSCRIPT FONT
C
 4500 CONTINUE
      IFOUND='YES'
      IPSTFN='HELB'
      IF(IFEEDB.EQ.'OFF')GOTO4519
      WRITE(ICOUT,4508)IPSTFN
 4508 FORMAT('THE POSTSCRIPT FONT HAS BEEN SET TO ',A4)
      CALL DPWRST('XXX','BUG ')
 4519 CONTINUE
      GOTO9000
C
C  SET POSTSCRIPT FONT.  THIS CODE HAS NOT BEEN WRITTEN YET.
C
 4600 CONTINUE
      GOTO9000
C
C  LIST AVAILABLE POSTSCRIPT FONTS
C
 4800 CONTINUE
      IFOUND='YES'
      IHELMX=24
      NCPREH=0
      ICPREH=' '
      IRESP='YES'
      IBUGO2='OFF'
      NUMLPR=4
      DO4810I=1,IPSTMF
         NUMLPR=NUMLPR+3
         IF(NUMLPR.GE.IHELMX)THEN
            CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
            NUMLPR=0
            IF(IRESP.EQ.'NO')GOTO9000
         END IF
CCCCC THE FOLLOWING FORMAT STATEMENT WAS SPLIT   SEPTEMBER 1993
         WRITE(ICOUT,4811)IPSTT2(I)
 4811    FORMAT('POSTSCRIPT FONT: ',A40)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4812)IPSTT1(I)
 4812    FORMAT('      SET POSTSCRIPT FONT ',A4,' OR')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4813)IPSTAL(I)
 4813    FORMAT('      SET POSTSCRIPT FONT ',A40)
         CALL DPWRST('XXX','BUG ')
 4810 CONTINUE
      GOTO9000
C
 4910 CONTINUE
      IERROR='YES'
      GOTO9000
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEFN')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF DPDEFN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGO2
 9013 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGG4,ISUBG4
 9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFOUND,IERROR
 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEFR(IHARG,IARGT,ARG,NUMARG,DEFDMF,
     1DEMOFR,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE FREQUENCY AS INPUT IN COMPLEX
C              DEMODULATION.
C              THE SPECIFIED FREQUENCY VALUE WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE DEMOFR.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --ARG    (A  FLOATING POINT VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --DEFDMF (A  FLOATING POINT VARIABLE)
C     OUTPUT ARGUMENTS--DEMOFR (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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--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
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1150
      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
      IF(IHARG(NUMARG).EQ.'?')GOTO8100
      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
      GOTO1120
C
 1120 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1121)
 1121 FORMAT('***** ERROR IN DPDEFR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR DEMODULATION FREQUENCY ',
     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 ANALYST DESIRES THE  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      FREQUENCY FOR DEMODULATION ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      TO BE .25 (OBSERVATIONS PER UNIT TIME)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1129)
 1129 FORMAT('      THEN THE ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1130)
 1130 FORMAT('      DEMODULATION FREQUENCY .25 ')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      HOLD=DEFDMF
      GOTO1180
C
 1160 CONTINUE
      HOLD=ARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      DEMOFR=HOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)DEMOFR
 1181 FORMAT('THE DEMODULATION FREQUENCY HAS JUST BEEN SET TO ',
     1E15.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)DEMOFR
 8111 FORMAT('THE CURRENT DEMODULATION FREQUENCY IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8112)DEFDMF
 8112 FORMAT('THE DEFAULT DEMODULATION FREQUENCY IS ',E15.7)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEFT(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IDEFFN,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
     1IBUGO2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE FONT (TEKT/SIMP/...) FOR AN OUTPUT DEVICE.
C              THE FONT FOR DEVICE I
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C              VECTOR IDFONT(.).
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                     --IDEFFN
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDFONT (A CHARACTER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              FONT (ON/OFF) FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--96/7
C     ORIGINAL VERSION--JULY      1996.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IDEFFN
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
      CHARACTER*4 IDFONT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDFONT(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
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)GOTO9000
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FONT')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FONT')GOTO1140
      GOTO9000
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1120
      IF(IHARG(2).EQ.'ON')GOTO1120
      IF(IHARG(2).EQ.'OFF')GOTO1125
      IF(IHARG(2).EQ.'AUTO')GOTO1127
      IF(IHARG(2).EQ.'DEFA')GOTO1127
      GOTO1128
C
 1120 CONTINUE
      IHOLD='SIMP'
      GOTO1130
C
 1125 CONTINUE
      IHOLD='OFF'
      GOTO1130
C
 1127 CONTINUE
      IHOLD=IDEFFN
      GOTO1130
C
 1128 CONTINUE
      IHOLD=IHARG(NUMARG)
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDFONT(I)=IHOLD
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IHOLD
 1136 FORMAT('THE FONT FOR ALL DEVICES HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO9000
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDEFT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... FONT COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 FONT TEKTRONIX')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDEFT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... FONT COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1160 CONTINUE
      IF(NUMARG.LE.2)GOTO1170
      IF(IHARG(3).EQ.'ON')GOTO1170
      IF(IHARG(3).EQ.'OFF')GOTO1175
      IF(IHARG(3).EQ.'AUTO')GOTO1177
      IF(IHARG(3).EQ.'DEFA')GOTO1177
      GOTO1178
C
 1170 CONTINUE
      IHOLD='SIMP'
      GOTO1180
C
 1175 CONTINUE
      IHOLD='OFF'
      GOTO1180
C
 1177 CONTINUE
      IHOLD=IDEFFN
      GOTO1180
C
 1178 CONTINUE
      IHOLD=IHARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDFONT(I)=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR           --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1191)IDFONT(I)
 1191 FORMAT('            FONT             --',A4)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEGR(IHARG,IARGT,IARG,NUMARG,IDEFDG,
     1IDEG,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE INTEGER DEGREE OF THE POLYNOMIAL
C              FOR USE IN THE FIT, PRE-FIT, SPLINE FIT, AND SMOOTH COMMANDS.
C              THE SPECIFIED DEGREE WILL BE PLACED
C              IN THE FLOATING POINT VARIABLE IDEG.
C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
C                     --IARGT  (A  HOLLERITH VECTOR)
C                     --IARG   (AN INTEGER VECTOR)
C                     --NUMARG (AN INTEGER VARIABLE)
C                     --IDEFDG (AN INTEGER VARIABLE)
C     OUTPUT ARGUMENTS--IDEG   (AN INTEGER VARIABLE)
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER 1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IARGT
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
C
 1110 CONTINUE
      IF(NUMARG.LE.0)GOTO1150
      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEGR')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 DPDEGR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1122)
 1122 FORMAT('      ILLEGAL FORM FOR DEGREE ',
     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 ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1126)
 1126 FORMAT('      TO SET THE DEGREE = 3  ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1127)
 1127 FORMAT('      FOR SOME SMOOTHING OR FITTING OPERATION,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1128)
 1128 FORMAT('      THEN AN ALLOWABLE FORM IS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1129)
 1129 FORMAT('      DEGREE 3 ')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1150 CONTINUE
      IHOLD=IDEFDG
      GOTO1180
C
 1160 CONTINUE
      IHOLD=IARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDEG=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)IDEG
 1181 FORMAT('THE POLYNOMIAL DEGREE HAS JUST BEEN SET TO ',
     1I8)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1199
C
 1199 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEGP(Y,N,
     1XTEMP,MAXNXT,
     1GAMMA,A,SDG,THRESH,
     1GAMMA2,ALOC,SCALE,
     1IGEPDF,ICAPSW,ICAPTY,
     1PPOTTO,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE DEHAAN
C              ESTIMATES FOR THE GENERALIZED PARETO DISTRIBUTION.
C              THIS IS USED IN EXTREME VALUE APPLICATIONS.
C     EXAMPLE--DEHAAN Y
C     REFERENCE--DeHaan (1994). "Extreme Value Theory and
C                Applications", Edited by Galambos, Lechner, and
C                Simiu, Kluwer Academic Publishers, Boston,
C                pp. 93-122.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98/5
C     ORIGINAL VERSION--MAY       1998.
C     UPDATED         --APRIL     2005. NUMEROUS CORRECTIONS AND
C                                       ENHANCEMENTS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IGEPDF
      CHARACTER*4 ICAPSW
      CHARACTER*4 ICAPTY
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*8 ISIGN1
      CHARACTER*8 ISIGN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      EXTERNAL DGAMMA
      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
      DATA PI / 3.1415926535/
      DATA MINSIZ / 5/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPDE'
      ISUBN2='GP  '
C
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF DPDEGP--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,53)THRESH,MINSIZ
   53   FORMAT('THRESH,MINSIZ = ',G15.7,I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,PPOTTO
   55   FORMAT('N,PPOTTO = ',I8,2X,G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MAX(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='11'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LT.MINSIZ)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)
 1111   FORMAT('***** ERROR IN DEHAAN GENERALIZED PARETO ',
     1         'ESTIMATION--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1112)
 1112   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN THE')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1113)MINSIZ
 1113   FORMAT('      MINIMUM REQUIRED OF ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1114)N
 1114   FORMAT('THE NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
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,1111)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,1133)HOLD
 1133 FORMAT('      THE INPUT DATA HAS ALL ELEMENTS EQUAL TO ',G15.7)
      CALL DPWRST('XXX','WRIT')
      IERROR='YES'
      GOTO9000
 1139 CONTINUE
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CARRY OUT CALCULATIONS                **
C               **  FOR DEHAAN ESTIMATE                   **
C               **  SORT THE DATA                         **
C               **  AND IDENTIFY POINTS ABOVE THE THRESHOLD*
C               ********************************************
C
 2100 CONTINUE
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL SORT(Y,N,Y)
      EPS=0.0001
      IF(THRESH.LE.0.0)THRESH=Y(1)-EPS
      DO2110I=1,N
        IF(Y(I).GT.THRESH)THEN
          IFRST=I
          GOTO2119
        ENDIF
 2110 CONTINUE
      IFIRST=N+1
 2119 CONTINUE
C
      NUSE=N-IFRST+1
      IF(NUSE.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2121)
 2121   FORMAT('      NO POINTS ARE ABOVE THE THRESHOLD.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2123)THRESH
 2123   FORMAT('      THRESHOLD          = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2125)Y(N)
 2125   FORMAT('      MAXIMUM DATA POINT = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(Y(IFRST).LT.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1111)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2131)
 2131   FORMAT('      NEGATIVE VALUES ENCOUNTERED IN THE INPUT ',
     1         'DATA.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      CALL DEHAAN(Y(IFRST),NUSE,GAMMA,SDG,KK,ANM1)
C
      U=Y(IFRST)
      IF(GAMMA.GE.0.0)THEN
        RHO1=1.0
      ELSE
        RHO1=1.0/(1.0-GAMMA)
      ENDIF
      A=U*ANM1/RHO1
C
      IWRITE='OFF'
      CALL MEAN(Y(IFRST),NUSE,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL SD(Y(IFRST),NUSE,IWRITE,XSD,IBUGA3,IERROR)
      IF(GAMMA.LT.-PPOTTO)THEN
        GAMMA2=-1.0/GAMMA
        DA=DGAMMA(DBLE((GAMMA2+1.0)/GAMMA2))
        DB=DGAMMA(DBLE((GAMMA2+2.0)/GAMMA2)) - DA*DA
        IF(DB.GT.0.0D0)THEN
          SCALE=XSD/REAL(DSQRT(DB))
          ALOC=XMEAN + SCALE*REAL(DA)
        ELSE
          SCALE=0.0
          ALOC=0.0
        ENDIF
      ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
        SCALE=XSD*SQRT(6.0)/PI
        ALOC=XMEAN - 0.57722*SCALE
      ELSE
      ENDIF
C
C  DEPENDING ON WHAT DEFINITION OF GENERALIZED PARETO PREFERRED,
C  REVERSE SIGN OF GAMMA.
C
      IF(IGEPDF.EQ.'SIMI')THEN
        GAMMSV=GAMMA
        ISIGN1='NEGATIVE'
        ISIGN2='POSITIVE'
      ELSE
        GAMMSV=-GAMMA
        ISIGN1='POSITIVE'
        ISIGN2='NEGATIVE'
      ENDIF
C
C               *********************************
C               **   STEP 42--                 **
C               **   WRITE OUT EVERYTHING      **
C               **   FOR DEHAAN      ESTIMATE  **
C               *********************************
C
      ISTEPN='42'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DEGP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPRINT.EQ.'ON')THEN
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
C  STEP 1: END ASIS MODE AND WRITE A HEADER
C
 5001   FORMAT('</PRE>')
 5002   FORMAT('<CENTER>')
 5003   FORMAT('<B>DeHaan Parameter Estimation for the ',
     1         'Generalized Pareto Distribution</B>')
 5004   FORMAT('</CENTER>')
 5005   FORMAT('<BR><BR>')
        WRITE(ICOUT,5001)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5002)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5003)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5004)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5005)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 2: START TABLE AND DEFINE A CAPTION
C
 5011   FORMAT('<UL>')
 5013   FORMAT('<TABLE NOBORDER>')
        WRITE(ICOUT,5011)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5013)
        CALL DPWRST('XXX','WRIT')
C
C  STEP 4: DEFINE DATA ROW
C
 5041   FORMAT('   <TR>')
 5043   FORMAT('      <TD ALIGN=LEFT VALIGN=BOTTOM WIDTH=350>')
 5045   FORMAT('         Number of Observations:')
 5061   FORMAT('         Threshold:')
 5062   FORMAT('         Number of Observations Above the Threshold:')
 5063   FORMAT('         Estimate of Shape Parameter Gamma:')
 5064   FORMAT('         Standard Deviation of Gamma:')
 5065   FORMAT('         Estimate of Scale Parameter A:')
 5066   FORMAT('         For ',A8,' gamma, the generalized Pareto ',
     1         'distribution is')
 5067   FORMAT('         equivalent to a reverse Weibull (SET ',
     1         'MINMAX MAX) with:')
 5068   FORMAT('         Estimate of Location Parameter:')
 5069   FORMAT('         Estimate of Scale Parameter:')
 5070   FORMAT('         For gamma = zero, the generalized Pareto ',
     1         'distribution is')
 5071   FORMAT('         equivalent to a Gumbel distribution with:')
 5047   FORMAT('      </TD>')
 5049   FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=150>')
 5051   FORMAT('         ',G15.7)
 5053   FORMAT('         ',I8)
 5055   FORMAT('         &nbsp;')
 5059   FORMAT('   </TR>')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5045)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5053)N
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5061)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)THRESH
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5062)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5053)NUSE
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5055)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5055)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5063)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)GAMMSV
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5064)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)SDG
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5065)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5051)A
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,5041)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5043)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5055)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5049)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5055)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5047)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5059)
        CALL DPWRST('XXX','WRIT')
C
        IF(GAMMA.LT.-PPOTTO)THEN
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5066)ISIGN1
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5067)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5055)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5063)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5051)GAMMA2
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5068)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5051)ALOC
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5069)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5051)SCALE
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
        ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5070)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5071)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5055)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5068)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5051)ALOC
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
          WRITE(ICOUT,5041)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5043)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5069)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5049)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5051)SCALE
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5047)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,5059)
          CALL DPWRST('XXX','WRIT')
C
        ELSE
        ENDIF
C
C  STEP 4: END THE TABLE AND RESET ASIS MODE
C
 5091   FORMAT('</TABLE>')
 5093   FORMAT('</UL>')
 5099   FORMAT('<PRE>')
        WRITE(ICOUT,5091)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5093)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5099)
        CALL DPWRST('XXX','WRIT')
C
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
      ELSEIF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF')THEN
      ELSE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4211)
 4211   FORMAT(10X,'DEHAAN ESTIMATION FOR THE GENERALIZED PARETO ',
     1         'DISTRIBUTION')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4242)N
 4242   FORMAT('NUMBER OF OBSERVATIONS                     = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4250)THRESH
 4250   FORMAT('THRESHOLD                                  = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4252)NUSE
 4252   FORMAT('NUMBER OF OBSERVATIONS ABOVE THE THRESHOLD = ',I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4343)GAMMSV
 4343   FORMAT('ESTIMATE OF SHAPE PARAMETER GAMMA          = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4354)SDG
 4354   FORMAT('STANDARD DEVIATION OF GAMMA                = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4243)A
 4243   FORMAT('SCALE PARAMETER A                          = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
C
        IF(GAMMA.LT.-PPOTTO)THEN
          WRITE(ICOUT,4500)ISIGN1
 4500     FORMAT('FOR ',A8,' GAMMA, THE GENERALIZED PARETO IS ',
     1           'EQUIVALENT TO ')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4501)
 4501     FORMAT('A REVERSE WEIBULL (SET MINMAX MAX) WITH:')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4502)GAMMA2
 4502     FORMAT('SHAPE PARAMETER GAMMA                    = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4504)ALOC
 4504     FORMAT('LOCATION PARAMETER                       = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4506)SCALE
 4506     FORMAT('SCALE PARAMETER                          = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
        ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
          WRITE(ICOUT,4600)
 4600     FORMAT('FOR GAMMA = ZERO, THE GENERALIZED PARETO IS ',
     1           'EQUIVALENT TO ')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4602)
 4602     FORMAT('AN EXTREME VALUE TYPE I (GUMBEL) WITH:')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4604)ALOC
 4604     FORMAT('LOCATION PARAMETER                       = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4606)SCALE
 4606     FORMAT('SCALE PARAMETER                          = ',G15.7)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
        ELSE
          WRITE(ICOUT,4700)ISIGN2
 4700     FORMAT('FOR ',A8,' GAMMA, THE GENERALIZED PARETO IS ',
     1           'EQUIVALENT TO ')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4702)
 4702     FORMAT('A (MAXIMUM) EXTREME VALUE TYPE II (FRECHET)')
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
      ENDIF
      ENDIF
C
      IF(IFEEDB.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,4941)
 4941   FORMAT('GAMMA, SDGAMMA, AND A WILL BE SAVED AS INTERNAL ',
     1         'PARAMETERS.')
        CALL DPWRST('XXX','BUG ')
        IF(GAMMA.LT.-PPOTTO)THEN
          WRITE(ICOUT,4951)
 4951     FORMAT('THE REVERSE WEIBULL PARAMETERS WILL BE SAVED AS')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,4953)
 4953     FORMAT('THE INTERNAL PARAMETERS GAMMA2, LOC, AND SCALE, ',
     1           ' RESPECTIVELY.')
          CALL DPWRST('XXX','WRIT')
        ELSEIF(ABS(GAMMA).LE.PPOTTO)THEN
          WRITE(ICOUT,4961)
 4961     FORMAT('THE GUMBEL PARAMETERS WILL BE SAVED AS THE ',
     1           'INTERNAL PARAMETERS LOC AND SCALE, RESPECTIVELY.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DEGP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','WRIT')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEGP--')
      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')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEHA(IHARG,NUMARG,IDEFHA,
     1IDEXHA,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE DESIGN OF EXPERIMENT HORIZONTAL AXIS
C              (FACTORS OR TERMS)
C              (DEFAULT = FACTORS)
C                     --IHARG  (A  HOLLERITH VECTOR)
C     INPUT  ARGUMENTS--IHARG (A HOLLARITH VECTOR)
C                     --NUMARG
C                     --IDEFHA
C     OUTPUT ARGUMENTS--IDEXHA (A HOLLERITH VARIABLE
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/5
C     ORIGINAL VERSION--MAY       1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IDEFHA
      CHARACTER*4 IDEXHA
      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.1)GOTO1900
C
 1100 CONTINUE
      IF(NUMARG.EQ.2)GOTO1150
      IF(IHARG(3).EQ.'ON')GOTO1150
      IF(IHARG(3).EQ.'OFF')GOTO1150
      IF(IHARG(3).EQ.'AUTO')GOTO1150
      IF(IHARG(3).EQ.'DEFA')GOTO1150
      GOTO1160
C
 1150 CONTINUE
      IHOLD=IDEFHA
      GOTO1180
C
 1160 CONTINUE
      IHOLD=IHARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDEXHA=IHOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE DESIGN OF EXPERIMENT HORIZONTAL AXIS')
      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
 1900 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEHL(X,Y,Z,D,X2,Y2,NPLOTP,
     1XEYE,YEYE,ZEYE,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--GIVEN THE VECTORS OF THE ALREADY-TRANSFORMED
C              3D-TO-2D DATA, DETERMINE WHERE THE
C              HIDDEN LINES ARE AND REMOVE THEM--
C              FORM UPDATED VECTORS CONTAINING ONLY THE
C              VISIBLE LINES.
C     METHOD USED = FLOATING HORIZON
C     REFERENCE--ROGERS, DAVID F. (1985).  PROCEDURAL
C                ELEMENTS FOR COMPUTER GRAPHICS.
C                MCGRAW-HILL, NEW YORK, PAGE 197-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
      CHARACTER*4 IWRITE
C
      CHARACTER*4 IVIS
C
CCCCC CHARACTER*4 ICASEF
C
      CHARACTER*4 ICNEAR
      CHARACTER*4 IXCASE
      CHARACTER*4 IYCASE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Z(*)
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D(*)
C
      DIMENSION XOUT(*)
      DIMENSION YOUT(*)
      DIMENSION TAGOUT(*)
C
      DIMENSION AUPPER(1000)
      DIMENSION ALOWER(1000)
      DIMENSION XHORIZ(1000)
C
      DIMENSION XD(1000)
      DIMENSION YD(1000)
C
      DIMENSION XS(1000)
      DIMENSION YS(1000)
      DIMENSION IVIS(1000)
C
      DIMENSION XTEMP(1000)
      DIMENSION YTEMP(1000)
      DIMENSION DTEMP(1000)
CCCCC FOLLOWING LINES ADDED MAY 1995
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR31),AUPPER(1))
      EQUIVALENCE (G2RBAG(IGAR32),ALOWER(1))
      EQUIVALENCE (G2RBAG(IGAR33),XHORIZ(1))
      EQUIVALENCE (G2RBAG(IGAR34),XD(1))
      EQUIVALENCE (G2RBAG(IGAR35),YD(1))
      EQUIVALENCE (G2RBAG(IGAR36),XS(1))
      EQUIVALENCE (G2RBAG(IGAR37),YS(1))
      EQUIVALENCE (G2RBAG(IGAR38),XTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR39),YTEMP(1))
      EQUIVALENCE (G2RBAG(IGAR40),DTEMP(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='DPDE'
      ISUBN2='HL  '
C
      NHORP=300
CCCCC NHORP=1000
C
      IPASS=0
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEHL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IPASS
   52 FORMAT('IPASS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGU2,ISUBRO,IERROR
   53 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NPLOTP
   54 FORMAT('NPLOTP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NPLOTP
      WRITE(ICOUT,56)I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I)
   56 FORMAT('I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I) = ',I8,6E13.4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,61)XEYE,YEYE,ZEYE
   61 FORMAT('XEYE,YEYE,ZEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)NOUT,NTRACE
   71 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IF(NOUT.LE.0)GOTO79
      DO72I=1,NOUT
      WRITE(ICOUT,73)I,XOUT(I),YOUT(I),TAGOUT(I)
   73 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   79 CONTINUE
   90 CONTINUE
C
C           ******************************************
C           **  STEP 11--                           **
C           **  DETERMINE WHICH OF THE 4 CORNERS--  **
C           **     1. (XMIN,YMIN)                   **
C           **     2. (XMAX,YMIN)                   **
C           **     3. (XMIN,YMAX)                   **
C           **     4. (XMAX,YMAX)                   **
C           **  IS CLOSEST TO THE EYE POINT.        **
C           ******************************************
C
      NX=NPLOTP
      NY=NPLOTP
      ND=NPLOTP
C
      CALL DISTIN(X,NX,IWRITE,XD,NXD,IBUGU2,IERROR)
      CALL DISTIN(Y,NY,IWRITE,YD,NYD,IBUGU2,IERROR)
C
      XMIN=XD(1)
      XMAX=XD(1)
      DO1110I=1,NXD
      IF(XD(I).LT.XMIN)XMIN=XD(I)
      IF(XD(I).GT.XMAX)XMAX=XD(I)
 1110 CONTINUE
C
      YMIN=YD(1)
      YMAX=YD(1)
      DO1120I=1,NYD
      IF(YD(I).LT.YMIN)YMIN=YD(I)
      IF(YD(I).GT.YMAX)YMAX=YD(I)
 1120 CONTINUE
C
      XMIN2=(XMIN-XEYE)/(XMAX-XMIN)
      YMIN2=(YMIN-YEYE)/(YMAX-YMIN)
      XMAX2=(XMAX-XEYE)/(XMAX-XMIN)
      YMAX2=(YMAX-YEYE)/(YMAX-YMIN)
      ALEN1=XMIN2**2+YMIN2**2
      ALEN2=XMAX2**2+YMIN2**2
      ALEN3=XMIN2**2+YMAX2**2
      ALEN4=XMAX2**2+YMAX2**2
C
      IF(ALEN1.LE.ALEN2.AND.ALEN1.LE.ALEN3.AND.
     1ALEN1.LE.ALEN4)GOTO1210
      IF(ALEN2.LE.ALEN1.AND.ALEN2.LE.ALEN3.AND.
     1ALEN2.LE.ALEN4)GOTO1220
      IF(ALEN3.LE.ALEN1.AND.ALEN3.LE.ALEN2.AND.
     1ALEN3.LE.ALEN4)GOTO1230
      GOTO1240
C
 1210 CONTINUE
      ICNEAR='X1Y1'
      IXCASE='SL'
      IYCASE='SL'
      GOTO1290
 1220 CONTINUE
      ICNEAR='X2Y1'
      IXCASE='LS'
      IYCASE='SL'
      GOTO1290
 1230 CONTINUE
      ICNEAR='X1Y2'
      IXCASE='SL'
      IYCASE='LS'
      GOTO1290
 1240 CONTINUE
      ICNEAR='X2Y2'
      IXCASE='LS'
      IYCASE='LS'
      GOTO1290
 1290 CONTINUE
C
C               **************************************************
C               **  STEP 12--                                   **
C               **  DETERMINE THE ORDER IN WHICH THE X VALUES   **
C               **  WILL BE PROCESSED.                          **
C               **  DETERMINE THE ORDER IN WHICH THE Y VALUES   **
C               **  WILL BE PROCESSED.                          **
C               **************************************************
C
      IF(IXCASE.EQ.'LS')CALL SORTDE(XD,NXD,XD)
      IF(IYCASE.EQ.'LS')CALL SORTDE(YD,NYD,YD)
C
C               **************************************************
C               **  STEP 13--                                   **
C               **  EXTRACT ALL DISTINCT SCREEN                 **
C               **  HORIZONTAL VALUES.                          **
C               **  SORT THEM LEFT TO RIGHT                     **
C               **  (SMALLEST TO LARGEST).
C               **************************************************
C
      X2MIN=X2(1)
      X2MAX=X2(1)
      DO1300I=1,NPLOTP
      IF(X2(I).LT.X2MIN)X2MIN=X2(I)
      IF(X2(I).GT.X2MAX)X2MAX=X2(I)
 1300 CONTINUE
C
C               **************************************************
C               **  STEP 21--                                   **
C               **  FORM THE VISIBLE TRACES FOR THE Y SLICES--  **
C               **     1. LOOP THROUGH EACH Y TRACE;            **
C               **     2. EXTRACT THE SCREEN HORIZONTAL AND     **
C               **        VERTICAL VALUES FOR A GIVEN SLICE;    **
C               **     3. FORM THE OUTPUT VISIBLE TRACE FOR     **
C               **        A GIVEN SLICE.                        **
C               **************************************************
C
      ILOOP=0
      DO2100IYD=1,NYD
      YTARG=YD(IYD)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
     1WRITE(ICOUT,2101)IYD,NYD,YTARG
 2101 FORMAT('SEARCH FOR Y SLICE--IYD,NYD,YTARG = ',2I8,E15.7)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
     1CALL DPWRST('XXX','BUG ')
C
      ICOUNT=0
      DO2110I=1,NPLOTP
      IF(Y(I).EQ.YTARG)GOTO2120
      GOTO2110
 2120 CONTINUE
      ICOUNT=ICOUNT+1
      XTEMP(ICOUNT)=X2(I)
      YTEMP(ICOUNT)=Y2(I)
      DTEMP(ICOUNT)=D(I)
 2110 CONTINUE
      NTEMP=ICOUNT
C
      DTARG=CPUMIN
      CALL DPEXSS(XTEMP,YTEMP,DTEMP,NTEMP,DTARG,
     1XS,YS,NS,DHIT,
     1IBUGU2,ISUBRO,IERROR)
C
      IF(NS.LE.1)GOTO2100
      ILOOP=ILOOP+1
C
      IF(IBUGU2.NE.'ON'.AND.ISUBRO.NE.'DEHL')GOTO2139
      WRITE(ICOUT,2131)NS,ILOOP
 2131 FORMAT('Y SLICE--NS,ILOOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO2132I=1,NS
      WRITE(ICOUT,2133)I,XS(I),YS(I)
 2133 FORMAT('Y SLICE--I,XS(I),YS(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 2132 CONTINUE
 2139 CONTINUE
C
      CALL DPDEH2(XS,YS,IVIS,NS,ILOOP,
     1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
C
 2100 CONTINUE
C
C               **************************************************
C               **  STEP 22--                                   **
C               **  FORM THE VISIBLE TRACES FOR THE X SLICES--  **
C               **     1. LOOP THROUGH EACH X TRACE;            **
C               **     2. EXTRACT THE SCREEN HORIZONTAL AND     **
C               **        VERTICAL VALUES FOR A GIVEN SLICE;    **
C               **     3. FORM THE OUTPUT VISIBLE TRACE FOR     **
C               **        A GIVEN SLICE.                        **
C               **************************************************
C
      ILOOP=0
      DO2200IXD=1,NXD
      XTARG=XD(IXD)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
     1WRITE(ICOUT,2201)IXD,NXD,XTARG
 2201 FORMAT('SEARCH FOR X SLICE--IXD,NXD,XTARG = ',2I8,E15.7)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')
     1CALL DPWRST('XXX','BUG ')
C
      ICOUNT=0
      DO2210I=1,NPLOTP
      IF(X(I).EQ.XTARG)GOTO2220
      GOTO2210
 2220 CONTINUE
      ICOUNT=ICOUNT+1
      XTEMP(ICOUNT)=X2(I)
      YTEMP(ICOUNT)=Y2(I)
      DTEMP(ICOUNT)=D(I)
 2210 CONTINUE
      NTEMP=ICOUNT
C
      DTARG=CPUMIN
      CALL DPEXSS(XTEMP,YTEMP,DTEMP,NTEMP,DTARG,
     1XS,YS,NS,DHIT,
     1IBUGU2,ISUBRO,IERROR)
C
      IF(NS.LE.1)GOTO2200
      ILOOP=ILOOP+1
C
      IF(IBUGU2.NE.'ON'.AND.ISUBRO.NE.'DEHL')GOTO2239
      WRITE(ICOUT,2231)NS,ILOOP
 2231 FORMAT('X SLICE--NS,ILOOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO2232I=1,NS
      WRITE(ICOUT,2233)I,XS(I),YS(I)
 2233 FORMAT('X SLICE--I,XS(I),YS(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 2232 CONTINUE
 2239 CONTINUE
C
      CALL DPDEH2(XS,YS,IVIS,NS,ILOOP,
     1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
C
 2200 CONTINUE
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
 9000 CONTINUE
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEHL')GOTO9010
      GOTO9090
 9010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEHL--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IPASS
 9012 FORMAT('IPASS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGU2,ISUBRO,IERROR
 9013 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NPLOTP
 9014 FORMAT('NPLOTP = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=1,NPLOTP
      WRITE(ICOUT,9016)I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I)
 9016 FORMAT('I,X(I),Y(I),Z(I),D(I),X2(I),Y2(I) = ',I8,6E12.4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9021)XEYE,YEYE,ZEYE
 9021 FORMAT('XEYE,YEYE,ZEYE = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)XMIN,XMAX,YMIN,YMAX
 9022 FORMAT('XMIN,XMAX,YMIN,YMAX = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)NOUT,NTRACE
 9031 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IF(NOUT.LE.0)GOTO9039
      DO9032I=1,NOUT
      WRITE(ICOUT,9033)I,XOUT(I),YOUT(I),TAGOUT(I)
 9033 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9032 CONTINUE
 9039 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEH2(XS,YS,IVIS,NS,ILOOP,
     1XHORIZ,AUPPER,ALOWER,NHORP,X2MIN,X2MAX,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--GIVEN THE SCREEN COORDINATES OF A TRACE,
C              AND THE CURRENT HORIZON TABLE,
C              DETERMINE WHAT PART OF THE INPUT TRACE
C              IS VISIBLE, AND
C              FORM THE APPROPRIATE VISIBLE OUTPUT TRACE.
C     METHOD USED = FLOATING HORIZON
C     REFERENCE--ROGERS, DAVID F. (1985).  PROCEDURAL
C                ELEMENTS FOR COMPUTER GRAPHICS.
C                MCGRAW-HILL, NEW YORK, PAGE 197-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/10
C     ORIGINAL VERSION--SEPTEMBER 1988.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IVIS
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASEF
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION XS(1000)
      DIMENSION YS(1000)
      DIMENSION IVIS(1000)
C
      DIMENSION XHORIZ(1000)
      DIMENSION AUPPER(1000)
      DIMENSION ALOWER(1000)
C
      DIMENSION XOUT(*)
      DIMENSION YOUT(*)
      DIMENSION TAGOUT(*)
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
C
      ISUBN1='DPDE'
      ISUBN2='H2  '
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
   52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)NS,ILOOP
   55 FORMAT('NS,ILOOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO56I=1,NS
      WRITE(ICOUT,57)I,XS(I),YS(I),IVIS(I)
   57 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   56 CONTINUE
      WRITE(ICOUT,61)NHORP,X2MIN,X2MAX
   61 FORMAT('NHORP,X2MIN,X2MAX = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO62I=1,NHORP
      WRITE(ICOUT,63)I,XHORIZ(I),AUPPER(I),ALOWER(I)
   63 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
      WRITE(ICOUT,71)NOUT,NTRACE
   71 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO72I=1,NOUT
      WRITE(ICOUT,73)I,XOUT(I),YOUT(I),TAGOUT(I)
   73 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   72 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  STEP 21--                                   **
C               **  SORT THE INPUT TRACE                        **
C               **  BY THE HORIZONTAL AXIS SCREEN VALUES, AND   **
C               **  CARRY ALONG THE VERTICAL AXIS SCREEN VALUES.**
C               **************************************************
C
      CALL SORTC(XS,YS,NS,XS,YS)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO2180
      GOTO2189
 2180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2181)
 2181 FORMAT('***** FROM THE MIDDLE OF DPDEH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2182)ILOOP
 2182 FORMAT('      AFTER THE SORT OF NEW SLICE # ',I8)
      CALL DPWRST('XXX','BUG ')
      DO2185I=1,NS
      WRITE(ICOUT,2186)I,XS(I),YS(I)
 2186 FORMAT('I,XS(I),YS(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 2185 CONTINUE
 2189 CONTINUE
C
C               **************************************************
C               **  STEP 22--                                   **
C               **  BRANCH DEPENDING ON WHETHER THIS IS SLICE 1 **
C               **  (THE NEAREST SLICE), OR                     **
C               **  WHETHER IT IS A MORE DISTANT SLICE.         **
C               **************************************************
C
      IF(ILOOP.EQ.1)GOTO3000
      GOTO4000
C
C               **************************************************
C               **  STEP 30--                                   **
C     ----------**  TREAT THE FIRST (= NEAR) SLICE SUBCASE.     **----------
C               **************************************************
C
 3000 CONTINUE
      ISTEPN='30'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               **************************************************
C               **  STEP 31--                                   **
C               **  FOR THE FIRST (= NEAR) SLICE SUBCASE        **
C               **  INITIALIZE THE HORIZON ARRAYS.              **
C               **************************************************
C
      DO3110I=1,NHORP
      AUPPER(I)=CPUMIN
      ALOWER(I)=CPUMAX
 3110 CONTINUE
C
      ANHORP=NHORP
      DO3120I=1,NHORP
      AI=I
      P=(AI-1.0)/(ANHORP-1.0)
      XHORIZ(I)=X2MIN+P*(X2MAX-X2MIN)
 3120 CONTINUE
C
C               **************************************************
C               **  STEP 32--                                   **
C               **  FOR THE FIRST (= NEAR) SLICE SUBCASE        **
C               **  FORM THE OUTPUT DRAW VECTOR.                **
C               **************************************************
C
      NTRACE=NTRACE+1
      DO3200I=1,NS
      NOUT=NOUT+1
      XOUT(NOUT)=XS(I)
      YOUT(NOUT)=YS(I)
      TAGOUT(NOUT)=NTRACE
 3200 CONTINUE
C
C               **************************************************
C               **  STEP 33--                                   **
C               **  FOR THE FIRST (= NEAR) SLICE SUBCASE,       **
C               **  FILL THE UPPER HORIZON TABLES DIRECTLY      **
C               **************************************************
C
      DO3300I=1,NS
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
      IF(YS(I).GT.AUPPER(I2))AUPPER(I2)=YS(I)
CCCCC IF(YS(I).LT.ALOWER(I2))ALOWER(I2)=YS(I)
 3300 CONTINUE
C
C               **************************************************
C               **  STEP 34--                                   **
C               **  FOR THE FIRST (= NEAR) SLICE SUBCASE,       **
C               **  FILL THE LOWER HORIZON TABLES WITH THE      **
C               **  GLOBAL MIN FOR THIS FIRST SLICE.            **
C               **  "PAINTED WALL"                              **
C               **************************************************
C
      Y3MIN=YS(1)
      DO3410I=1,NS
      IF(YS(I).LT.Y3MIN)Y3MIN=YS(I)
 3410 CONTINUE
CCCCC DO3420I=1,NS
      DO3420I=1,NHORP
CCCCC CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
      I2=I
      IF(Y3MIN.LT.ALOWER(I2))ALOWER(I2)=Y3MIN
 3420 CONTINUE
C
C               **************************************************
C               **  STEP 35--                                   **
C               **  FOR THE FIRST (= NEAR) SLICE SUBCASE,       **
C               **  FILL IN (INTERPOLATE) THE HORIZON TABLES    **
C               **  (IF NEEDED).                                **
C               **************************************************
C
      I=1
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,IPREV,IBUGU2,ISUBRO,IERROR)
      DO3500I=2,NS
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICUR,IBUGU2,ISUBRO,IERROR)
      IDEL=ICUR-IPREV
      ICASEF='BOTH'
      IF(IDEL.GE.2)
     1CALL FILLHT(IPREV,ICUR,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      IPREV=ICUR
 3500 CONTINUE
C
      GOTO9000
C
C               ******************************************************
C               **  STEP 40--                                       **
C     ----------**  TREAT THE OTHER (= FARTHER AWAY) SLICE SUBCASE  **----------
C               ******************************************************
C
 4000 CONTINUE
      ISTEPN='40'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************************************************
C               **  STEP 41--                                      **
C               **  FOR THE OTHER (= FARTHER AWAY) SLICE SUBCASE,  **
C               **  DETERMINE VISIBILITY.                          **
C               *****************************************************
C
      DO4100I=1,NS
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,I2,IBUGU2,ISUBRO,IERROR)
      IVIS(I)='YES'
      IF(YS(I).LT.AUPPER(I2).AND.YS(I).GT.ALOWER(I2))IVIS(I)='NO'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1WRITE(ICOUT,4111)I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2)
 4111 FORMAT('I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2) = ',
     1I8,E15.7,2X,A4,I8,2E15.7)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1CALL DPWRST('XXX','BUG ')
 4100 CONTINUE
C
C               *****************************************************
C               **  STEP 42--                                      **
C               **  FOR THE OTHER (= FARTHER AWAY) SLICE SUBCASE,  **
C               **  FORM THE OUTPUT DRAW VECTOR,                   **
C               **  FILL THE HORIZON TABLES,                       **
C               **  FILL IN THE HORIZON TABLES (IF NEEDED)         **
C               *****************************************************
C
      DO4200I=1,NS
C
      IF(I.EQ.1)GOTO4210
      GOTO4220
C
 4210 CONTINUE
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICHORI,IBUGU2,ISUBRO,IERROR)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1WRITE(ICOUT,777)I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2)
  777 FORMAT('I,YS(I),IVIS(I),I2,ALOWER(I2),AUPPER(I2) = ',
     1I8,E15.7,2X,A4,I8,2E15.7)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')
     1CALL DPWRST('XXX','BUG ')
      IF(IVIS(I).EQ.'YES')GOTO4211
      GOTO4219
 4211 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XS(I)
      YOUT(NOUT)=YS(I)
      TAGOUT(NOUT)=NTRACE
 4219 CONTINUE
      IPHORI=ICHORI
      GOTO4200
C
 4220 CONTINUE
      IP=I-1
      IC=I
      CALL HORIND(XS(I),X2MIN,X2MAX,1,NHORP,ICHORI,IBUGU2,ISUBRO,IERROR)
      IPASS=IPASS+1
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')WRITE(ICOUT,4221)
CCCCC1IPASS,ILOOP,I,IP,YTARG,XS(IP)
     1IPASS,ILOOP,I,IP,XS(IP)
 4221 FORMAT('FROM DPDEH2, BEFORE CALL TO DPDETR--',
CCCCC1'IPASS,ILOOP,I,IP,YTARG,XS(IP) = ',4I8,2E15.7)
     1'IPASS,ILOOP,I,IP,XS(IP) = ',4I8,2E15.7)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')CALL DPWRST('XXX','BUG ')
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')WRITE(ICOUT,4222)
     1I,IP,IC,IVIS(IP),IVIS(IC)
 4222 FORMAT('I,IP,IC,IVIS(IP),IVIS(IC) = ',3I8,2X,A4,2X,A4)
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')CALL DPWRST('XXX','BUG ')
      CALL DPDETR(IP,IC,XS,YS,IVIS,NS,
     1IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,
     1X2MIN,X2MAX,IPASS,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
      IPHORI=ICHORI
C
 4200 CONTINUE
C
      GOTO9000
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
 9000 CONTINUE
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DEH2')GOTO9010
      GOTO9090
 9010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
 9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NS,ILOOP
 9015 FORMAT('NS,ILOOP = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9016I=1,NS
      WRITE(ICOUT,9017)I,XS(I),YS(I),IVIS(I)
 9017 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9016 CONTINUE
      WRITE(ICOUT,9021)NHORP,X2MIN,X2MAX
 9021 FORMAT('NHORP,X2MIN,X2MAX = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO9022I=1,NHORP
      WRITE(ICOUT,9023)I,XHORIZ(I),AUPPER(I),ALOWER(I)
 9023 FORMAT('I,XHORIZ(I),AUPPER(I),ALOWER(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
      WRITE(ICOUT,9024)IPHORI,ICHORI
 9024 FORMAT('IPHORI,ICHORI = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)NOUT,NTRACE
 9031 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9032I=1,NOUT
      WRITE(ICOUT,9033)I,XOUT(I),YOUT(I),TAGOUT(I)
 9033 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9032 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDELE(IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC SUBROUTINE DPDELE(IBUGS2,IBUGQ,IFOUND,IERROR)
CCCCC THE THIRD ARGUMENT (ISUBRO) ABOVE WAS ADDED   SEPTEMBER 1995
C
C     PURPOSE--TREAT THE DELETE CASE--
C              DELETE SPECIFIED ELEMENTS OF A VARIABLE
C              AND PACK THE REMAINING ELEMENTS
C              INTO THE FIRST AVAILABLE LOCATIONS;
C              REDEFINE THE LENGTH OF THE PACKED VARIABLE.
C     INPUT --NECESSARILY A VARIABLE.
C     OUTPUT--NECESSARILY A VARIABLE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--MARCH     1978.
C     UPDATED         --MAY       1978.
C     UPDATED         --JUNE      1978.
C     UPDATED         --JULY      1978.
C     UPDATED         --NOVEMBER  1978.
C     UPDATED         --NOVEMBER  1980.
C     UPDATED         --JANUARY   1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   1993. ADD DELETE MATRIX.
C     UPDATED         --FEBRUARY  1994. EQUIVALENCE TO GARBAGE COMMON
C     UPDATED         --DECEMBER  1994. SUPP. ERROR MESS. IF NOT EXIST
C     UPDATED         --SEPTEMBER 1995. ALLOW   DELETE Y7 TO Y15
C     UPDATED         --OCTOBER   1997. REINITIALIZE DELETED VALUES TO
C                                       0 INSTEAD OF CPUMIN.
C     UPDATED         --JANUARY   2000. SUPPORT FOR VARIABLE LABELS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGS2
      CHARACTER*4 IBUGQ
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEBMER 1995
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASEQ
      CHARACTER*4 ISTRIN
      CHARACTER*4 ISTRI2
      CHARACTER*4 INEX
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
      CHARACTER*4 IFOUCO
      CHARACTER*4 IFOULP
      CHARACTER*4 IFOURP
      CHARACTER*4 IFOURN
      CHARACTER*4 IFOUVN
      CHARACTER*4 IHVARJ
      CHARACTER*4 IHVRJ2
      CHARACTER*4 IVN
      CHARACTER*4 IVN2
      CHARACTER*4 IHSET
      CHARACTER*4 IHSET2
      CHARACTER*4 IERRO1
      CHARACTER*4 ITYPCO
      CHARACTER*4 IHOLCO
      CHARACTER*4 IHLCO2
      CHARACTER*4 ITYPLP
      CHARACTER*4 IHOLLP
      CHARACTER*4 IHLLP2
      CHARACTER*4 ITYPRP
      CHARACTER*4 IHOLRP
      CHARACTER*4 IHLRP2
      CHARACTER*4 ITYPRN
      CHARACTER*4 IHOLRN
      CHARACTER*4 IHLRN2
      CHARACTER*4 ITYPVN
      CHARACTER*4 IHOLVN
      CHARACTER*4 IHLVN2
C
CCCCC THE FOLLOWING 16 LINES WERE ADDED   SEPTEMBER 1995
      CHARACTER*4 IH1
      CHARACTER*4 IH2
      CHARACTER*4 ICASTO
      CHARACTER*4 IECASE
C
      CHARACTER*4 JVNAM1
      CHARACTER*4 JPNAM1
      CHARACTER*4 JMNAM1
      CHARACTER*4 JFNAM1
      CHARACTER*4 JUNAM1
      CHARACTER*4 JENAM1
C
      CHARACTER*4 JVNAM2
      CHARACTER*4 JPNAM2
      CHARACTER*4 JMNAM2
      CHARACTER*4 JFNAM2
      CHARACTER*4 JUNAM2
      CHARACTER*4 JENAM2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
CCCCC APRIL 1996.  ADD FOLLOWING LINE
      CHARACTER*4 ICASEA
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION ILISTV(100)
      DIMENSION TEMP(MAXOBV)
C
      DIMENSION IVN(100)
      DIMENSION IVN2(100)
      DIMENSION IRN(100)
CCCCC FOLLOWING LINES ADDED FEBRUARY, 1994
CCCCC INCLUDE 'DPCOZ2.INC'
CCCCC EQUIVALENCE (G2RBAG(IGAR11),TEMP(1))
CCCCC END CHANGE
C
CCCCC THE FOLLOWING 13 LINES WERE ADDED   SEPTEMBER 1995
      DIMENSION JVNAM1(100)
      DIMENSION JPNAM1(100)
      DIMENSION JMNAM1(100)
      DIMENSION JFNAM1(100)
      DIMENSION JUNAM1(100)
      DIMENSION JENAM1(100)
C
      DIMENSION JVNAM2(100)
      DIMENSION JPNAM2(100)
      DIMENSION JMNAM2(100)
      DIMENSION JFNAM2(100)
      DIMENSION JUNAM2(100)
      DIMENSION JENAM2(100)
C
      DIMENSION NIV(100)
C
CCCCC DIMENSION IEN(100)
      DIMENSION IECOL2(100)
      DIMENSION IECASE(100)
      DIMENSION PVAL(100)
      DIMENSION IFSTA2(100)
      DIMENSION IFSTO2(100)
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='DPDE'
      ISUBN2='LE  '
C
      IPASS=0
      NUMDEL=0
      ISAVE=0
      IROD1O=0
      IRODNO=0
      IROW1O=0
      IROWNO=0
      ILQP1=0
C
      TEMPD=0.0
      VALD1O=0.0
      VALDNO=0.0
      VAL1O=0.0
      VALNO=0.0
CCCCC FEBRUARY 1993.  ADD FOLLOWING INITIALIZATION
      DO30I=1,100
      ILISTV(I)=0
 30   CONTINUE
C
C               *************************************************
C               **  TREAT THE DELETE CASE                      **
C               **  DELETE SPECIFIC ELEMENTS OF A VECTOR       **
C               **  AND PACK REMAINING ELEMENTS                **
C               **  INTO THE FIRST AVAILABLE LOCATIONS.        **
C               *************************************************
C
      IFOUND='YES'
      IERROR='NO'
C
      MAXDEL=100
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED   SEPTEMBER 1995
      MAXV2=100
      MAXP2=100
      MAXM2=100
      MAXF2=100
      MAXU2=100
      MAXE2=100
C
      IF(IBUGS2.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGS2,IERROR
   52 FORMAT('IBUGS2,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)MAXNAM,NUMNAM
   53 FORMAT('MAXNAM,NUMNAM = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)MAXN,MAXCOL,NUMCOL
   54 FORMAT('MAXN,MAXCOL,NUMCOL = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO60I=1,NUMNAM
      WRITE(ICOUT,61)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
   61 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
     1I8,2X,A4,A4,2X,A4,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)
   62 FORMAT('I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)  = ',
     1I8,2X,A4,A4,6X,I8,I8,I8)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO70J=1,NUMCOL
      IJ=MAXN*(J-1)+1
      WRITE(ICOUT,71)J,MAXN,IJ,V(IJ)
   71 FORMAT('J,MAXN,IJ,V(IJ) = ',I8,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
   90 CONTINUE
C               *******************************************************
C               **  STEP 1--                                         **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='1'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.GE.1)GOTO190
      IERROR='YES'
      GOTO8900
  190 CONTINUE
      IFOUND='YES'
C
C               ***********************************************************
C               **  STEP 2--                                             **
C               **  DETERMINE THE SUBCASE BASED ON THE QUALIFIER.        **
C               **  SCAN TO CHECK IF 'SUBSET' OR 'FOR' IS PRESENT.       **
C               **  IF NOT PRESENT, THEN HAVE CASE 1--                   **
C               **  EXAMPLE--DELETE X(4) Y(1) Z(46)                      **
C               **  IF PRESENT, THEN HAVE CASE 2--                       **
C               **  EXAMPLE--DELETE X Y Z FOR I = 1 1 10                 **
C               **  DETERMINE THE LOCATION IN THE ARGUMENT LIST          **
C               **  OF 'SUBSET' OR 'FOR'.                                **
C               **  BRANCH TO THE APPROPRIATE SUBCASE                    **
C               **  FULL VERSUS SUBSET/FOR.                              **
C               ***********************************************************
C
      ISTEPN='2'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ILOCQ=1
      ICASEQ='UNKN'
      IF(NUMARG.LE.0)GOTO290
      DO210J=1,NUMARG
      J2=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO220
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO220
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO230
  210 CONTINUE
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
CCCCC THE FOLLOWING LINE WAS FIXED    SEPTEBMER 1995
CCCCC GOTO300
      GOTO290
C
  220 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J2
CCCCC THE FOLLOWING LINE WAS FIXED    SEPTEBMER 1995
CCCCC GOTO7000
      GOTO290
C
  230 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J2
CCCCC THE FOLLOWING LINE WAS FIXED    SEPTEBMER 1995
CCCCC GOTO7000
      GOTO290
C
  290 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED                 SEPTEMBER 1995
CCCCC TO ALLOW COMMANDS SUCH AS    DELETE Y1 TO Y10   SEPTEMBER 1995
C               ****************************************************************
C               **  STEP 2.5--
C               **  TREAT THE     TO    KEYWORD CASE
C               **  AS IN    DELETE Y1 TO Y10
C               **  EXPAND SUCH LINES LITERALLY.
C               **
C               **  DETERMINE THE TYPE AND NUMBER OF ITEMS
C               **  TO BE DELETED   .
C               **  NUMALL = TOTAL NUMBER OF DELETED  ITEMS
C               **           (AS DETERMINED BY INCLUDING ONLY ALL BEFORE
C               **           'SUBSET' OR 'EXCEPT' OR 'FOR')
C               **  NUMV   = NUMBER OF VARIABLES TO BE DELETED    ;
C               **  NUMP   = NUMBER OF PARAMETERS TO BE DELETED    ;
C               **  NUMM   = NUMBER OF MODELS TO BE DELETED     (SHOULD = 0 OR 1)
C               **  NUMF   = NUMBER OF FUNCTIONS TO BE DELETED
C               **  NUMU   = NUMBER OF UNKNOWNS TO BE DELETED    ;
C               **  NUME   = TOTAL NUMBER OF DELETED  ITEMS (SHOULD = NUMALL);
C               ****************************************************************
C
      ISTEPN='4'
      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'DELE')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IV=0
      IP=0
      IM=0
      IF=0
      IU=0
      IE=0
C
      JMIN=1
      JMAX=ILOCQ-1
C
      IVALMA=0
      NUMALL=0
      NUMALL=JMAX-JMIN+1
      IF(JMIN.GT.JMAX)GOTO4290
      DO4200J=JMIN,JMAX
         IH1=IHARG(J)
         IH2=IHARG2(J)
C
         ICASTO='OFF'
         IF(IH1.EQ.'TO  ')GOTO4210
         GOTO4220
C
 4210    CONTINUE
         ICASTO='ON'
         JM1=J-1
         JP1=J+1
         CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1),
     1   KNUMB,IVAL1,IVAL2,IBUGS2,ISUBRO,IERROR)
C
         IVA1P1=IVAL1+1
         IVA2M1=IVAL2-1
         IF(IVA1P1.GT.IVA2M1)GOTO4200
         IVAL=IVAL1
C
 4215    CONTINUE
         IVAL=IVAL+1
         IF(IVAL.GE.IVAL2)GOTO4200
C
         CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL,
     1   IH1,IH2,IBUGS2,ISUBRO,IERROR)
         GOTO4220
C
 4220    CONTINUE
         ICASEA='    '
         DO4300I=1,NUMNAM
            I2=I
            IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))GOTO4305
            GOTO4300
 4305       CONTINUE
            IF(IUSE(I).EQ.'V')GOTO4310
            IF(IUSE(I).EQ.'P')GOTO4320
            IF(IUSE(I).EQ.'M')GOTO4330
            IF(IUSE(I).EQ.'F')GOTO4340
 4300    CONTINUE
         ICASEA='U'
         GOTO4350
C
 4310    CONTINUE
         ICASEA='V'
         IV=IV+1
         IF(IV.GT.MAXV2)GOTO4370
         JVNAM1(IV)=IH1
         JVNAM2(IV)=IH2
         NIV(IV)=IN(I2)
         GOTO4370
C
 4320    CONTINUE
         ICASEA='P'
         IP=IP+1
         IF(IP.GT.MAXP2)GOTO4370
         JPNAM1(IP)=IH1
         JPNAM2(IP)=IH2
         PVAL(IP)=VALUE(I2)
         GOTO4370
C
 4330    CONTINUE
         ICASEA='M'
         IM=IM+1
         IF(IM.GT.MAXM2)GOTO4370
         JMNAM1(IM)=IH1
         JMNAM2(IM)=IH2
         GOTO4370
C
 4340    CONTINUE
         ICASEA='F'
         IF=IF+1
         IF(IF.GT.MAXF2)GOTO4370
         JFNAM1(IF)=IH1
         JFNAM2(IF)=IH2
         IFSTA2(IF)=IVSTAR(I2)
         IFSTO2(IF)=IVSTOP(I2)
         GOTO4370
C
 4350    CONTINUE
         ICASEA='U'
         IU=IU+1
         IF(IU.GT.MAXU2)GOTO4370
         JUNAM1(IU)=IH1
         JUNAM2(IU)=IH2
         GOTO4370
C
 4370    CONTINUE
         IE=IE+1
         IF(IE.GT.MAXE2)GOTO4380
         JENAM1(IE)=IH1
         JENAM2(IE)=IH2
         IECASE(IE)='NEW'
         IF(ICASEA.EQ.'V')IECASE(IE)='OLD'
         IECOL2(IE)=-1
         IF(ICASEA.EQ.'V')IECOL2(IE)=IVALUE(I2)
         IF(ICASEA.EQ.'P')IECASE(IE)='OLD'
         IF(ICASEA.EQ.'F')IECASE(IE)='OLD'
         GOTO4280
C
 4380    CONTINUE
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4381)
 4381    FORMAT('***** ERROR IN DPDELE--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4382)
 4382    FORMAT('      THE NUMBER OF NAMES IN THE DELETE COMMAND')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4383)
 4383    FORMAT('      HAS JUST EXCEEDED THE ALLOWABLE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,4384)MAXE2
 4384    FORMAT('      MAXIMUM (',I5,')')
         CALL DPWRST('XXX','BUG ')
         IERROR='YES'
         GOTO9000
C
 4280    CONTINUE
         IF(ICASTO.EQ.'ON')GOTO4215
C
 4200 CONTINUE
 4290 CONTINUE
      NUMV=IV
      NUMP=IP
      NUMM=IM
      NUMF=IF
      NUMU=IU
      NUME=IE
C
      IF(IBUGS2.EQ.'OFF'.AND.ISUBRO.NE.'DELE')GOTO4429
      WRITE(ICOUT,4411)NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME
 4411 FORMAT('NUMALL,NUMV,NUMP,NUMM,NUMF,NUMU,NUME = ',7I6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4412)
 4412 FORMAT('I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I),
     1JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I)')
      CALL DPWRST('XXX','BUG ')
      DO4420I=1,15
      WRITE(ICOUT,4421)I,JVNAM1(I),JVNAM2(I),JPNAM1(I),JPNAM2(I),
     1JMNAM1(I),JMNAM2(I),JFNAM1(I),JFNAM2(I),JUNAM1(I),JUNAM2(I)
 4421 FORMAT(I8,5X,2A4,1X,2A4,1X,2A4,1X,2A4,1X,2A4)
      CALL DPWRST('XXX','BUG ')
 4420 CONTINUE
 4429 CONTINUE
C
      IF(ICASEQ.EQ.'FULL')GOTO300
      IF(ICASEQ.EQ.'SUBS')GOTO7000
      IF(ICASEQ.EQ.'FOR')GOTO7000
      GOTO300
C
C               ***********************************************************
C               **  STEP 3--                                             **
C               **  FOR THE FULL CASE,                                   **
C               **  EXTRACT EACH VARIABLE NAME AND EACH ARGUMENT VALUE.  **
C               ***********************************************************
C
  300 CONTINUE
      ISTEPN='3'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IPASS=0
      IPASS=IPASS+1
C
      IF(1.LE.IPASS.AND.IPASS.LE.MAXDEL)GOTO310
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,301)
  301 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,302)
  302 FORMAT('      THE DELETE COMMAND REQUIRES THAT ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,303)
  303 FORMAT('      THE NUMBER OF VARIABLES WITH ELEMENTS ',
     1'TO BE DELETED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,304)IPASS
  304 FORMAT('      BE BETWEEN 1 AND ',I8,' (INCLUSIVE);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,305)NUMDEL
  305 FORMAT('      THE SPECIFIED NUMBER WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,306)
  306 FORMAT('      THE INPUT COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,307)(IANS(I),I=1,IWIDTH)
  307 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  310 CONTINUE
      IF(IPASS.GE.2)ISAVE=IENDRP
C
C               ****************************************************************
C               **  STEP 3.1--
C               **  IF THIS IS THE FIRST PASS ON THIS LINE (AND ONLY FOR PASS 1)
C               **  SEARCH FOR DELETE (OTHERWISE SKIP THIS STEP)
C               **  SEARCH BETWEEN COLUMN 1 AND THE END OF THE LINE (INCLUSIVE).
C               ****************************************************************
C
      ISTEPN='3.1'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.GE.2)GOTO319
C
      ISTAR1=1
      ISTOP1=IWIDTH
      ISTRIN='DELE'
      ISTRI2='TE  '
      INEX='II'
      CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
     1             IFOUCO,IBEGCO,IENDCO,
     1             ITYPCO,IHOLCO,IHLCO2,INT1CO,FLOACO,IERRO1)
      IF(IFOUCO.EQ.'YES')GOTO319
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,311)
  311 FORMAT('***** INTERNAL ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,312)
  312 FORMAT('      THE WORD      DELETE      NOT FOUND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,313)
  313 FORMAT('      ON THE ENTERED INPUT COMMAND LINE.')
      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('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  319 CONTINUE
C
C               ****************************************************************
C               **  STEP 3.2--
C               **  SEARCH FOR LEFT PARENTHESIS;
C               **  IF THIS IS THE FIRST PASS FOR THIS LINE,
C               **  SEARCH BETWEEN    DELETE     AND      END OF LINE
C               **  (IF NO LEFT PARENTHESIS FOUND AT ALL, JUMP TO 7000).
C               **  IF THIS IS THE SECOND (OR HIGHER) PASS FOR THIS LINE,
C               **  SEARCH BETWEEN    PREVIOUS RIGHT PARENTHESIS AND
C               **  END OF LINE.
C               ****************************************************************
C
      ISTEPN='3.2'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.LE.1)ISTAR1=IENDCO+1
      IF(IPASS.GE.2)ISTAR1=ISAVE+1
      ISTOP1=IWIDTH
      ISTRIN='('
      INEX='II'
      CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
     1             IFOULP,IBEGLP,IENDLP,
     1             ITYPLP,IHOLLP,IHLLP2,INT1LP,FLOALP,IERRO1)
      IF(IFOULP.EQ.'YES')GOTO338
      IF(IFOULP.EQ.'NO'.AND.IPASS.GE.2)GOTO399
      GOTO7000
  338 CONTINUE
C
C               ****************************************************************
C               **  STEP 3.3--
C               **  SEARCH FOR RIGHT PARENTHESIS;
C               **  SEARCH BETWEEN    LEFT PARENTHESIS     AND    END OF LINE.
C               ****************************************************************
C
      ISTEPN='3.3'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTAR1=IENDLP+1
      ISTOP1=IWIDTH
      ISTRIN=')'
      INEX='II'
      CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
     1             IFOURP,IBEGRP,IENDRP,
     1             ITYPRP,IHOLRP,IHLRP2,INT1RP,FLOARP,IERRO1)
      IF(IFOURP.EQ.'YES')GOTO358
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,341)
  341 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,342)
  342 FORMAT('      WHEN THE DELETE COMMAND IS USED ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,343)
  343 FORMAT('      WITHOUT A SUBSET QUALIFICATION, OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,344)
  344 FORMAT('      WITHOUT A FOR    QUALIFICATION,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,345)
  345 FORMAT('      THEN ONLY INDIVIDUAL ELEMENTS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,346)
  346 FORMAT('      OF A VARIABLE MAY BE DELETED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,347)
  347 FORMAT('      SUCH INDIVIDUAL ELEMENTS ARE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,348)
  348 FORMAT('      SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,349)
  349 FORMAT('      PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,350)
  350 FORMAT('      HOWEVER, A RIGHT PARENTHESIS IS MISSING HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,351)
  351 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,352)(IANS(I),I=1,IWIDTH)
  352 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  358 CONTINUE
C
C               ****************************************************************
C               **  STEP 3.4--
C               **  SEARCH FOR ROW NUMBER;
C               **  SEARCH BETWEEN    LEFT PARENTHESIS     AND     RIGHT PARENTH
C               ****************************************************************
C
      ISTEPN='3.4'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ISTAR1=IENDLP
      ISTOP1=IENDRP
      ISTRIN='(;)'
      INEX='EE'
      CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
     1             IFOURN,IBEGRN,IENDRN,
     1             ITYPRN,IHOLRN,IHLRN2,INT1RN,FLOARN,IERRO1)
      IF(IFOURN.EQ.'YES')GOTO378
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,361)
  361 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,362)
  362 FORMAT('      WHEN THE DELETE COMMAND IS USED ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,363)
  363 FORMAT('      WITHOUT A SUBSET QUALIFICATION, OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,364)
  364 FORMAT('      WITHOUT A FOR    QUALIFICATION,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,365)
  365 FORMAT('      THEN ONLY INDIVIDUAL ELEMENTS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,366)
  366 FORMAT('      OF A VARIABLE MAY BE DELETED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,367)
  367 FORMAT('      SUCH INDIVIDUAL ELEMENTS ARE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,368)
  368 FORMAT('      SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,369)
  369 FORMAT('      PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,370)
  370 FORMAT('      HOWEVER, A ROW NUMBER IS MISSING HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,371)
  371 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,352)(IANS(I),I=1,IWIDTH)
  372 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  378 CONTINUE
C
C               ****************************************************************
C               **  STEP 3.5--
C               **  SEARCH FOR VARIABLE NAME;
C               **  IF THIS IS THE FIRST PASS FOR THIS LINE,
C               **  SEARCH BETWEEN    DELETE     AND      LEFT PARENTHESIS;
C               **  IF THIS IS THE SECOND (OR HIGHER) PASS FOR THIS LINE,
C               **  SEARCH BETWEEN    PREVIOUS RIGHT PARENTHESIS AND
C               **  THE NEXT LEFT PARENTHESIS.
C               ****************************************************************
C
      ISTEPN='3.5'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IPASS.LE.1)ISTAR1=IENDCO+1
      IF(IPASS.GE.2)ISTAR1=ISAVE+1
      ISTOP1=IENDLP
      ISTRIN='!;('
      INEX='IE'
      CALL DPTY3B(IANS,IWIDTH,ISTAR1,ISTOP1,ISTRIN,ISTRI2,INEX,IBUGS2,
     1             IFOUVN,IBEGVN,IENDVN,
     1             ITYPVN,IHOLVN,IHLVN2,INT1VN,FLOAVN,IERRO1)
      IF(IFOUVN.EQ.'YES')GOTO398
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,381)
  381 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,382)
  382 FORMAT('      WHEN THE DELETE COMMAND IS USED ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,383)
  383 FORMAT('      WITHOUT A SUBSET QUALIFICATION, OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,384)
  384 FORMAT('      WITHOUT A FOR    QUALIFICATION,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,385)
  385 FORMAT('      THEN ONLY INDIVIDUAL ELEMENTS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,386)
  386 FORMAT('      OF A VARIABLE MAY BE DELETED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,387)
  387 FORMAT('      SUCH INDIVIDUAL ELEMENTS ARE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,388)
  388 FORMAT('      SPECIFIED BY A VARIABLE NAME FOLLOWED BY A')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,389)
  389 FORMAT('      PAIR OF PARENTHSES WITH A ROW NUMBER WITHIN;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,390)
  390 FORMAT('      HOWEVER, A VARIABLE NAME IS MISSING HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,391)
  391 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,392)(IANS(I),I=1,IWIDTH)
  392 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  398 CONTINUE
      IVN(IPASS)=IHOLVN
      IVN2(IPASS)=IHLVN2
      IRN(IPASS)=INT1RN
C
      GOTO300
C
  399 CONTINUE
      NUMDEL=IPASS-1
C
C               ***************************************************************
C               **  STEP 4--                                                 **
C               **  FOR THE FULL CASE,                                       **
C               **  CHECK TO MAKE SURE ALL VARIABLES WITH DELETIONS          **
C               **  ARE, IN FACT, IN THE INTERNAL LIST,                      **
C               **  AND ARE, IN FACT, VARIABLES (AS OPPOSED TO PARAMETERS).  **
C               ***************************************************************
C
  400 CONTINUE
C
      ISTEPN='4'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO420J=1,NUMDEL
      J2=J
      IHVARJ=IVN(J)
      IHVRJ2=IVN2(J)
      DO430I=1,NUMNAM
      I2=I
      IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'V')GOTO440
      IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'M')GOTO440
      IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1IUSE(I).EQ.'P')GOTO450
  430 CONTINUE
C
      ILISTV(J2)=(-5)
      GOTO420
C
  440 CONTINUE
      ILISTV(J2)=I2
      GOTO420
C
  450 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
  451 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,452)
  452 FORMAT('      A VARIABLE WITH ELEMENTS TO BE DELETED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,454)
  454 FORMAT('      WAS FOUND IN THE INTERNAL NAME LIST,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,455)
  455 FORMAT('      BUT AS A PARAMETER,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,456)
  456 FORMAT('      AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,457)IHVARJ,IHVRJ2
  457 FORMAT('      THE VARIABLE NAME WAS ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,458)
  458 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,459)(IANS(I),I=1,IWIDTH)
  459 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  420 CONTINUE
C
C               *****************************************
C               **  STEP 5--                           **
C               **  TREAT THE FULL CASE.               **
C               **  CARRY OUT THE DELETING,            **
C               **  AND THE SUBSEQUENT PACKING,        **
C               **  DO THE LIST UPDATING, AND          **
C               **  PRODUCE SOME INFORMATIVE PRINTING. **
C               *****************************************
C
      ISTEPN='5'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO500J=1,NUMDEL
      IHVARJ=IVN(J)
      IHVRJ2=IVN2(J)
      IROWD=IRN(J)
      ILIST2=ILISTV(J)
CCCCC THE FOLLOWING LINE WAS INSERTED           DECEMBER 1994
      IF(ILIST2.LE.0)GOTO500
      NIVARJ=IN(ILIST2)
      ICOLVJ=IVALUE(ILIST2)
CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
      INCLVJ=IVALU2(ILIST2)
      IMAX=NIVARJ
      IF(1.LE.IROWD.AND.IROWD.LE.IMAX)GOTO539
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,531)
  531 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,532)IROWD
  532 FORMAT('      THE SPECIFIED ROW ELEMENT (= ROW ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,533)IHVARJ,IHVRJ2
  533 FORMAT('      TO BE DELETED FROM VARIABLE ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,534)
  534 FORMAT('      WAS SMALLER THAN 1, OR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,535)IMAX
  535 FORMAT('      WAS LARGER THAN THE CURRENT (= ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,536)
  536 FORMAT('      NUMBER OF ELEMENTS IN THIS VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  539 CONTINUE
C
      NS2=0
      ND2=0
      DO550I=1,IMAX
      IF(I.EQ.IROWD)GOTO560
      GOTO570
C
  560 CONTINUE
      ND2=ND2+1
      IJ=MAXN*(ICOLVJ-1)+I
      IF(ICOLVJ.LE.MAXCOL)TEMPD=V(IJ)
      IF(ICOLVJ.EQ.MAXCP1)TEMPD=PRED(I)
      IF(ICOLVJ.EQ.MAXCP2)TEMPD=RES(I)
      IF(ICOLVJ.EQ.MAXCP3)TEMPD=YPLOT(I)
      IF(ICOLVJ.EQ.MAXCP4)TEMPD=XPLOT(I)
      IF(ICOLVJ.EQ.MAXCP5)TEMPD=X2PLOT(I)
      IF(ICOLVJ.EQ.MAXCP6)TEMPD=TAGPLO(I)
      IF(ND2.EQ.1)IROD1O=I
      IRODNO=I
      IF(ND2.EQ.1)VALD1O=TEMPD
      VALDNO=TEMPD
      GOTO550
C
  570 CONTINUE
      NS2=NS2+1
      IJ=MAXN*(ICOLVJ-1)+I
      IF(ICOLVJ.LE.MAXCOL)TEMP(NS2)=V(IJ)
      IF(ICOLVJ.EQ.MAXCP1)TEMP(NS2)=PRED(I)
      IF(ICOLVJ.EQ.MAXCP2)TEMP(NS2)=RES(I)
      IF(ICOLVJ.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
      IF(ICOLVJ.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
      IF(ICOLVJ.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
      IF(ICOLVJ.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
      IF(NS2.EQ.1)IROW1O=I
      IROWNO=I
      IF(NS2.EQ.1)VAL1O=TEMP(NS2)
      VALNO=TEMP(NS2)
      GOTO550
C
  550 CONTINUE
      NIOLD=NIVARJ
      NINEW=NS2
      IROW1N=1
      IROWNN=NS2
C
      IF(NS2.GE.1)GOTO580
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,581)
  581 FORMAT('***** INTERNAL ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,582)
  582 FORMAT('      FOR THE FULL (UNQUALIFIED) CASE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,583)
  583 FORMAT('      SINCE THE RESULTING NS2 = 0,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,584)
  584 FORMAT('      THE NUMBER OF ELEMENTS DELETED = 0')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,585)IHVARJ,IHVRJ2,IMAX,IROWD
  585 FORMAT('      IHVARJ, IHVRJ2, IMAX, IROWD = ',2A4,I8,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,590)
  590 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,591)(IANS(I),I=1,IWIDTH)
  591 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
  580 CONTINUE
      DO600I=1,NS2
      IJ=MAXN*(ICOLVJ-1)+I
      IF(ICOLVJ.LE.MAXCOL)V(IJ)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP1)PRED(I)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP2)RES(I)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=TEMP(I)
      IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=TEMP(I)
  600 CONTINUE
C
      DO602J4=1,NUMNAM
      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLVJ)GOTO605
      GOTO602
  605 CONTINUE
      IUSE(J4)='V'
      IVALUE(J4)=ICOLVJ
CCCCC OCTOBER 1993.  ADD FOLLOWING LINE
      IVALU2(J4)=INCLVJ
      VALUE(J4)=ICOLVJ
      IN(J4)=NINEW
      IVSTAR(J4)=MAXN*(ICOLVJ-1)+1
      IVSTOP(J4)=MAXN*(ICOLVJ-1)+NINEW
  602 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO629
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)IHVARJ,IHVRJ2,NIOLD
  611 FORMAT('VARIABLE ',2A4,'--OLD NUMBER OF ELEMENTS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,612)NINEW
  612 FORMAT('                   NEW NUMBER OF ELEMENTS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,613)VALD1O
  613 FORMAT('                   FIRST VALUE DELETED    = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,614)IROD1O
  614 FORMAT('                         (DELETED FROM ROW ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,615)VALDNO
  615 FORMAT('                   LAST  VALUE DELETED    = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,616)IRODNO
  616 FORMAT('                         (DELETED FROM ROW ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,617)VAL1O
  617 FORMAT('                   FIRST VALUE RETAINED   = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,618)IROW1O,IROW1N
  618 FORMAT('                         (MOVED FROM ROW ',I8,
     1' TO ROW ',I8,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,619)VALNO
  619 FORMAT('                   LAST  VALUE RETAINED   = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,620)IROWNO,IROWNN
  620 FORMAT('                         (MOVED FROM ROW ',I8,
     1' TO ROW ',I8,')')
      CALL DPWRST('XXX','BUG ')
  629 CONTINUE
C
  500 CONTINUE
C
      GOTO8900
C
C               ***************************************************************
C               **  STEP 7--                                                 **
C               **  FOR THE SUBSET AND FOR CASES                            **
C               **  (AND WHEN DELETING ENTIRE VARIABLES),
C               **  CHECK TO MAKE SURE ALL VARIABLES WITH DELETIONS          **
C               **  ARE, IN FACT, IN THE INTERNAL LIST.                      **
C               ***************************************************************
C
 7000 CONTINUE
C
      ISTEPN='7'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC NUMDEL=ILOCQ-1
CCCCC IF(NUMDEL.LE.0.OR.NUMDEL.GT.MAXDEL)THEN
      IF(NUME.LE.0.OR.NUME.GT.MAXE2)THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7101)
 7101    FORMAT('***** ERROR IN DPDELE--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7102)
 7102    FORMAT('      THE DELETE COMMAND REQUIRES THAT ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7103)
 7103    FORMAT('      THE NUMBER OF VARIABLES WITH ELEMENTS ',
     1   'TO BE DELETED')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7104)MAXE2
 7104    FORMAT('      BE BETWEEN 1 AND ',I8,' (INCLUSIVE);')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7105)NUME
 7105    FORMAT('      THE SPECIFIED NUMBER WAS ',I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,7106)
 7106    FORMAT('      THE INPUT COMMAND LINE WAS AS FOLLOWS--')
         CALL DPWRST('XXX','BUG ')
         IF(IWIDTH.GE.1)WRITE(ICOUT,7107)(IANS(I),I=1,IWIDTH)
 7107    FORMAT('      ',100A1)
         IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
         IERROR='YES'
         GOTO8900
      ENDIF
C
      J2=0
      DO7200J=1,NUME
         IHVARJ=JENAM1(J)
         IHVRJ2=JENAM2(J)
         DO7300I=1,NUMNAM
            I2=I
            IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1      IUSE(I).EQ.'V')GOTO7400
            IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1      IUSE(I).EQ.'P')GOTO7500
            IF(IHVARJ.EQ.IHNAME(I).AND.IHVRJ2.EQ.IHNAM2(I).AND.
     1      IUSE(I).EQ.'M')GOTO7450
 7300    CONTINUE
C
CCCCC    ILISTV(J2)=(-5)
         GOTO7200
C
 7400    CONTINUE
         J2=J2+1
         ILISTV(J2)=I2
         GOTO7200
CCCCC    OCTOBER 1993.  HANDLE MATRIX CASE.  NEED TO DELETE EACH OF THE
CCCCC    VARIABLES AS WELL.
 7450    CONTINUE
         IN(I2)=-1
         NCOL=IVALU2(I2) - IVALUE(I2) + 1
         ISTART=I2+1
         ISTOP=ISTART+NCOL-1
         DO7455II=ISTART,ISTOP
           IN(II)=-1
 7455    CONTINUE
         GOTO7200
C
CCCCC    OCTOBER 1993.  TO DELETE A PARAMETER, USE THE FACT THAT DPUPDV
CCCCC    REMOVES ANY NAME WHERE IN(.)=0.  SET IN(.) TO ZERO.
CCCCC    JUNE 1994.  SET TO -1 (SOME INTERNALLY SET PARAMETERS DO
CCCCC    NOT SET IN(.), SO BE MORE EXPLICIT.
 7500    CONTINUE
CCCCC    IN(I2)=0
         IN(I2)=-1
         GOTO7200
C
 7200 CONTINUE
      NDONE=J2
C
C               *****************************************
C               **  STEP 8--                           **
C               **  TREAT THE SUBSET AND FOR CASES     **
C               **  AND CERTAIN FULL CASES.            **
C               **  CARRY OUT THE DELETING,            **
C               **  AND THE SUBSEQUENT PACKING,        **
C               **  DO THE LIST UPDATING, AND          **
C               **  PRODUCE SOME INFORMATIVE PRINTING. **
C               *****************************************
C
      ISTEPN='8'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEQ.EQ.'FULL')GOTO8100
      ILQP1=ILOCQ+1
      IF(ILQP1.LE.NUMARG)GOTO8100
      IF(ICASEQ.EQ.'FOR')GOTO8030
      GOTO8010
C
 8010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8011)
 8011 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8012)
 8012 FORMAT('      THE WORD    SUBSET    WAS THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8013)
 8013 FORMAT('      FINAL WORD ON THE COMMAND LINE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8014)
 8014 FORMAT('      THE WORD    SUBSET   SHOULD HAVE BEEN FOLLOWED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8015)
 8015 FORMAT('      BY EITHER 2 OR 3 ARGUMENTS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8016)
 8016 FORMAT('      THE FIRST ARGUMENT SPECIFIES THE SUBSET ',
     1'VARIABLE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8017)
 8017 FORMAT('      THE SECOND AND (IF EXISTENT) THIRD ARGUMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8018)
 8018 FORMAT('      SPECIFY THE VALUE OR INTERVAL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8019)
 8019 FORMAT('      (OF THE SUBSET VARIABLE) WHICH DEFINES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8020)
 8020 FORMAT('      THE SUBSET OF INTEREST.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8021)
 8021 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,8022)(IANS(I),I=1,IWIDTH)
 8022 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
 8030 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8031)
 8031 FORMAT('***** ERROR IN DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8032)
 8032 FORMAT('      THE WORD    FOR    WAS THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8033)
 8033 FORMAT('      FINAL WORD ON THE COMMAND LINE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8034)
 8034 FORMAT('      THE WORD    FOR    SHOULD HAVE BEEN FOLLOWED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8035)
 8035 FORMAT('      BY EXACTLY 3 OR BY EXACTLY 5    WORDS   --')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8036)
 8036 FORMAT('      1) A DUMMY VARIABLE NAME;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8037)
 8037 FORMAT('      2) AN EQUAL SIGN;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8038)
 8038 FORMAT('      3) ONE LIMIT (LOWER OR UPPER) ',
     1'FOR THE DUMMY VARIABLE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8039)
 8039 FORMAT('      4) THE INCREMENT FOR THE DUMMY VARIABLE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9040)
 9040 FORMAT('      5) THE OTHER LIMIT (UPPER OR LOWER) ',
     1'FOR THE DUMMY VARIABLE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)
 9041 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,9042)(IANS(I),I=1,IWIDTH)
 9042 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO8900
C
 8100 CONTINUE
      IF(ICASEQ.EQ.'FULL')GOTO8130
      IF(ICASEQ.EQ.'FOR')GOTO8120
      IHSET=IHARG(ILQP1)
      IHSET2=IHARG2(ILQP1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHSET,IHSET2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      GOTO8110
C
 8110 CONTINUE
      NISET=IN(ILOC)
      CALL DPSUBS(NISET,ILOCS,NS,IBUGQ,IERROR)
      NQ=NISET
      GOTO8200
C
 8120 CONTINUE
      NIOLD=MAXN
      CALL DPFOR(NIOLD,NINEW,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NINEW
      GOTO8200
C
 8130 CONTINUE
      DO8135I=1,MAXN
         ISUB(I)=1
 8135 CONTINUE
      NQ=MAXN
      GOTO8200
C
 8200 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO8300J=1,NUME
         IHVARJ=JENAM1(J)
         IHVRJ2=JENAM2(J)
         ILIST2=ILISTV(J)
         IF(ILIST2.LE.0)GOTO8300
         NIVARJ=IN(ILIST2)
CCCCC    OCTOBER 1993.  SKIP FOR PARAMETER
         IF(NIVARJ.EQ.0)GOTO8300
         ICOLVJ=IVALUE(ILIST2)
CCCCC    OCTOBER 1993.  ADD FOLLOWING LINE
         INCLVJ=IVALU2(ILIST2)
         NS2=0
         ND2=0
         IMAX=NQ
         IF(NIVARJ.LT.NQ)IMAX=NIVARJ
         DO8400I=1,IMAX
            IF(ISUB(I).EQ.0)GOTO8450
C
            ND2=ND2+1
            IJ=MAXN*(ICOLVJ-1)+I
            IF(ICOLVJ.LE.MAXCOL)TEMPD=V(IJ)
            IF(ICOLVJ.EQ.MAXCP1)TEMPD=PRED(I)
            IF(ICOLVJ.EQ.MAXCP2)TEMPD=RES(I)
            IF(ICOLVJ.EQ.MAXCP3)TEMPD=YPLOT(I)
            IF(ICOLVJ.EQ.MAXCP4)TEMPD=XPLOT(I)
            IF(ICOLVJ.EQ.MAXCP5)TEMPD=X2PLOT(I)
            IF(ICOLVJ.EQ.MAXCP6)TEMPD=TAGPLO(I)
            IF(ND2.EQ.1)IROD1O=I
            IRODNO=I
            IF(ND2.EQ.1)VALD1O=TEMPD
            VALDNO=TEMPD
            GOTO8400
C
 8450       CONTINUE
            NS2=NS2+1
            IJ=MAXN*(ICOLVJ-1)+I
            IF(ICOLVJ.LE.MAXCOL)TEMP(NS2)=V(IJ)
            IF(ICOLVJ.EQ.MAXCP1)TEMP(NS2)=PRED(I)
            IF(ICOLVJ.EQ.MAXCP2)TEMP(NS2)=RES(I)
            IF(ICOLVJ.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
            IF(ICOLVJ.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
            IF(ICOLVJ.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
            IF(ICOLVJ.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
            IF(NS2.EQ.1)IROW1O=I
            IROWNO=I
            IF(NS2.EQ.1)VAL1O=TEMP(NS2)
            VALNO=TEMP(NS2)
            GOTO8400
C
 8400    CONTINUE
         NIOLD=NIVARJ
         NINEW=NS2
         IROW1N=1
         IROWNN=NS2
C
         IF(ND2.GE.1)GOTO8550
         IERROR='YES'
         GOTO8900
C
 8550    CONTINUE
         DO8500I=1,NS2
            IJ=MAXN*(ICOLVJ-1)+I
            IF(ICOLVJ.LE.MAXCOL)V(IJ)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP1)PRED(I)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP2)RES(I)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=TEMP(I)
            IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=TEMP(I)
 8500    CONTINUE
C
CCCCC OCTOBER 1997.  REINIITIALIZE DELETED VALUES TO ZERO
CCCCC INSTEAD OF CPUMIN.
         NS2P1=NS2+1
         IF(NS2P1.GT.IMAX)GOTO8569
         DO8560I=NS2P1,IMAX
            IJ=MAXN*(ICOLVJ-1)+I
CCCCC       IF(ICOLVJ.LE.MAXCOL)V(IJ)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP1)PRED(I)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP2)RES(I)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=CPUMIN
CCCCC       IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=CPUMIN
            IF(ICOLVJ.LE.MAXCOL)V(IJ)=0.0
            IF(ICOLVJ.EQ.MAXCP1)PRED(I)=0.0
            IF(ICOLVJ.EQ.MAXCP2)RES(I)=0.0
            IF(ICOLVJ.EQ.MAXCP3)YPLOT(I)=0.0
            IF(ICOLVJ.EQ.MAXCP4)XPLOT(I)=0.0
            IF(ICOLVJ.EQ.MAXCP5)X2PLOT(I)=0.0
            IF(ICOLVJ.EQ.MAXCP6)TAGPLO(I)=0.0
 8560    CONTINUE
 8569    CONTINUE
C
         DO8600J4=1,NUMNAM
            IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLVJ)GOTO8605
            GOTO8600
 8605       CONTINUE
            IUSE(J4)='V'
            IVALUE(J4)=ICOLVJ
CCCCC       OCTOBER 1993.  ADD FOLLOWING LINE
            IVALU2(J4)=INCLVJ
            VALUE(J4)=ICOLVJ
            IN(J4)=NINEW
            IVSTAR(J4)=MAXN*(ICOLVJ-1)+1
            IVSTOP(J4)=MAXN*(ICOLVJ-1)+NINEW
 8600    CONTINUE
C
         IF(IFEEDB.EQ.'OFF')GOTO8629
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8611)IHVARJ,IHVRJ2,NIOLD
 8611    FORMAT('VARIABLE ',2A4,'--OLD NUMBER OF ELEMENTS = ',I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8612)NINEW
 8612    FORMAT('                   NEW NUMBER OF ELEMENTS = ',I8)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8613)VALD1O
 8613    FORMAT('                   FIRST VALUE DELETED    = ',E15.7)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8614)IROD1O
 8614    FORMAT('                         (DELETED FROM ROW ',I8,')')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8615)VALDNO
 8615    FORMAT('                   LAST  VALUE DELETED    = ',E15.7)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8616)IRODNO
 8616    FORMAT('                         (DELETED FROM ROW ',I8,')')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8617)VAL1O
 8617    FORMAT('                   FIRST VALUE RETAINED   = ',E15.7)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8618)IROW1O,IROW1N
 8618    FORMAT('                         (MOVED FROM ROW ',I8,
     1   ' TO ROW ',I8,'  )')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8619)VALNO
 8619    FORMAT('                   LAST  VALUE RETAINED   = ',E15.7)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,8620)IROWNO,IROWNN
 8620    FORMAT('                         (MOVED FROM ROW ',I8,
     1   ' TO ROW ',I8,')')
         CALL DPWRST('XXX','BUG ')
 8629    CONTINUE
C
 8300 CONTINUE
C
      GOTO8900
C
C               **********************************
C               **  STEP 9--                    **
C               **  UPDATE INTERNAL DATA ARRAY  **
C               **  (IF NECESSARY)              **
C               **********************************
C
 8900 CONTINUE
C
      ISTEPN='9'
      IF(IBUGS2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC OCTOBER 1993.  ADD ARGUMENT TO LIST
CCCCC CALL DPUPDV(IHNAME,IHNAM2,IUSE,IVALUE,VALUE,IN,
      CALL DPUPDV(IHNAME,IHNAM2,IUSE,IVALUE,IVALU2,VALUE,IN,
     1IVARLB,
     1IVSTAR,IVSTOP,MAXNAM,NUMNAM,V,MAXN,MAXCOL,NUMCOL,
     1IBUGS2,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGS2.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDELE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGS2,IERROR
 9012 FORMAT('IBUGS2,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)MAXNAM,NUMNAM
 9013 FORMAT('MAXNAM,NUMNAM = ',3I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)MAXN,MAXCOL,NUMCOL
 9014 FORMAT('MAXN,MAXCOL,NUMCOL = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO9020I=1,NUMNAM
      WRITE(ICOUT,9021)I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I)
 9021 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVALUE(I),VALUE(I) = ',
     1I8,2X,A4,A4,2X,A4,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)
 9022 FORMAT('I,IHNAME(I),IHNAM2(I),IN(I),IVSTAR(I),IVSTOP(I)  = ',
     1I8,2X,A4,A4,6X,I8,I8,I8)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9030J=1,NUMCOL
      IJ=MAXN*(J-1)+1
      WRITE(ICOUT,9031)J,MAXN,IJ,V(IJ)
 9031 FORMAT('J,MAXN,IJ,V(IJ) = ',I8,I8,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDELI(Y,X,PX,NP,NUMSET,
     1ICASPL,ICAS3D,
     1XDELMN)
C
C     PURPOSE--DETERMINE DATA LIMITS, FRAME LIMITS,
C              AND TIC COORDINATES FOR A PLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--MAY        1990.  ADD VARIABLES TO DPDETM CALL LIST
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION PX(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      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.'DELI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDELI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IMANUF,IMODEL
   52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)NP,NUMSET,XDELMN
   54 FORMAT('NP,NUMSET,XDELMN = ',2I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)ICASPL,ICAS3D
   55 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)ITICUN
   70 FORMAT('ITICUN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)PX1TOL,PX2TOL,PY1TOB,PY2TOB
   71 FORMAT('PX1TOL,PX2TOL,PY1TOB,PY2TOB = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)PX1TOR,PX2TOR,PY1TOT,PY2TOT
   72 FORMAT('PX1TOR,PX2TOR,PY1TOT,PY2TOT = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ************************************
C               **  STEP 1--                      **
C               **  DETERMINE ACTUAL DATA LIMITS  **
C               **  (IN UNITS OF THE DATA)        **
C               ************************************
C
      CALL DPDEDL(Y,X,PX,NP,NUMSET,
     1ICASPL,ICAS3D,
     1ISPISW,ASPIBA,MAXSPI,
     1IBARSW,ABARBA,ABARWI,MAXBAR,XDELMN,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
     1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
     1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
     1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
     1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
     1IHORSW)
C  IHORSW ADDED SEPTEMBER, 1987
C
C               *************************************
C               **  STEP 2--                       **
C               **  DETERMINE ACTUAL FRAME LIMITS  **
C               **  (IN UNITS OF THE DATA)         **
C               *************************************
C
      CALL DPDEFL(ICASPL,ICAS3D,
     1DX1MIN,DX1MAX,DY1MIN,DY1MAX,
     1DX2MIN,DX2MAX,DY2MIN,DY2MAX,
     1GX1MIN,GX1MAX,GY1MIN,GY1MAX,
     1GX2MIN,GX2MAX,GY2MIN,GY2MAX,
     1IX1MIN,IX1MAX,IY1MIN,IY1MAX,
     1IX2MIN,IX2MAX,IY2MIN,IY2MAX,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
     1NMJX1T,NMJX2T,NMJY1T,NMJY2T)
CCCCC NOVEMBER 1997.  SAVE FRAME LIMITS BEFORE AFFECTED BY
CCCCC TIC OFFSET VALUES.
      FX1MNZ=FX1MIN
      FX1MXZ=FX1MAX
      FX2MNZ=FX2MIN
      FX2MXZ=FX2MAX
      FY1MNZ=FY1MIN
      FY1MXZ=FY1MAX
      FY2MNZ=FY2MIN
      FY2MXZ=FY2MAX
C
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *********************************************
C               **  STEP 3--                               **
C               **  DETERMINE ACTUAL TIC MARK COORDINATES  **
C               **  (IN BOTH STANDARDIZED 0 TO 100 UNITS,  **
C               **  AND IN DATA UNITS)                     **
C               *********************************************
C
CCCCC ADDED TIC OFFSET VARIABLES TO CALL LIST MAY, 1990.
C
      CALL DPDETM(PXMIN,PYMIN,PXMAX,PYMAX,
     1ICASPL,ICAS3D,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
     1IX1TSW,IX2TSW,IY1TSW,IY2TSW,
     1IX1JSW,IX2JSW,IY1JSW,IY2JSW,
     1NMJX1T,NMJX2T,NMJY1T,NMJY2T,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1PX1COO,PX2COO,PY1COO,PY2COO,
     1X1COOR,X2COOR,Y1COOR,Y2COOR,
     1NX1COO,NX2COO,NY1COO,NY2COO,
     1IX1NSW,IX2NSW,IY1NSW,IY2NSW,
     1NMNX1T,NMNX2T,NMNY1T,NMNY2T,
     1PX1CMN,PX2CMN,PY1CMN,PY2CMN,
     1X1COMN,X2COMN,Y1COMN,Y2COMN,
     1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
     1PX1TOL,PX2TOL,PY1TOB,PY2TOB,
     1PX1TOR,PX2TOR,PY1TOT,PY2TOT,
     1ITICUN)
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DELI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDELI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IMANUF,IMODEL
 9012 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NP,NUMSET,XDELMN
 9014 FORMAT('NP,NUMSET,XDELMN = ',2I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)ICASPL,ICAS3D
 9015 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4
 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEMN(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IPL1NU,IPL1NA,
     1IPL2NU,IPL2NA,
     1IPL1CS,IPL2CS,
     1IDEFMA,IDEFMO,IDEFM2,IDEFM3,
     1IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1ICAPSW,ICAPNU,
     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C  JUNE 1992.  IPL1CS, IPL2CS ADDED TO ARGUMENT LIST
C
C     PURPOSE--DEFINE THE MANUFACTURER AND MODEL FOR AN OUTPUT DEVICE.
C              THE MANUFACTURER AND MODEL WILL BE PLACED
C              IN THE I-TH ELEMENT OF THE VECTORS
C              IDMANU, IDMODE, IDMOD2, AND IDMOD3.
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                     --IDEFMA
C                     --IDEFMO
C                     --IDEFM2
C                     --IDEFM3
C                     --MAXDEV
C     OUTPUT ARGUMENTS--
C                     --IDMANU
C                     --IDMODE
C                     --IDMOD2
C                     --IDMOD3
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1989.  POSTSCRIPT, QUIC, PCL, ETC.  (ALAN)
C     UPDATED         --MAY       1989.  POSTSCRIPT TRANSLATION FIX (ALAN)
C     UPDATED         --MARCH     1990.  X11 FIX
C     UPDATED         --MAY       1990.  HP-GL MODEL NUMBERS
C     UPDATED         --MAY       1990.  DISTINCTION BETWEEN OFF AND CLOSE
C     UPDATED         --APRIL     1992.  CALL GREXIT IF CLOSE (ALAN)
C     UPDATED         --MAY       1992.  SKIP MESSAGE FOR DEVICE 3
C     UPDATED         --JUNE      1992.  DON'T CALL GRINDE FOR ON
C     UPDATED         --JUNE      1992.  IF DEVICE, CHECK IF STATUS IS OPEN
C     UPDATED         --AUGUST    1992.  FIX FOR HP-GL (LASER JET III)
C     UPDATED         --MARCH     1995.  SYNONYMS FOR POSTSCRIPT
C     UPDATED         --OCTOBER   1996.  QWIN PATCH
C     UPDATED         --FEBRUARY  2001.  GD AND GDI DEVICES SHOULD NOT OPEN OUTPUT
C                                        FILE (DONE BY UNDERLYING C ROUTINES)
C                                        PASS IGDFLG TO DPDEP2
C     UPDATED         --SEPTEMBER 2002.  ICAPSW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*80 IPL1NA
      CHARACTER*80 IPL2NA
C  FOLLOWING 2 LINES JUNE 1992
      CHARACTER*12 IPL1CS
      CHARACTER*12 IPL2CS
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*4 IDEFMA
      CHARACTER*4 IDEFMO
      CHARACTER*4 IDEFM2
      CHARACTER*4 IDEFM3
C
      CHARACTER*4 IDEFPO
      CHARACTER*4 IDEFCN
      CHARACTER*4 IDEFDC
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
      CHARACTER*4 IDFONT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IANS
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IOPERA
      CHARACTER*4 IGENID
      CHARACTER*4 IGDFLG
      CHARACTER*4 IFOUN2
C
      CHARACTER*4 ISAVE
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDFONT(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
      DIMENSION IDNVOF(*)
      DIMENSION IDNHOF(*)
C
      DIMENSION IANS(*)
C
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'
      IBUGG4='OFF'
      ISUBG4='-999'
      ISAVE='-999'
C
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF DPDEMN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGO2,ISUBRO
   53 FORMAT('IBUGO2,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFOUND,IERROR
   60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
      WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
   71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      WRITE(ICOUT,75)IPL1CS,IPL2CS
   75 FORMAT('IPL1CS,IPL2CS=',A4,1X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
CCCCC FEBRUARY, 1989.  CHECK IF MODEL ="ON" OR "OFF".  IF SO, DO NOT TREAT AS
CCCCC AS A DEVICE.  WILL BE HANDLED SEPARATELY IN MAINOD.
C
CCCCC IF(IHARG(NUMARG).EQ.'ON')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'OPEN')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'OFF')GOTO9000
CCCCC IF(IHARG(NUMARG).EQ.'CLOS')GOTO9000
C  END FIX
      IF(NUMARG.LE.0)GOTO1199
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MANU')GOTO1110
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MANU')GOTO1140
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MODE')GOTO1140
CCCCC GOTO1199
      GOTO1140
C
C  ***************************************************************
C  **  FEBRAURY, 1989: HANDLE "ON" AND "OFF" SEPARETELY.  THESE WILL **
C  **  TURN THE DEVICE POWER "ON" AND "OFF", BUT WILL NOT RESET **
C  **  THE DEVICE TYPE OR OTHER SETTINGS.  DO THIS WAY SO CAN   **
C  **  TOGGLE A DEVICE "ON" AND "OFF".                          **
C  ***************************************************************
C
C  MAY, 1990.  DISTINGUISH BETWEEN OFF AND CLOSE.  BOTH WILL TURN THE
C  POWER SWITCH OFF, BUT CLOSE WILL ALSO CLOSE THE FILE.
 1110 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1112
      IF(IHARG(NUMARG).EQ.'OPEN')GOTO1112
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1116
      IF(IHARG(NUMARG).EQ.'CLOS')GOTO1118
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
      IF(NUMARG.LE.1)GOTO1120
      GOTO1125
C
 1120 CONTINUE
      DO1121I=1,NUMDEV
      IDMANU(I)=IDEFMA
      IDMODE(I)=IDEFMO
      IDMOD2(I)=IDEFM2
      IDMOD3(I)=IDEFM3
      IDPOWE(I)=IDEFPO
      IDCONT(I)=IDEFCN
      IDCOLO(I)=IDEFDC
      IDNVPP(I)=IDEFVP
      IDNHPP(I)=IDEFHP
      IDUNIT(I)=IDEFUN
 1121 CONTINUE
      GOTO1130
C
 1112 CONTINUE
      DO1114I=1,NUMDEV
      IDPOWE(I)='ON'
 1114 CONTINUE
      GOTO1130
C
 1116 CONTINUE
      DO1117I=1,NUMDEV
      IDPOWE(I)='OFF'
 1117 CONTINUE
      GOTO1130
C
 1118 CONTINUE
      DO1119I=1,NUMDEV
      IDPOWE(I)='OFF'
 1119 CONTINUE
      GOTO1130
C
C  FEBRUARY,1989.  "QMS" WILL BE SET TO "QUIC".  "LASER JET" TO PCL.
 1125 CONTINUE
C  JUNE 1992.  FOLLOWING FOR DEBUGGING PURPOSES
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO1124
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1123)
 1123 FORMAT('IN LOOP 1125')
      CALL DPWRST('XXX','BUG ')
 1124 CONTINUE
C
      DO1127I=1,NUMDEV
      K=2
      IF(K.LE.NUMARG)IDMANU(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMANU(I)='    '
      ISAVE=IDMANU(I)
      IF(ISAVE.EQ.'HPGL')IDMANU(I)='HP  '
      IF(ISAVE.EQ.'QMS')IDMANU(I)='QUIC'
      IF(ISAVE.EQ.'TELA')IDMANU(I)='QUIC'
      IF(ISAVE.EQ.'LASE')IDMANU(I)='PCL '
      IF(ISAVE.EQ.'PS  ')IDMANU(I)='POST'
      K=K+1
      IF(K.LE.NUMARG)IDMODE(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMODE(I)='    '
C  FOLLOWING LINE MOVED TO BELOW
CCCCC IF(ISAVE.EQ.'HPGL')IDMODE(I)='GL  '
      IF(ISAVE.EQ.'LASE'.AND.IDMODE(I).EQ.'JET')IDMODE(I)='    '
      K=K+1
      IF(K.LE.NUMARG)IDMOD2(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMOD2(I)='    '
      K=K+1
      IF(K.LE.NUMARG)IDMOD3(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMOD3(I)='    '
C  FOLLOWING BLOCK ADDED TO CHECK FOR HPGL MODEL NUMBERS
      IF(ISAVE.EQ.'HPGL')THEN
        IDMOD3(I)=IDMOD2(I)
        IDMOD2(I)=IDMODE(I)
        IDMODE(I)='GL  '
      END IF
C  END CHANGES
CCCCC MARCH 1995.  ADD FOLLOWING 4 LINES
      IF(ISAVE.EQ.'EPS ')IDMANU(I)='POST'
      IF(ISAVE.EQ.'EPS ')IDMODE(I)='ENCA'
      IF(ISAVE.EQ.'ENCA')IDMANU(I)='POST'
      IF(ISAVE.EQ.'ENCA')IDMODE(I)='ENCA'
C
      CALL GRSEPP(I,
     1IPL1NU,
     1IPL2NU,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IBUGO2,IFOUN2,IERROR)
 1127 CONTINUE
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)
 1136 FORMAT('THE MANUFACTURER FOR ALL DEVICES HAS JUST BEEN')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1137)IDMANU(1),IDMODE(1),IDMOD2(1),IDMOD3(1)
 1137 FORMAT('SET TO ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO1199
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDEMN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... MANUFACTURER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 2 MANUFACTURER FR-80')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDEMN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... MANUFACTURER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
C  ***************************************************************
C  **  FEBRUARY, 1989: HANDLE "ON" AND "OFF" SEPARETELY.  THESE WILL **
C  **  TURN THE DEVICE POWER "ON" AND "OFF", BUT WILL NOT RESET **
C  **  THE DEVICE TYPE OR OTHER SETTINGS.  DO THIS WAY SO CAN   **
C  **  TOGGLE A DEVICE "ON" AND "OFF".                          **
C  ***************************************************************
C
C  MAY, 1990.  DISTINGUISH BETWEEN OFF AND CLOSE.  BOTH WILL TURN THE
C  POWER SWITCH OFF, BUT CLOSE WILL ALSO CLOSE THE FILE.
C
 1160 CONTINUE
      IF(IHARG(NUMARG).EQ.'ON')GOTO1162
CCCCC JUNE 1992.  HANDLE ON AND OPEN CASE DIFFERENTLY
CCCCC IF(IHARG(NUMARG).EQ.'OPEN')GOTO1162
      IF(IHARG(NUMARG).EQ.'OPEN')GOTO1163
      IF(IHARG(NUMARG).EQ.'OFF')GOTO1167
      IF(IHARG(NUMARG).EQ.'CLOS')GOTO1168
      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1170
      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
      IF(NUMARG.LE.2)GOTO1175
      GOTO1175
C
 1170 CONTINUE
      IF(I.GT.NUMDEV)NUMDEV=I
      IDMANU(I)=IDEFMA
      IDMODE(I)=IDEFMO
      IDMOD2(I)=IDEFM2
      IDMOD3(I)=IDEFM3
      IDPOWE(I)=IDEFPO
      IDCONT(I)=IDEFCN
      IDCOLO(I)=IDEFDC
      IDNVPP(I)=IDEFVP
      IDNHPP(I)=IDEFHP
      IDUNIT(I)=IDEFUN
      GOTO1180
C
 1162 CONTINUE
      IF(I.GT.NUMDEV)NUMDEV=I
      IDPOWE(I)='ON'
      GOTO1180
C
CCCCC JUNE 1992.  FOLLOWING BLOCK ADDED.
 1163 CONTINUE
      IF(I.EQ.2.AND.IPL1CS(1:4).EQ.'OPEN')THEN
        IERROR='YES'
        WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3163)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3164)
      CALL DPWRST('XXX','BUG ')
        GOTO1199
      ENDIF
 3163 FORMAT('***** ERROR IN DPDEMN--')
 3164 FORMAT('      DEVICE 2 IS ALREADY OPEN')
      IF(I.EQ.3.AND.IPL2CS(1:4).EQ.'OPEN')THEN
        IERROR='YES'
        WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3173)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3174)
      CALL DPWRST('XXX','BUG ')
        GOTO1199
      ENDIF
 3173 FORMAT('***** ERROR IN DPDEMN--')
 3174 FORMAT('      DEVICE 3 IS ALREADY OPEN')
      IF(I.GT.NUMDEV)NUMDEV=I
      IDPOWE(I)='ON'
      IOPERA='OPEN'
      GOTO1179
CCCCC END JUNE 1992 CHANGE
C
 1167 CONTINUE
      IF(I.GT.NUMDEV)NUMDEV=I
      IDPOWE(I)='OFF'
      GOTO1180
C
 1168 CONTINUE
      IF(I.GT.NUMDEV)NUMDEV=I
      IDPOWE(I)='OFF'
      IOPERA='CLOS'
      GOTO1179
C
C  FEBRUARY,1989.  "QMS" WILL BE SET TO "QUIC".  "LASER JET" TO PCL.
C
 1175 CONTINUE
CCCCC JUNE 1992.  DON"T RE-OPEN DEVICE IF ALREADY OPEN
C  JUNE 1992.  FOLLOWING FOR DEBUGGING PURPOSES
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO1174
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1173)I,IPL1CS,IPL2CS
 1173 FORMAT('IN LOOP 1175, I,IPL1CS,IPL2CS=',I4,A4,A4)
      CALL DPWRST('XXX','BUG ')
 1174 CONTINUE
C
      IF(I.EQ.2.AND.IPL1CS(1:4).EQ.'OPEN')THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3163)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3164)
        CALL DPWRST('XXX','BUG ')
        GOTO1199
      ENDIF
      IF(I.EQ.3.AND.IPL2CS(1:4).EQ.'OPEN')THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3173)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3174)
        CALL DPWRST('XXX','BUG ')
        GOTO1199
      ENDIF
CCCCC END JUNE 1992 CHANGES
      IF(I.GT.NUMDEV)NUMDEV=I
      K=2
      IF(IHARG(2).EQ.'MANU')K=3
      IF(IHARG(2).EQ.'MODE')K=3
      IF(K.LE.NUMARG)IDMANU(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMANU(I)='    '
      ISAVE=IDMANU(I)
      IF(ISAVE.EQ.'HPGL')IDMANU(I)='HP  '
      IF(ISAVE.EQ.'QMS')IDMANU(I)='QUIC'
      IF(ISAVE.EQ.'TELA')IDMANU(I)='QUIC'
      IF(ISAVE.EQ.'LASE')IDMANU(I)='PCL '
      IF(ISAVE.EQ.'PS  ')IDMANU(I)='POST'
      K=K+1
      IF(K.LE.NUMARG)IDMODE(I)=IHARG(K)
C  FOLLOWING LINE MOVED TO BELOW TO CHECK FOR HP-GL MODEL NUMBERS
CCCCC IF(ISAVE.EQ.'HPGL')IDMODE(I)='GL  '
      IF(ISAVE.EQ.'LASE'.AND.IDMODE(I).EQ.'JET')IDMODE(I)='    '
      IF(K.GT.NUMARG)IDMODE(I)='    '
      K=K+1
      IF(K.LE.NUMARG)IDMOD2(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMOD2(I)='    '
      K=K+1
      IF(K.LE.NUMARG)IDMOD3(I)=IHARG(K)
      IF(K.GT.NUMARG)IDMOD3(I)='    '
C  FOLLOWING BLOCK ADDED TO CHECK FOR HPGL MODEL NUMBERS
      IF(ISAVE.EQ.'HPGL')THEN
        IDMOD3(I)=IDMOD2(I)
        IDMOD2(I)=IDMODE(I)
        IDMODE(I)='GL  '
      END IF
C  END CHANGES
CCCCC MARCH 1995.  ADD FOLLOWING 4 LINES
      IF(ISAVE.EQ.'EPS ')IDMANU(I)='POST'
      IF(ISAVE.EQ.'EPS ')IDMODE(I)='ENCA'
      IF(ISAVE.EQ.'ENCA')IDMANU(I)='POST'
      IF(ISAVE.EQ.'ENCA')IDMODE(I)='ENCA'
C
      CALL GRSEPP(I,
     1IPL1NU,
     1IPL2NU,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1IBUGO2,IFOUN2,IERROR)
CCCCC JUNE 1992.  DISTINGUISH BETWEEN ON AND OPEN
      IOPERA='OPEN'
      GOTO1179
CCCCC GOTO1180
C
 1180 CONTINUE
C
      IOPERA=IDPOWE(I)
C  FOLLOWING LINE ADDED MAU, 1990 (DEVICE ... CLOSE)
 1179 CONTINUE
C
C  FEBRUARY,1989.  SEPARATE UNITS FOR GRAPHICS AND ALPHANUMERIC OUTPUT.
C  SAME ON MOST SYSTEMS, BUT CDC NOS/VE REQUIRES DIFFERENT ATTRIBUTES
C  FOR GRAPHICS AND ALPANUMERIC OUTPUT.
CCCCC IGENNU=IPR
      IGENNU=IPRGR
C
      IF(I.EQ.1)THEN
        IGENID='SCRE'
        IF(IDMANU(1).EQ.'LATE'.AND.ICAPSW.EQ.'ON')THEN
          IGENNU=ICAPNU
          IPRGR=IGENNU
        ELSE
          IGENNU=IPRGR
        ENDIF
      ENDIF
      IF(I.EQ.2)IGENNU=IPL1NU
      IF(I.EQ.2)IGENID='PLO1'
C
      IF(I.EQ.3)IGENNU=IPL2NU
      IF(I.EQ.3)IGENID='PLO2'
C
      IF(I.GE.4)IGENNU=IDUNIT(I)
      IF(I.GE.4)IGENID='GENE'
C
      IGDFLG='OFF'
      IF(IDMANU(I).EQ.'GD  '.OR.IDMANU(I).EQ.'GDI ')IGDFLG='ON'
C
CCCCC IF(IGENNU.NE.IPR)
CCCCC IF(IGENNU.NE.IPRGR)
      CALL DPDEP2(IOPERA,IGENNU,IGENID,IGDFLG,
     1ICAPSW,
     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
      IF(IERROR.EQ.'YES')GOTO9000
C
CCCCC JUNE 1992.  FOLLOWINF LINE ADDED
      IF(IOPERA.EQ.'OPEN')GOTO2000
      IF(IOPERA.EQ.'ON')GOTO2000
      GOTO2090
 2000 CONTINUE
      IMANUF=IDMANU(I)
      IMODEL=IDMODE(I)
CCCCC AUGUST 1992.  FOLLOWING 2 LINES ADDED FOR HPGL LASERJET
      IMODE2=IDMOD2(I)
      IMODE3=IDMOD3(I)
      IGUNIT=IDUNIT(I)
C
C  FEBRUARY 2006: DEVICE 1 LATEX OUTPUT SHOULD GO TO CAPTURE
C                 FILE IF CAPTURE SWITCH IS ON.
C
      IF(IMANUF.EQ.'LATE' .AND. I.EQ.1 .AND. ICAPSW.EQ.'ON')THEN
        IGUNIT=ICAPNU
      ENDIF
C
      IBUGG4=IBUGO2
C  FOLLOWING LINE ADDED FEBRUARY, 1989 FOR POSTSCRIPT DEVICE
      ANUMVP=IDNVPP(I)
C  FOLLOWING LINE ADDED MARCH, 1990 FOR X11 DEVICE
      ANUMHP=IDNHPP(I)
CCCCC THE FOLLOWING 2 LINES WERE ADDED           MAY 1989
CCCCC TO FIX POSTSCRIPT TRANSLATION (ALAN)       MAY 1989
      IOFFSV=IDNVOF(I)
      IOFFSH=IDNHOF(I)
CCCCC JUNE 1992.  ONLY CALL FOR OPEN CASE (NOT FOR ON)
CCCCC CALL GRINDE
      IF(IOPERA.EQ.'OPEN')CALL GRINDE
CCCCC FOLLOWING THREE LINES ADDED MARCH, 1990.  X11 LIBRARY CAN
CCCCC DYNAMICALLY CHANGE THE NUMBER OF PICTURE POINTS.
      IF(IMANUF.NE.'X11'.AND.IMANUF.NE.'QWIN')GOTO2090
      IDNVPP(I)=ANUMVP
      IDNHPP(I)=ANUMHP
 2090 CONTINUE
C
      IFOUND='YES'
CCCCC THE FOLLOWING 3 LINES WERE ADDED   MAY 1992 (JJF)
      IF(NUMARG.GE.1)THEN
         IF(IARGT(1).EQ.'NUMB'.AND.IARG(1).EQ.3)GOTO1199
      ENDIF
      IF(IFEEDB.EQ.'OFF')GOTO1199
      IF(IDMANU(I).EQ.'LATE' .AND. I.EQ.1 .AND. ICAPSW.EQ.'ON')
     1GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IF(I.EQ.2)WRITE(ICOUT,1192)IPL1NA
 1192 FORMAT('            FILE NAME (LOCAL)--',A80)
      IF(I.EQ.2)CALL DPWRST('XXX','BUG ')
      IF(I.EQ.3)WRITE(ICOUT,1193)IPL2NA
 1193 FORMAT('            FILE NAME (LOCAL)--',A80)
      IF(I.EQ.3)CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF DPDEMN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGO2
 9013 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGG4,ISUBG4
 9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IOPERA,IMANUF,IMODEL
 9015 FORMAT('IOPERA,IMANUF,IMODEL = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFOUND,IERROR
 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
      WRITE(ICOUT,9041)IHARG(2),ISAVE,IDMANU(1),IDMODE(1)
 9041 FORMAT('IHARG(2),ISAVE,IDMANU(1),IDMODE(1) = ',
     1A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEPM(ICOM,IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IBUGO2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DEFINE A PEN MAP (I.E., ASSOCIATE A COLOR WITH AN INDEX
C              NUMBER FOR A DEVICE).  THIS COMMAND IS INTENDED FOR PEN
C              PLOTTERS HAVE PEN SLOTS WHICH CAN BE LOADED WITH WHATEVER
C              COLOR PEN THE LOCAL OPERATOR DESIRES.  DATAPLOT WILL USE
C              A DEFAULT MAPPING.  THIS COMMAND ALLOWS A USER CONFIGURABLE
C              MAPPING TO OVERRIDE THE DEFAULT.  CURRENTLY, THE HPGL, ZETA,
C              AND CALCOMP DEVICES ARE SUPPORTED.  THE OTHER 2 PLOTTERS
C              CURRENTLY SUPPORTED (HP 7221 AND TEKTRONIX 4662) ARE
C              RATHER OBSOLETE, SO DATAPLOT CODE HAS NOT BEEN UPDATED
C              TO SUPPORT THEM THIS WAY (I.E., ONLY THE DEFAULT MAPPING
C              AVAILABLE).
C     INPUT  ARGUMENTS--ICOM   (A  CHARACTER VECTOR)
C                     --IHARG  (A  CHARACTER VECTOR)
C                     --IHARG2 (A CHARACTER VECTOR)
C                     --IARGT  (A CHARACTER VECTOR)
C                     --IARG   (A CHARACTER VECTOR)
C                     --NUMARG
C     OUTPUT ARGUMENTS--
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1991.  REGIS SUPPORT
C     UPDATED         --JUNE      1991.  ADD SHOW X11 COLORS COMMAND
C     UPDATED         --APRIL     1992.  SHORTEN COLORS AFTER IZETPM(.)
C                                        TO 4 CHARACTERS (BUT NO NOTE NOTED)
C     UPDATED         --AUGUST    1992.  DATAPLOT COLORS HAVE BEEN
C                                        REDEFINED IN A CONSISTENT
C                                        MANNER FOR ALL DEVICES.
C                                        UPDATE SHOW COLORS COMMANDS TO
C                                        REFLECT THIS.
C     UPDATED         --SEPTEMBER 1993.  SPLIT MULTI-LINE FORMATS
C     UPDATED         --MARCH     1995.  ? AS SYNONYM FOR SHOW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICOM
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICOL
C
      CHARACTER*40 ICPREH
      CHARACTER*4 IRESP
C
      CHARACTER*4 IGRAY
      CHARACTER*4 IDEV
      CHARACTER*4 IDEV2
C
CCCCC CHARACTER*25 IRGCLR(64)
CCCCC CHARACTER*8 IRGNAM(64)
CCCCC CHARACTER*25 IXCLR(67)
CCCCC CHARACTER*8 IXNAM(67)
      CHARACTER*4 CJUNK
      PARAMETER(MAXCLR=89)
      CHARACTER*25 ICLR(MAXCLR)
      CHARACTER*8 INAM(MAXCLR)
      INTEGER J4027(MAXCLR)
      INTEGER J4105(MAXCLR)
      INTEGER JPLOT4(MAXCLR)
      INTEGER JPLOT8(MAXCLR)
      INTEGER J2622(MAXCLR)
      INTEGER JCGM(MAXCLR)
      INTEGER JSUN(MAXCLR)
      INTEGER JX11(MAXCLR)
      INTEGER JPC(MAXCLR)
      INTEGER JREGIS(MAXCLR)
      INTEGER JTEMP(MAXCLR)
      INTEGER JREG2(64)
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCODV.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  TEKTRONIX 4027
C
      DATA (J4027(I),I=1,MAXCLR)/
     1  0,  7,  1,  3,  2,  6,  5,  3,  4,  4,
     2  2,  3,  3,  1,  7,  0,  3,  5,  3,  1,
     3  3,  2,  6,  3,  6,  4,  2,  4,  4,  7,
     4  1,  4,  0,  3,  2,  1,  3,  3,  2,  4,
     5  6,  2,  3,  2,  6,  6,  3,  3,  5,  6,
     6  2,  1,  6,  6,  4,  2,  6,  3,  3,  2,
     7  3,  4,  4,  6,  6,  4,  2,  3,  3,  3,
     8  3,  3,  3,  3,  2,  2,  2,  4,  4,  4,
     9  5,  5,  5,  1,  1,  1,  6,  6,  6/
C  TEKTRONIX 4105, GENERAL, GENERAL CODED
C
      DATA (J4105(I),I=1,MAXCLR)/
     1  1,  0,  2,  4,  3,  6,  2,  5,  7,  7,
     2  3,  4,  4,  2,  0,  1,  4,  2,  4,  2,
     3  4,  3,  6,  4,  6,  7,  3,  7,  7,  0,
     4  2,  7,  1,  4,  3,  2,  4,  4,  3,  7,
     5  6,  3,  4,  3,  6,  6,  4,  4,  2,  6,
     6  3,  2,  6,  6,  7,  3,  6,  4,  4,  3,
     7  4,  7,  7,  6,  6,  7,  3,  5,  4,  4,
     8  4,  5,  5,  5,  3,  3,  3,  7,  7,  7,
     9  7,  7,  7,  2,  2,  2,  6,  6,  6/
C
C  PLOTTERS WITH 4 PENS (TEKTRONIX 4662, HP-7221, CALCOMP, ZETA, HP-GL)
C
      DATA (JPLOT4(I),I=1,MAXCLR)/
     1  1,  1,  2,  3,  4,  4,  2,  3,  2,  2,
     2  4,  3,  3,  2,  1,  1,  3,  2,  3,  2,
     3  3,  4,  2,  3,  2,  2,  4,  2,  2,  1,
     4  2,  2,  1,  3,  4,  2,  3,  3,  4,  2,
     5  2,  4,  3,  4,  2,  2,  3,  3,  2,  2,
     6  4,  2,  2,  2,  2,  4,  2,  3,  3,  4,
     7  3,  2,  2,  2,  2,  2,  4,  3,  3,  3,
     8  3,  3,  3,  3,  4,  4,  4,  2,  2,  2,
     9  2,  2,  2,  2,  2,  2,  4,  4,  4/
C
C  PLOTTERS WITH 8 PENS (HP-GL, CALCOMP, ZETA)
C
      DATA (JPLOT8(I),I=1,MAXCLR)/
     1  1,  1,  2,  3,  4,  5,  6,  7,  8,  8,
     2  4,  7,  3,  2,  1,  1,  3,  8,  3,  2,
     3  3,  4,  5,  3,  5,  8,  4,  8,  8,  1,
     4  2,  8,  1,  3,  4,  5,  7,  3,  4,  8,
     5  5,  4,  7,  4,  5,  5,  3,  3,  6,  5,
     6  4,  2,  5,  5,  8,  4,  5,  7,  3,  4,
     7  3,  8,  8,  5,  5,  8,  4,  7,  3,  3,
     8  3,  7,  7,  7,  4,  4,  4,  8,  8,  8,
     9  6,  6,  6,  2,  2,  2,  5,  5,  5/
C
C  HP-2622 AND RELATED TERMINALS
C
      DATA (J2622(I),I=1,MAXCLR)/
     1  7,  0,  1,  4,  2,  5,  3,  6,  3,  3,
     2  2,  6,  4,  1,  0,  7,  6,  3,  4,  1,
     3  4,  2,  5,  4,  5,  3,  2,  3,  3,  0,
     4  1,  3,  7,  6,  2,  5,  6,  4,  2,  3,
     5  5,  2,  6,  2,  5,  5,  4,  4,  3,  5,
     6  2,  1,  5,  5,  3,  2,  5,  6,  4,  2,
     7  4,  3,  3,  5,  5,  3,  2,  6,  4,  4,
     8  4,  6,  6,  6,  2,  2,  2,  3,  3,  3,
     9  3,  3,  3,  1,  1,  1,  5,  5,  5/
C
C  DIRECT RGB DEVICES (CGM, POSTSCRIPT)
C
      DATA (JCGM(I),I=1,MAXCLR)/
     1  1,  2,  3,  4,  5,  6,  7,  8,  9, 10,
     2 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
     3 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
     4 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
     5 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
     6 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
     7 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
     8 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,
     9 81, 82, 83, 84, 85, 86, 87, 88, 89/
C
C  SUN
C
      DATA (JSUN(I),I=1,MAXCLR)/
     1  7,  5,  1,  3,  2,  6,  4,  3,  4,  4,
     2  2,  3,  3,  1,  0,  7,  3,  4,  3,  1,
     3  3,  2,  6,  3,  6,  4,  2,  4,  4,  0,
     4  1,  4,  7,  3,  2,  6,  3,  3,  2,  4,
     5  6,  2,  3,  2,  6,  6,  3,  3,  1,  6,
     6  2,  1,  6,  6,  4,  2,  6,  3,  3,  2,
     7  3,  4,  4,  6,  6,  4,  2,  3,  3,  3,
     8  3,  3,  3,  3,  2,  2,  2,  4,  4,  4,
     9  4,  4,  4,  1,  1,  1,  6,  6,  6/
C
C  X11
C
      DATA (JX11(I),I=1,MAXCLR)/
     1  1,  0,  4,  5,  2,  6,  8,  7,  3,  9,
     2 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
     3 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
     4 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
     5 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,
     6 50, 51, 52, 53, 54, 55, 56, 57, 58, 59,
     7 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
     8 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
     9 80, 81, 82, 83, 84, 85, 86, 87, 88/
C
C  REGIS
C
      DATA (JREGIS(I),I=1,MAXCLR)/
     1 62,  3, 47,  4, 23, 39, 41, 18, 63, 64,
     2 24,  8, 60, 51, 35, 37,  1,  3,  5, 17,
     3  6, 25, 43,  7, 57, 19, 26, 20, 21, 35,
     4 48, 38, 36,  9, 27, 40,  2, 10, 28, 22,
     5 44, 29, 11, 30, 58, 49, 12, 13, 50, 42,
     6 31, 45, 46, 57, 52, 32, 53, 14, 15, 33,
     7 16, 54, 55, 56, 59, 61, 34, 18,  4,  4,
     8  4, 18, 18, 18, 23, 23, 23, 63, 63, 63,
     9 41, 41, 41, 47, 47, 47, 39, 39, 39/
      DATA (JREG2(I),I=1,64)/
     1 17, 37,  2,  4, 19, 21, 24, 12, 34, 38,
     2 43, 47, 48, 58, 59, 60, 20,  8, 26, 28,
     3 29, 40,  5, 11, 22, 27, 35, 39, 42, 44,
     4 51, 56, 60, 67, 15, 33, 16, 32,  6, 36,
     5  7, 50, 23, 41, 52, 53,  3, 31, 46, 49,
     6 14, 55, 57, 62, 63, 64, 25, 45, 65, 13,
     7 66,  1,  9, 10/
C
C  IBM-PC
C
      DATA (JPC(I),I=1,MAXCLR)/
     1 15,  0,  4,  1,  2,  5, 14,  3, 14, 14,
     2  2,  9,  1,  4,  8, 10,  3,  6,  9, 12,
     3  1,  2,  5,  1,  5, 14,  2, 14, 14,  7,
     4 12, 14, 10,  9,  2,  5, 11,  9,  2, 14,
     5  5,  2,  9,  2, 13,  5,  1,  1,  4, 13,
     6  2,  4,  5,  5, 14,  2,  5, 11,  1,  2,
     7  1,  6, 14,  5,  5, 14,  2, 11,  1,  1,
     8  1,  3,  3,  3,  2,  2,  2, 14, 14, 14,
     9 14, 14, 14,  4,  4,  4,  5,  5,  5/
C
C
C  COMMENT OUT FOLLOWING, USE SAME TABLES FOR ALL DEVICES
C
CCCCC DATA (IRGCLR(I),I=1,15)/
CCCCC1 'Aquamarine',
CCCCC2 'Aquamarine, Medium',
CCCCC3 'Black',
CCCCC4 'Blue',
CCCCC5 'Blue, Cadet',
CCCCC6 'Blue, Cornflower',
CCCCC7 'Blue, Dark Slate',
CCCCC8 'Blue, Light',
CCCCC9 'Blue, Light Steel',
CCCCC* 'Blue, Medium',
CCCCC1 'Blue, Medium Slate',
CCCCC2 'Blue, Midnight',
CCCCC3 'Blue, Navy',
CCCCC4 'Blue, Sky',
CCCCC5 'Blue, Slate'/
CCCCC DATA (IRGCLR(I),I=16,30)/
CCCCC1 'Blue, Steel',
CCCCC2 'Coral',
CCCCC3 'Cyan',
CCCCC4 'Firebrick',
CCCCC5 'Gold',
CCCCC6 'Goldenrod',
CCCCC7 'Goldenrod, Medium',
CCCCC8 'Green',
CCCCC9 'Green, Dark',
CCCCC* 'Green, Dark Olive',
CCCCC1 'Green, Forest',
CCCCC2 'Green, Lime',
CCCCC3 'Green, Medium Forest',
CCCCC4 'Green, Medium Sea',
CCCCC5 'Green, Medium Spring'/
CCCCC DATA (IRGCLR(I),I=31,45)/
CCCCC1 'Greeen, Pale',
CCCCC2 'Green, Sea',
CCCCC3 'Green, Spring',
CCCCC4 'Green, Yellow',
CCCCC5 'Grey, Dark Slate',
CCCCC6 'Grey, Dim',
CCCCC7 'Grey, Light',
CCCCC8 'Khaki',
CCCCC9 'Magenta',
CCCCC* 'Maroon',
CCCCC1 'Orange',
CCCCC2 'Orchid',
CCCCC3 'Orchid, Dark',
CCCCC4 'Orchid, Medium',
CCCCC5 'Pink'/
CCCCC DATA (IRGCLR(I),I=46,60)/
CCCCC1 'Plum',
CCCCC2 'Red',
CCCCC3 'Red, Indian',
CCCCC4 'Red, Medium Violet',
CCCCC5 'Red, Orange',
CCCCC6 'Red, Violet',
CCCCC7 'Salmon',
CCCCC8 'Sienna',
CCCCC9 'Tan',
CCCCC* 'Thistle',
CCCCC1 'Turquoise',
CCCCC2 'Turqoise, Dark',
CCCCC3 'Turqoise, Medium',
CCCCC4 'Violet',
CCCCC5 'Violet, Blue'/
CCCCC DATA (IRGCLR(I),I=61,64)/
CCCCC1 'Wheat',
CCCCC2 'White',
CCCCC3 'Yellow',
CCCCC4 'Yellow, Green'/
C
CCCCC DATA (IRGNAM(I),I=1,15)/
CCCCC1 'AQUA',
CCCCC2 '2',
CCCCC3 'BLACK',
CCCCC4 'BLUE',
CCCCC5 '5',
CCCCC6 '6',
CCCCC7 '7',
CCCCC8 '8',
CCCCC9 '9',
CCCCC* '10',
CCCCC1 '11',
CCCCC2 '12',
CCCCC3 '13',
CCCCC4 '14',
CCCCC5 '15'/
CCCCC DATA (IRGNAM(I),I=16,30)/
CCCCC1 '16',
CCCCC2 'CORAL',
CCCCC3 'CYAN',
CCCCC4 'FIREBRIC',
CCCCC5 'GOLD',
CCCCC6 '21',
CCCCC7 '22',
CCCCC8 'GREEN',
CCCCC9 '24',
CCCCC* '25',
CCCCC1 '26',
CCCCC2 '27',
CCCCC3 '28',
CCCCC4 '29',
CCCCC5 '30'/
CCCCC DATA (IRGNAM(I),I=31,45)/
CCCCC1 '31',
CCCCC2 '32',
CCCCC3 '33',
CCCCC4 '34',
CCCCC5 'GREY',
CCCCC6 '36',
CCCCC7 '37',
CCCCC8 'KHAKI',
CCCCC9 'MAGENTA',
CCCCC* 'MAROON',
CCCCC1 'ORANGE',
CCCCC2 'ORCHID',
CCCCC3 '43',
CCCCC4 '44',
CCCCC5 'PINK'/
CCCCC DATA (IRGNAM(I),I=46,60)/
CCCCC1 'PLUM',
CCCCC2 'RED',
CCCCC3 '48',
CCCCC4 '49',
CCCCC5 '50',
CCCCC6 '51',
CCCCC7 'SALMON',
CCCCC8 'SIENNA',
CCCCC9 'TAN',
CCCCC* 'THISTLE',
CCCCC1 'TURQUOIS',
CCCCC2 '57',
CCCCC3 '58',
CCCCC4 'VIOLET',
CCCCC5 '60'/
CCCCC DATA (IRGNAM(I),I=61,64)/
CCCCC1 'WHEAT',
CCCCC2 'WHITE',
CCCCC3 'YELLOW',
CCCCC4 '64'/
C
C  AUGUST 1992.
C  CHANGE IXCLR TO ICLR, IXNAM TO INAM, REORDER TO MATCH NEW ORDER.
C
CCCCC DATA (IXCLR(I),I=1,15)/
      DATA (ICLR(I),I=1,15)/
     1 'White',
     2 'Black',
     3 'Red',
     4 'Blue',
     5 'Green',
     6 'Magenta',
     7 'Orange',
     8 'Cyan',
     9 'Yellow',
     * 'Yellow Green',
     1 'Dark Green',
     2 'Light Blue',
     3 'Blue Violet',
     4 'Violet Red',
     5 'Dark Slate Gray'/
CCCCC DATA (IXCLR(I),I=16,30)/
      DATA (ICLR(I),I=16,30)/
     1 'Light Gray',
     2 'Aquamarine',
     3 'Brown',
     4 'Cadet Blue',
     5 'Coral',
     6 'Cornflower Blue',
     7 'Dark Olive Green',
     8 'Dark Orchid',
     9 'Dark Slate Blue',
     * 'Dark Turquoise',
     1 'Firebrick',
     2 'Forest Green',
     3 'Gold',
     4 'Goldenrod',
     5 'Gray'/
CCCCC DATA (IXCLR(I),I=31,45)/
      DATA (ICLR(I),I=31,45)/
     1 'Indian Red',
     2 'Khaki',
     3 'Dim Gray',
     4 'Light Blue Steel',
     5 'Lime Green',
     6 'Maroon',
     7 'Medium Aquamarine',
     8 'Medium Blue',
     9 'Medium Forest Green',
     * 'Medium Goldenrod',
     1 'Medium Orchid',
     2 'Medium Sea Green',
     3 'Medium Slate Blue',
     4 'Medium Spring Green',
     5 'Medium Turquoise'/
CCCCC DATA (IXCLR(I),I=46,60)/
      DATA (ICLR(I),I=46,60)/
     1 'Medium Violet Red',
     2 'Midnight Blue',
     3 'Navy',
     4 'Orange Red',
     5 'Orchid',
     6 'Pale Green',
     7 'Pink',
     8 'Plum',
     9 'Purple',
     * 'Salmon',
     1 'Sea Green',
     2 'Sienna',
     3 'Sky Blue',
     4 'Slate Blue',
     5 'Spring Green'/
CCCCC DATA (IXCLR(I),I=61,66)/
      DATA (ICLR(I),I=61,75)/
     1 'Steel Blue',
     2 'Tan',
     3 'Thistle',
     4 'Turquoise',
     5 'Violet',
     6 'Wheat',
     7 'Green Yellow',
     8 'Light Cyan',
     9 'Blue2',
     * 'Blue3',
     1 'Blue4',
     2 'Cyan2',
     3 'Cyan3',
     4 'Cyan4',
     5 'Green2'/
      DATA (ICLR(I),I=76,MAXCLR)/
     1 'Green3',
     2 'Green4',
     3 'Yellow2',
     4 'Yellow3',
     5 'Yellow4',
     6 'Orange2',
     7 'Orange3',
     8 'Orange4',
     9 'Red2',
     * 'Red3',
     1 'Red4',
     2 'Magenta2',
     3 'Magenta3',
     4 'Magenta4'/
C
CCCCC DATA (IXNAM(I),I=1,15)/
      DATA (INAM(I),I=1,15)/
     1 'WHITE',
     2 'BLACK',
     3 'RED',
     4 'BLUE',
     5 'GREEN',
     6 'MAGENTA',
     7 'ORANGE',
     8 'CYAN',
     9 'YELLOW',
     * 'YGRE',
     1 'DGRE',
     2 'LBLU',
     3 'VBLU',
     4 'VRED',
     5 'DGRA'/
CCCCC DATA (IXNAM(I),I=16,30)/
      DATA (INAM(I),I=16,30)/
     1 'LGRA',
     2 'AQUA',
     3 'BROWN',
     4 'CABL',
     5 'CORAL',
     6 'CBLU',
     7 'DOGR',
     8 'DORC',
     9 'DSBL',
     * 'DTUR',
     1 'FIRE',
     2 'FGRE',
     3 'GOLD',
     4 'GLDR',
     5 'GRAY'/
CCCCC DATA (IXNAM(I),I=31,45)/
      DATA (INAM(I),I=31,45)/
     1 'IRED',
     2 'KHAKI',
     3 'DMGR',
     4 'LSBL',
     5 'LGRE',
     6 'MAROON',
     7 'MAQU',
     8 'MBLU',
     9 'MFGR',
     * 'MGLD',
     1 'MORC',
     2 'MSGR',
     3 'MSBL',
     4 'MSPG',
     5 'MTUR'/
CCCCC DATA (IXNAM(I),I=46,60)/
      DATA (INAM(I),I=46,60)/
     1 'MVRD',
     2 'MDBL',
     3 'NAVY',
     4 'ORED',
     5 'ORCHID',
     6 'PGRE',
     7 'PINK',
     8 'PLUM',
     9 'PURPLE',
     * 'SALMON',
     1 'SGRE',
     2 'SIENNA',
     3 'SKBL',
     4 'SBLU',
     5 'SPGR'/
CCCCC DATA (IXNAM(I),I=61,66)/
      DATA (INAM(I),I=61,75)/
     1 'STBL',
     2 'TAN',
     3 'THISTLE',
     4 'TURQ',
     5 'VIOLET',
     6 'WHEAT',
     7 'GYEL',
     8 'LCYA',
     9 'BLU2',
     * 'BLU3',
     1 'BLU4',
     2 'CYA2',
     3 'CYA3',
     4 'CYA4',
     5 'GRE2'/
      DATA (INAM(I),I=76,MAXCLR)/
     1 'GRE3',
     2 'GRE4',
     3 'YEL2',
     4 'YEL3',
     5 'YEL4',
     6 'ORA2',
     7 'ORA3',
     8 'ORA4',
     9 'RED2',
     * 'RED3',
     1 'RED4',
     2 'MAG2',
     3 'MAG3',
     4 'MAG4'/
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
      IBUGG4='OFF'
      ISUBG4='-999'
C
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPM')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF DPDEPM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGO2
   53 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFOUND,IERROR
   60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
      WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
   71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
      WRITE(ICOUT,72)IHPGPF
   72 FORMAT('IHPGPF=',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IF(ICOM.EQ.'HPGL')GOTO1100
      IF(ICOM.EQ.'HP-G')GOTO1100
      IF(ICOM.EQ.'ZETA')GOTO2100
      IF(ICOM.EQ.'CALC')GOTO3100
      IF(ICOM.EQ.'REGI')GOTO4100
      IF(ICOM.EQ.'X11')GOTO5100
C  ADD FOLLOWING LINE AUGUST 1992.
      IF(ICOM.EQ.'SHOW')GOTO6100
C
C  *****************************************
C  **  HPGL CASE                          **
C  *****************************************
C
 1100 CONTINUE
      IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO1110
      IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO1110
      IF(IHARG(1).EQ.'PEN')GOTO1120
      IF(IHARG(1).EQ.'MAP')GOTO1120
      IF(IHARG(1).EQ.'COLO')GOTO1120
 
C
 1110 CONTINUE
      IARGCL=3
      IARGIN=4
      GOTO1190
C
 1120 CONTINUE
      IARGCL=2
      IARGIN=3
      GOTO1190
C
 1190 CONTINUE
      IFOUND='YES'
      IF(NUMARG.LT.IARGCL)GOTO1910
      IF(IHARG(IARGCL).EQ.'AUTO')GOTO1500
      IF(IHARG(IARGCL).EQ.'DEFA')GOTO1500
      IF(IHARG(IARGCL).EQ.'ON  ')GOTO1600
      IF(IHARG(IARGCL).EQ.'OFF ')GOTO1700
      IF(IHARG(IARGCL).EQ.'LIST')GOTO1800
      IF(IHARG(IARGCL).EQ.'SHOW')GOTO1800
      IF(IHARG(IARGCL).EQ.'?   ')GOTO1800
      IF(IHARG(IARGCL).EQ.'PRIN')GOTO1800
      IF(NUMARG.LT.IARGIN)GOTO1920
C
      ICOL=IHARG(IARGCL)
      INDEX=IARG(IARGIN)
      IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO1930
      IHPGPM(INDEX)=ICOL
      IHPGPF='ON'
      IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,1490)IHPGPM(INDEX),INDEX
 1490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR HP-GL')
      IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1500 CONTINUE
      IF(IHPGCL.LE.4)THEN
        IHPGPM(1)='BLACK'
        IHPGPM(2)='RED '
        IHPGPM(3)='BLUE'
        IHPGPM(4)='GREEN'
        DO1510J=5,16
        ITEMP=MOD(J-1,4)+1
        IHPGPM(J)=IHPGPM(ITEMP)
 1510   CONTINUE
      ELSE
        IHPGPM(1)='BLACK'
        IHPGPM(2)='RED '
        IHPGPM(3)='BLUE'
        IHPGPM(4)='GREEN'
        IHPGPM(5)='MAGENTA'
        IHPGPM(6)='ORANGE'
        IHPGPM(7)='CYAN'
        IHPGPM(8)='YELLOW'
        DO1520J=9,16
        ITEMP=J-8
        IHPGPM(J)=IHPGPM(ITEMP)
 1520   CONTINUE
      END IF
      GOTO9000
C
 1600 CONTINUE
      IHPGPF='ON'
      GOTO9000
C
 1700 CONTINUE
      IHPGPF='OFF'
      GOTO9000
C
 1800 CONTINUE
      WRITE(ICOUT,1805)
 1805 FORMAT('FOR THE HP-GL PENPLOTTER:')
      CALL DPWRST('XXX','BUG ')
      DO1810I=1,16
      WRITE(ICOUT,1811)IHPGPM(I),I
      CALL DPWRST('XXX','BUG ')
 1810 CONTINUE
 1811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
      GOTO9000
C
 1910 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1911)
 1911 FORMAT('NO COLOR SPECIFIED FOR HPGL PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1920 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1921)
 1921 FORMAT('NO INDEX SPECIFIED FOR HPGL PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1930 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,1931)
 1931 FORMAT('INVALID INDEX SPECIFIED FOR HPGL PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C  *****************************************
C  **  ZETA CASE                          **
C  *****************************************
C
 2100 CONTINUE
      IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO2110
      IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO2110
      IF(IHARG(1).EQ.'PEN')GOTO2120
      IF(IHARG(1).EQ.'MAP')GOTO2120
      IF(IHARG(1).EQ.'MAP')GOTO2120
      IF(IHARG(1).EQ.'COLO')GOTO2120
C
 2110 CONTINUE
      IARGCL=3
      IARGIN=4
      GOTO2190
C
 2120 CONTINUE
      IARGCL=2
      IARGIN=3
      GOTO2190
C
 2190 CONTINUE
      IFOUND='YES'
      IF(NUMARG.LT.IARGCL)GOTO2910
      IF(IHARG(IARGCL).EQ.'AUTO')GOTO2500
      IF(IHARG(IARGCL).EQ.'DEFA')GOTO2500
      IF(IHARG(IARGCL).EQ.'ON  ')GOTO2600
      IF(IHARG(IARGCL).EQ.'OFF ')GOTO2700
      IF(IHARG(IARGCL).EQ.'LIST')GOTO2800
      IF(IHARG(IARGCL).EQ.'SHOW')GOTO2800
      IF(IHARG(IARGCL).EQ.'?   ')GOTO2800
      IF(IHARG(IARGCL).EQ.'PRIN')GOTO2800
      IF(NUMARG.LT.IARGIN)GOTO2920
C
      ICOL=IHARG(IARGCL)
      INDEX=IARG(IARGIN)
      IF(INDEX.LT.1.OR.INDEX.GT.26)GOTO2930
      IZETPM(INDEX)=ICOL
      IZETPF='ON'
      IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,2490)IZETPM(INDEX),INDEX
 2490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR ZETA')
      IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 2500 CONTINUE
      IF(IZETCL.LE.4)THEN
        IZETPM(1)='BLAC'
        IZETPM(2)='RED '
        IZETPM(3)='BLUE'
        IZETPM(4)='GREE'
        DO2510J=5,16
        ITEMP=MOD(J-1,4)+1
        IZETPM(J)=IZETPM(ITEMP)
 2510   CONTINUE
      ELSE
        IZETPM(1)='BLAC'
        IZETPM(2)='RED '
        IZETPM(3)='BLUE'
        IZETPM(4)='GREE'
        IZETPM(5)='MAGE'
        IZETPM(6)='ORAN'
        IZETPM(7)='CYAN'
        IZETPM(8)='YELL'
        DO2520J=9,16
        ITEMP=J-8
        IZETPM(J)=IZETPM(ITEMP)
 2520   CONTINUE
      END IF
      GOTO9000
C
 2600 CONTINUE
      IZETPF='ON'
      GOTO9000
C
 2700 CONTINUE
      IZETPF='OFF'
      GOTO9000
C
 2800 CONTINUE
      WRITE(ICOUT,2805)
 2805 FORMAT('FOR THE ZETA PENPLOTTER:')
      CALL DPWRST('XXX','BUG ')
      DO2810I=1,16
      WRITE(ICOUT,2811)IZETPM(I),I
      CALL DPWRST('XXX','BUG ')
 2810 CONTINUE
 2811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
      GOTO9000
C
 2910 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,2911)
 2911 FORMAT('NO COLOR SPECIFIED FOR ZETA PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 2920 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,2921)
 2921 FORMAT('NO INDEX SPECIFIED FOR ZETA PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 2930 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,2931)
 2931 FORMAT('INVALID INDEX SPECIFIED FOR ZETA PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C  *****************************************
C  **  CALCOMP CASE                          **
C  *****************************************
C
 3100 CONTINUE
      IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO3110
      IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO3110
      IF(IHARG(1).EQ.'PEN')GOTO3120
      IF(IHARG(1).EQ.'MAP')GOTO3120
      IF(IHARG(1).EQ.'MAP')GOTO3120
      IF(IHARG(1).EQ.'COLO')GOTO3120
C
 3110 CONTINUE
      IARGCL=3
      IARGIN=4
      GOTO3390
C
 3120 CONTINUE
      IARGCL=2
      IARGIN=3
      GOTO3390
C
 3390 CONTINUE
      IFOUND='YES'
      IF(NUMARG.LT.IARGCL)GOTO3910
      IF(IHARG(IARGCL).EQ.'AUTO')GOTO3500
      IF(IHARG(IARGCL).EQ.'DEFA')GOTO3500
      IF(IHARG(IARGCL).EQ.'ON  ')GOTO3600
      IF(IHARG(IARGCL).EQ.'OFF ')GOTO3700
      IF(IHARG(IARGCL).EQ.'LIST')GOTO3800
      IF(IHARG(IARGCL).EQ.'PRIN')GOTO3800
      IF(IHARG(IARGCL).EQ.'SHOW')GOTO3800
      IF(IHARG(IARGCL).EQ.'?   ')GOTO3800
      IF(NUMARG.LT.IARGIN)GOTO3920
C
      ICOL=IHARG(IARGCL)
      INDEX=IARG(IARGIN)
      IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO3930
      ICALPM(INDEX)=ICOL
      ICALPF='ON'
      IF(IFEEDB.EQ.'OFF')WRITE(ICOUT,3490)ICALPM(INDEX),INDEX
 3490 FORMAT('COLOR ',A4,' WILL SELECT PEN ',I2,' FOR CALCOMP ')
      IF(IFEEDB.EQ.'OFF')CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 3500 CONTINUE
      IF(ICALCL.LE.4)THEN
        ICALPM(1)='BLAC'
        ICALPM(2)='RED '
        ICALPM(3)='GREE'
        ICALPM(4)='BLUE'
        DO3510J=5,16
        ITEMP=MOD(J-1,4)+1
        ICALPM(J)=ICALPM(ITEMP)
 3510   CONTINUE
      ELSE
        ICALPM(1)='BLAC'
        ICALPM(2)='RED '
        ICALPM(3)='GREE'
        ICALPM(4)='BLUE'
        ICALPM(5)='MAGE'
        ICALPM(6)='ORAN'
        ICALPM(7)='CYAN'
        ICALPM(8)='YELL'
        DO3520J=9,16
        ITEMP=J-8
        ICALPM(J)=ICALPM(ITEMP)
 3520   CONTINUE
      END IF
      GOTO9000
C
 3600 CONTINUE
      ICALPF='ON'
      GOTO9000
C
 3700 CONTINUE
      ICALPF='OFF'
      GOTO9000
C
 3800 CONTINUE
      WRITE(ICOUT,3805)
 3805 FORMAT('FOR THE CALCOMP PENPLOTTER:')
      CALL DPWRST('XXX','BUG ')
      DO3810I=1,16
      WRITE(ICOUT,3811)ICALPM(I),I
      CALL DPWRST('XXX','BUG ')
 3810 CONTINUE
 3811 FORMAT('COLOR ',A8,' SET TO PEN ',I2)
      GOTO9000
C
 3910 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,3911)
 3911 FORMAT('NO COLOR SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 3920 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,3921)
 3921 FORMAT('NO INDEX SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 3930 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,3931)
 3931 FORMAT('INVALID INDEX SPECIFIED FOR CALCOMP PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C  *****************************************
C  **  REGIS CASE                         **
C  *****************************************
C
 4100 CONTINUE
C
      IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO4110
      IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO4110
      IF(IHARG(1).EQ.'PEN')GOTO4120
      IF(IHARG(1).EQ.'MAP')GOTO4120
      IF(IHARG(1).EQ.'COLO')GOTO4120
 
C
 4110 CONTINUE
      IARGCL=3
      IARGIN=4
      GOTO4190
C
 4120 CONTINUE
      IARGCL=2
      IARGIN=3
      GOTO4190
C
 4190 CONTINUE
      IFOUND='YES'
      IF(NUMARG.LT.IARGCL)GOTO4910
      IF(IHARG(IARGCL).EQ.'AUTO')GOTO4500
      IF(IHARG(IARGCL).EQ.'DEFA')GOTO4500
      IF(IHARG(IARGCL).EQ.'ON  ')GOTO4500
      IF(IHARG(IARGCL).EQ.'OFF ')GOTO9000
      IF(IHARG(IARGCL).EQ.'LIST')GOTO4800
      IF(IHARG(IARGCL).EQ.'SHOW')GOTO4800
      IF(IHARG(IARGCL).EQ.'?   ')GOTO4800
      IF(IHARG(IARGCL).EQ.'PRIN')GOTO4800
      IF(NUMARG.LT.IARGIN)GOTO4920
C
      ICOL=IHARG(IARGCL)
      INDEX=IARG(IARGIN)
      IF(INDEX.LT.1.OR.INDEX.GT.16)GOTO4930
C
C  AUGUST 1992.  FOLLOWING LIST MODIFIED TO REFLECT CURRENTLY
C  SUPPORTED NAMES AND INDICES.
C
      DO4150I=1,MAXCLR
        IF(ICOL.EQ.INAM(I)(1:4))THEN
          JINDEX=I-1
          GOTO4159
        ENDIF
 4150 CONTINUE
      IF(ICOL.EQ.'DGRY')JINDEX=14
      IF(ICOL.EQ.'LGRY')JINDEX=15
      IF(ICOL.EQ.'GREY')JINDEX=29
      IF(ICOL.EQ.'LRED')JINDEX=83
      IF(ICOL.EQ.'LMAG')JINDEX=86
      IF(ICOL.EQ.'SKYB')JINDEX=57
 4159 CONTINUE
C
C  CHECK FOR INDEX (0 THROUGH MAXCLR-1)
C
      CJUNK='    '
      DO4191I=0,9
        WRITE(CJUNK(1:1),'(I1)')I
        IF(ICOL(1:4).EQ.CJUNK(1:4))THEN
          JINDEX=I
          GOTO4194
        ENDIF
 4191 CONTINUE
 4194 CONTINUE
      CJUNK='    '
      DO4196I=10,MAXCLR-1
        WRITE(CJUNK(1:2),'(I2)')I
        IF(ICOL(1:4).EQ.CJUNK(1:4))THEN
          JINDEX=I
          GOTO4199
        ENDIF
 4196 CONTINUE
 4199 CONTINUE
C
C  CHECK FOR GREY SCALE (G0 - G100)
C
      IF(ICOL.EQ.'G0')JINDEX=1
      IF(ICOL.EQ.'G100')JINDEX=0
      IF(ICOL(1:1).EQ.'G')THEN
        CJUNK='    '
        DO4181I=1,9
          WRITE(CJUNK(1:1),'(I1)')I
          IF(ICOL(2:4).EQ.CJUNK(1:3))THEN
            JINDEX=-I
            GOTO4184
          ENDIF
 4181   CONTINUE
 4184   CONTINUE
        CJUNK='    '
        DO4186I=10,99
          WRITE(CJUNK(1:2),'(I2)')I
          IF(ICOL(2:4).EQ.CJUNK(1:3))THEN
            JINDEX=-I
            GOTO4189
           ENDIF
 4186   CONTINUE
 4189   CONTINUE
      ENDIF
      IF(JINDEX.LT.0)JINDEX=1
C
CCCCC IREGPM(INDEX)=JCOL
      IREGPM(INDEX)=JREGIS(JINDEX)
      IF(IFEEDB.EQ.'ON')WRITE(ICOUT,4490)INDEX,ICOL
 4490 FORMAT('REGIS WILL USE COLOR MAP ',I2,' FOR COLOR ',A4)
      IF(IFEEDB.EQ.'ON')CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 4500 CONTINUE
CCCCC IREGPM(1)=62
CCCCC IREGPM(2)=63
CCCCC IREGPM(3)=47
CCCCC IREGPM(4)=3
CCCCC IREGPM(5)=23
CCCCC IREGPM(6)=18
CCCCC IREGPM(7)=4
CCCCC IREGPM(8)=41
CCCCC IREGPM(9)=59
CCCCC IREGPM(10)=39
CCCCC IREGPM(11)=64
CCCCC IREGPM(12)=54
CCCCC IREGPM(13)=20
CCCCC IREGPM(14)=51
CCCCC IREGPM(15)=37
CCCCC IREGPM(16)=35
      IREGPM(1)=1
      IREGPM(2)=9
      IREGPM(3)=3
      IREGPM(4)=2
      IREGPM(5)=5
      IREGPM(6)=8
      IREGPM(7)=4
      IREGPM(8)=7
      IREGPM(9)=64
      IREGPM(10)=6
      IREGPM(11)=10
      IREGPM(12)=62
      IREGPM(13)=28
      IREGPM(14)=14
      IREGPM(15)=16
      IREGPM(16)=15
      IF(IFEEDB.EQ.'OFF')GOTO4519
      WRITE(ICOUT,4506)
 4506 FORMAT('FOR REGIS, THE DEFAULT COLORS ARE:')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4507)
 4507 FORMAT('COLOR MAP COLOR NAME')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4508)
 4508 FORMAT('========= ==========')
      CALL DPWRST('XXX','BUG ')
      DO4510I=1,IREGMC
CCCCC   WRITE(ICOUT,4511)I,IRGCLR(IREGPM(I))
CCCCC CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,4511)I,ICLR(IREGPM(I))
      CALL DPWRST('XXX','BUG ')
 4510 CONTINUE
 4511 FORMAT(I2,8X,A25)
 4519 CONTINUE
      GOTO9000
C
 4800 CONTINUE
      IDEV='REGI'
      IDEV2='    '
      GOTO6200
C
 4910 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,4911)
 4911 FORMAT('NO COLOR SPECIFIED FOR REGIS PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 4920 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,4921)
 4921 FORMAT('NO INDEX SPECIFIED FOR REGIS PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 4930 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,4931)
 4931 FORMAT('INVALID INDEX SPECIFIED FOR REGIS PEN MAP COMMAND.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C  *****************************************
C  **  X11 CASE                           **
C  **  CURRENTLY ONLY SUPPORT             **
C  **    X11 COLORS SHOW (OR SIMILIAR)    **
C  *****************************************
C
 5100 CONTINUE
C
      IF(IHARG(1).EQ.'PEN'.AND.IHARG(2).EQ.'MAP')GOTO5110
      IF(IHARG(1).EQ.'COLO'.AND.IHARG(2).EQ.'MAP')GOTO5110
      IF(IHARG(1).EQ.'PEN')GOTO5120
      IF(IHARG(1).EQ.'MAP')GOTO5120
      IF(IHARG(1).EQ.'COLO')GOTO5120
 
C
 5110 CONTINUE
      IARCL=3
      GOTO5190
C
 5120 CONTINUE
      IARGCL=2
      GOTO5190
C
 5190 CONTINUE
      IFOUND='YES'
      IF(IHARG(IARGCL).EQ.'AUTO')GOTO5800
      IF(IHARG(IARGCL).EQ.'DEFA')GOTO5800
      IF(IHARG(IARGCL).EQ.'ON  ')GOTO5800
      IF(IHARG(IARGCL).EQ.'OFF ')GOTO9000
      IF(IHARG(IARGCL).EQ.'LIST')GOTO5800
      IF(IHARG(IARGCL).EQ.'SHOW')GOTO5800
      IF(IHARG(IARGCL).EQ.'?   ')GOTO5800
      IF(IHARG(IARGCL).EQ.'PRIN')GOTO5800
      GOTO5800
C
 5800 CONTINUE
CCCCC THE FOLLOWING FORMAT STATEMENT WAS SPLIT   SEPTEMBER 1993
CCCCC WRITE(ICOUT,5805)
      WRITE(ICOUT,5801)
 5801 FORMAT('COLORS FOR THE X11 TERMINAL:')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5802)
 5802 FORMAT('COLOR',24X,'NAME',6X,'INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5803)
 5803 FORMAT('=====',24X,'====',6X,'=====')
      CALL DPWRST('XXX','BUG ')
      IHELMX=24
      NCPREH=0
      ICPREH=' '
      IRESP='YES'
      IBUGO2='OFF'
      NUMLPR=4
      DO5810I=1,MAXCLR
        NUMLPR=NUMLPR+1
        IF(NUMLPR.GE.IHELMX)THEN
          CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
          NUMLPR=0
          IF(IRESP.EQ.'NO')GOTO9000
        END IF
        WRITE(ICOUT,5811)ICLR(I),INAM(I),I
        CALL DPWRST('XXX','BUG ')
 5810 CONTINUE
 5811 FORMAT(A25,5X,A8,2X,I2)
      GOTO9000
C
C  *****************************************
C  **  SHOW COLORS CASE                   **
C  *****************************************
C
 6100 CONTINUE
C
      IF(IHARG(1).EQ.'COLO'.AND.NUMARG.LE.1)GOTO6800
      IF(IHARG(1).EQ.'COLO'.AND.NUMARG.GE.2)GOTO6130
      IF(IHARG(2).EQ.'COLO')GOTO6140
      IF(IHARG(3).EQ.'COLO')GOTO6150
      GOTO9000
C
 6130 CONTINUE
      IDEV=IHARG(2)
      IDEV2=IHARG(3)
      GOTO6200
C
 6140 CONTINUE
      IDEV=IHARG(1)
      IDEV2=' '
      GOTO6200
C
 6150 CONTINUE
      IDEV=IHARG(1)
      IDEV2=IHARG(2)
      GOTO6200
C
 6200 CONTINUE
      IFOUND='YES'
      IGRAY='NO'
      IF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4027'))THEN
        DO6201I=1,MAXCLR
        JTEMP(I)=J4027(I)
        JINDEX=2
        IF(JTEMP(I).EQ.0)JINDEX=1
        IF(JTEMP(I).EQ.1)JINDEX=3
        IF(JTEMP(I).EQ.2)JINDEX=5
        IF(JTEMP(I).EQ.3)JINDEX=4
        IF(JTEMP(I).EQ.4)JINDEX=9
        IF(JTEMP(I).EQ.5)JINDEX=7
        IF(JTEMP(I).EQ.6)JINDEX=54
        IF(JTEMP(I).EQ.7)JINDEX=2
        JTEMP(I)=JINDEX
 6201   CONTINUE
      ELSEIF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4105').OR.
     1       (IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4113').OR.
     1       (IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4115').OR.
     1       (IDEV.EQ.'GENE'))THEN
        DO6202I=1,MAXCLR
        JTEMP(I)=J4105(I)
        JINDEX=2
        IF(JTEMP(I).EQ.0)JINDEX=2
        IF(JTEMP(I).EQ.1)JINDEX=1
        IF(JTEMP(I).EQ.2)JINDEX=3
        IF(JTEMP(I).EQ.3)JINDEX=5
        IF(JTEMP(I).EQ.4)JINDEX=4
        IF(JTEMP(I).EQ.5)JINDEX=8
        IF(JTEMP(I).EQ.6)JINDEX=6
        IF(JTEMP(I).EQ.7)JINDEX=9
        JTEMP(I)=JINDEX
 6202   CONTINUE
      ELSEIF((IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2622').OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2623').OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2627').OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'2647'))THEN
        DO6205I=1,MAXCLR
        JTEMP(I)=J2622(I)
        JINDEX=2
        IF(JTEMP(I).EQ.0)JINDEX=2
        IF(JTEMP(I).EQ.1)JINDEX=3
        IF(JTEMP(I).EQ.2)JINDEX=5
        IF(JTEMP(I).EQ.3)JINDEX=9
        IF(JTEMP(I).EQ.4)JINDEX=4
        IF(JTEMP(I).EQ.5)JINDEX=6
        IF(JTEMP(I).EQ.6)JINDEX=8
        IF(JTEMP(I).EQ.7)JINDEX=1
        JTEMP(I)=JINDEX
 6205   CONTINUE
      ELSEIF((IDEV.EQ.'TEKT'.AND.IDEV2.EQ.'4662').OR.
     1       (IDEV.EQ.'CALC'.AND.ICALCL.LE.4).OR.
     1       (IDEV.EQ.'ZETA'.AND.IZETCL.LE.4).OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IDEV2.EQ.'7221').OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IHPGCL.LE.4))THEN
        DO6203I=1,MAXCLR
        JTEMP(I)=JPLOT4(I)
        JINDEX=1
        IF(JTEMP(I).EQ.1)JINDEX=2
        IF(JTEMP(I).EQ.2)JINDEX=3
        IF(JTEMP(I).EQ.3)JINDEX=4
        IF(JTEMP(I).EQ.4)JINDEX=5
        JTEMP(I)=JINDEX
 6203   CONTINUE
      ELSEIF(
     1       (IDEV.EQ.'CALC'.AND.ICALCL.GT.4).OR.
     1       (IDEV.EQ.'ZETA'.AND.IZETCL.GT.4).OR.
     1       (IDEV(1:2).EQ.'HP'.AND.IHPGCL.GT.4))THEN
        DO6204I=1,MAXCLR
        JTEMP(I)=JPLOT8(I)
        JINDEX=2
        IF(JTEMP(I).EQ.1)JINDEX=2
        IF(JTEMP(I).EQ.2)JINDEX=3
        IF(JTEMP(I).EQ.3)JINDEX=4
        IF(JTEMP(I).EQ.4)JINDEX=5
        IF(JTEMP(I).EQ.5)JINDEX=6
        IF(JTEMP(I).EQ.6)JINDEX=7
        IF(JTEMP(I).EQ.7)JINDEX=8
        IF(JTEMP(I).EQ.8)JINDEX=9
        JTEMP(I)=JINDEX
 6204   CONTINUE
      ELSEIF((IDEV.EQ.'CGM').OR.
     1       (IDEV.EQ.'POST'))THEN
        DO6206I=1,MAXCLR
        JTEMP(I)=JCGM(I)
 6206   CONTINUE
        IF(IDEV.EQ.'POST')IGRAY='YES'
      ELSEIF((IDEV.EQ.'SUN '))THEN
        DO6207I=1,MAXCLR
        JTEMP(I)=JSUN(I)
        JINDEX=2
        IF(JTEMP(I).EQ.0)JINDEX=2
        IF(JTEMP(I).EQ.1)JINDEX=3
        IF(JTEMP(I).EQ.2)JINDEX=5
        IF(JTEMP(I).EQ.3)JINDEX=4
        IF(JTEMP(I).EQ.4)JINDEX=9
        IF(JTEMP(I).EQ.5)JINDEX=2
        IF(JTEMP(I).EQ.6)JINDEX=6
        IF(JTEMP(I).EQ.7)JINDEX=1
        JTEMP(I)=JINDEX
 6207   CONTINUE
      ELSEIF((IDEV.EQ.'REGI'))THEN
        DO6208I=1,MAXCLR
        JTEMP(I)=JREGIS(I)
        JINDEX=JREG2(JTEMP(I))
        JTEMP(I)=JINDEX
 6208   CONTINUE
      ELSEIF((IDEV.EQ.'X11'))THEN
        DO6209I=1,MAXCLR
        JTEMP(I)=JCGM(I)
 6209   CONTINUE
        IGRAY='YES'
      ELSEIF(IDEV.EQ.'PC'.OR.
     1       IDEV.EQ.'IBM'.OR.
     1       IDEV.EQ.'TURB'.OR.
     1       IDEV.EQ.'VGA')THEN
        DO6210I=1,MAXCLR
        JTEMP(I)=JPC(I)
        JINDEX=2
        IF(JTEMP(I).EQ.0)JINDEX=2
        IF(JTEMP(I).EQ.1)JINDEX=4
        IF(JTEMP(I).EQ.2)JINDEX=5
        IF(JTEMP(I).EQ.3)JINDEX=8
        IF(JTEMP(I).EQ.4)JINDEX=3
        IF(JTEMP(I).EQ.5)JINDEX=6
        IF(JTEMP(I).EQ.6)JINDEX=18
        IF(JTEMP(I).EQ.7)JINDEX=30
        IF(JTEMP(I).EQ.8)JINDEX=15
        IF(JTEMP(I).EQ.9)JINDEX=12
        IF(JTEMP(I).EQ.10)JINDEX=16
        IF(JTEMP(I).EQ.11)JINDEX=68
        IF(JTEMP(I).EQ.12)JINDEX=84
        IF(JTEMP(I).EQ.13)JINDEX=87
        IF(JTEMP(I).EQ.14)JINDEX=9
        IF(JTEMP(I).EQ.15)JINDEX=1
        JTEMP(I)=JINDEX
 6210   CONTINUE
      ELSE
        WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6221)IDEV,IDEV2
 6221 FORMAT('DEVICE ',A4,1X,A4,' NOT RECOGNIZED')
      CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6255)IDEV,IDEV2
 6255 FORMAT('THE FOLLOWING SHOWS THE COLOR MAPPING FOR DEVICE: ',
     11X,A4,1X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(IGRAY.EQ.'YES')THEN
         WRITE(ICOUT,6261)
 6261    FORMAT('THIS DEVICE SUPPORTS GRAY SCALE')
         CALL DPWRST('XXX','BUG ')
      ELSE
         WRITE(ICOUT,6262)
 6262    FORMAT('THIS DEVICE DOES NOT SUPPORT GRAY SCALE')
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
CCCCC THE FOLLOWING FORMAT WAS SPLIT   SEPTEMBER 1993
CCCCC WRITE(ICOUT,6270)
      WRITE(ICOUT,6271)
 6271 FORMAT(5X,24X,'DATAPLOT',2X,'DATAPLOT',2X,'DEVICE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6272)
 6272 FORMAT('COLOR',24X,'NAME',6X,'INDEX',5X,'COLOR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6273)
 6273 FORMAT('=====',24X,'========',2X,'========',2X,'======')
      CALL DPWRST('XXX','BUG ')
C
      IHELMX=24
      NCPREH=0
      ICPREH=' '
      IRESP='YES'
      IBUGO2='OFF'
      NUMLPR=6
      DO6280I=1,MAXCLR
        NUMLPR=NUMLPR+1
        IF(NUMLPR.GE.IHELMX)THEN
          CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
          NUMLPR=0
          IF(IRESP.EQ.'NO')GOTO9000
        END IF
        WRITE(ICOUT,6281)ICLR(I),INAM(I),I-1,INAM(JTEMP(I))
      CALL DPWRST('XXX','BUG ')
 6280 CONTINUE
 6281 FORMAT(A24,5X,A8,2X,I2,8X,A8)
      GOTO9000
C
 6800 CONTINUE
      IFOUND='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING SECTION STATMENT WAS CHANGED   SEPTEMBER 1993
CCCCC WRITE(ICOUT,6805)
      WRITE(ICOUT,6801)
 6801 FORMAT('THE FOLLOWING IS A LIST OF COLORS THAT DATAPLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6802)
 6802 FORMAT('CURRENTLY RECOGNIZES.  ALL DEVICES RECOGNIZE THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6803)
 6803 FORMAT('SAME COLOR NAMES.  HOWEVER, MOST DEVICES ONLY SUPPORT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6804)
 6804 FORMAT('A SUBSET OF THIS LIST.  AN UNSUPPORTED COLOR WILL BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6805)
 6805 FORMAT('MAPPED TO A SUPPORTED COLOR.  IN ADDITION, GRAY SCALE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6806)
 6806 FORMAT('CAN BE REQUESTED BY USING G0 (BLACK) THROUGH G100')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6807)
 6807 FORMAT('(WHITE).  HOWEVER, ONLY A FEW DEVICES ACTUALLY SUPPORT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6808)
 6808 FORMAT('GRAY SCALE (POSTSCRIPT, X11).  OTHER DEVICES WILL MAP')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6809)
 6809 FORMAT('ALL GRAY SCALES TO EITHER BLACK OR WHITE.')
      CALL DPWRST('XXX','BUG ')
C
C     THE FOLLOWING FORMAT WAS SPLIT   SEPTEMBER 1993
CCCCC WRITE(ICOUT,6811)
      WRITE(ICOUT,6811)
 6811 FORMAT('SUPPORTED COLORS:')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6812)
 6812 FORMAT('COLOR',24X,'NAME',6X,'INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6813)
 6813 FORMAT('=====',24X,'====',6X,'=====')
      CALL DPWRST('XXX','BUG ')
C
      IHELMX=24
      NCPREH=0
      ICPREH=' '
      IRESP='YES'
      IBUGO2='OFF'
      NUMLPR=13
      DO6820I=1,MAXCLR
         NUMLPR=NUMLPR+1
         IF(NUMLPR.GE.IHELMX)THEN
            CALL DPMORE(NUMLPR,NCPREH,ICPREH,IRESP,IBUGO2,IERROR)
            NUMLPR=0
            IF(IRESP.EQ.'NO')GOTO9000
         END IF
         WRITE(ICOUT,6821)ICLR(I),INAM(I),I-1
 6821    FORMAT(A24,5X,A8,2X,I2)
         CALL DPWRST('XXX','BUG ')
 6820 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPM')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF DPDEPM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGO2
 9013 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGG4,ISUBG4
 9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFOUND,IERROR
 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
      WRITE(ICOUT,9032)IHPGPF
 9032 FORMAT('IHPGPF=',A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEP2(IOPERA,IGENNU,IGENID,IGDFLG,
     1ICAPSW,
     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--TURN ON OR TURN OFF
C              (DEPENDING ON THE CONTENTS OF IOPERA)
C              A DEVICE BY CARRYING OUT
C              APPROPRIATE (OPEN OR CLOSE) FILE OPERATIONS.
C              THIS IS USED FOR TURNING ON OR OFF
C              ALTERNATE PLOTTING DEVICES.
C     INPUT  ARGUMENTS--IOPERA (A CHARACTER VARIABLE
C                              DESCRIBING THE DESIRED OPERATION
C                              (OPEN OR CLOSE)
C                     --IGENNU (AN INTEGER VALUE
C                              BY WHICH THE PLOT  FILE/SUBFILE
C                              MAY BE REFERENCED IN A FORTRAN
C                              I/O STATEMENT.
C                     --IGENID (A CHARACTER VARIABLE
C                              CONTAINING IDENTIFICATION INFORMATION
C                              FOR THE PLOT  FILE/SUBFILE
C                             (E.G., PLO1, PLO2, GENE, ETC.)
C                     --IANS   (A  CHARACTER 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                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--86/1
C     ORIGINAL VERSION--JUNE      1978.
C     UPDATED         --APRIL     1979.
C     UPDATED         --OCTOBER   1980.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --JANUARY   1986.
C     UPDATED         --MAY       1988.
C     UPDATED         --MAY       1990.  REACTIVE "CLOSE" CODE
C     UPDATED         --APRIL     1992.  FIX BUG FOR "CLOSE"
C                                        CALL GREXIT IF "CLOSE"
C     UPDATED         --MAY       1992.  IFOUND NO --> YES
C     UPDATED         --MAY       1992.  ADD DEBUG STATEMENTS
C     UPDATED         --MAY       1992.  FIX IPL1CS,IPL2CS
C     UPDATED         --FEBRUARY  2001.  IGDFLG
C     UPDATED         --SEPTEMBER 2002.  HTML CAPTURE FOR GD AND
C                                        SVG DEVICES
C     UPDATED         --JANUARY   2003.  HTML CAPTURE FOR POSTSCRIPT
C     UPDATED         --JANUARY   2003.  SUPPORT FOR IPSTDV (CONVERT
C                                        POSTSCRIPT OUTPUT TO: JPEG,
C                                        PDF, TIFF, PBM USING
C                                        GHOSTSCRIPT
C     UPDATED         --SEPTEMBER 2003.  LATEX CAPTURE FOR POSTSCRIPT
C     UPDATED         --FEBRUARY  2006.  CALL GREXIT FOR DEVICE 1
C     UPDATED         --MARCH     2006.  CHECK IF ANOTHER PROCESS
C                                        MIGHT HAVE PLOT FILE LOCKED.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IOPERA
      CHARACTER*4 IGENID
      CHARACTER*4 IGDFLG
      CHARACTER*4 IANS
      CHARACTER*4 IBUGO2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*80 IFILE
      CHARACTER*12 ISTAT
      CHARACTER*12 IFORM
      CHARACTER*12 IACCES
      CHARACTER*12 IPROT
      CHARACTER*12 ICURST
      CHARACTER*4 IENDFI
      CHARACTER*4 IREWIN
      CHARACTER*4 ISUBN0
      CHARACTER*4 IERRFI
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*256 ISTRIN
C
      CHARACTER*80 IFIL2
      CHARACTER*1 IQUOTE
      CHARACTER*1 IBASLC
      CHARACTER*4 IEXIST
      CHARACTER*12 IFWRIT
      CHARACTER*12 IFORMT
C
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOFO.INC'
      INCLUDE 'DPCOF2.INC'
CCCCC FOLLOWING THREE INCLUDE FILES NEEDED TO CALL GREXIT
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCOGR.INC'
C
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCOHO.INC'
      INCLUDE 'DPCOST.INC'
C
      LOGICAL IOPPLO
      COMMON/OPNPLT/IOPPLO
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 THE FOLLOWING LINE WAS FIXED                MAY 1992 (JJF)
CCCCC AS PART OF FIX FOR   PRINT PLOT   COMMAND   MAY 1992 (JJF)
CCCCC IFOUND='NO'
      IFOUND='YES'
      IERROR='NO'
C
      ISUBN1='DPDE'
      ISUBN2='P2  '
C
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEP2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEP2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IDEV,IOPERA,IGENNU,IGENID
   52 FORMAT('IDEV,IOPERA,IGENNU,IGENID = ',
     1A4,2X,A4,2X,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGO2,IERROR
   53 FORMAT('IBUGO2,IERROR = ',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,61)IPL1NU
   61 FORMAT('IPL1NU = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)IPL1NA
   62 FORMAT('IPL1NA = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)IPL1ST
   63 FORMAT('IPL1ST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,64)IPL1FO
   64 FORMAT('IPL1FO = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,65)IPL1AC
   65 FORMAT('IPL1AC = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,66)IPL1FO
   66 FORMAT('IPL1FO = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,67)IPL1CS
   67 FORMAT('IPL1CS = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IPL2NU
   71 FORMAT('IPL2NU = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IPL2NA
   72 FORMAT('IPL2NA = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)IPL2ST
   73 FORMAT('IPL2ST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IPL2FO
   74 FORMAT('IPL2FO = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,75)IPL2AC
   75 FORMAT('IPL2AC = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,76)IPL2FO
   76 FORMAT('IPL2FO = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,77)IPL2CS
   77 FORMAT('IPL2CS = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)IOPERA,IDEV,IPL1CS,IPL2CS
   81 FORMAT('IOPERA,IDEV,IPL1CS,IPL2CS = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,83)IMANUF,IMODEL
   83 FORMAT('IMANUF,IMODEL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **************************
C               **  STEP 11--           **
C               **  COPY OVER VARIABLES **
C               **************************
C
      ISTEPN='11'
      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IGENID.EQ.'PLO1')GOTO1110
      IF(IGENID.EQ.'PLO2')GOTO1120
      IF(IGENID.EQ.'SCRE')GOTO1290
      GOTO1120
C
 1110 CONTINUE
      IOUNIT=IPL1NU
      IFILE=IPL1NA
      ISTAT=IPL1ST
      IFORM=IPL1FO
      IACCES=IPL1AC
      IPROT=IPL1PR
      ICURST=IPL1CS
      ISUBN0='DEP2'
      IERRFI='NO'
      GOTO1190
C
 1120 CONTINUE
      IOUNIT=IPL2NU
      IFILE=IPL2NA
      ISTAT=IPL2ST
      IFORM=IPL2FO
      IACCES=IPL2AC
      IPROT=IPL2PR
      ICURST=IPL2CS
      ISUBN0='DEP2'
      IERRFI='NO'
      GOTO1190
C
 1190 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEP2')GOTO1199
      WRITE(ICOUT,1193)IOUNIT
 1193 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1194)IFILE
 1194 FORMAT('IFILE = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
 1195 FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',
     1A12,2X,A12,2X,A12,2X,A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1196)ISUBN0,IERRFI
 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
C
C               *******************************************
C               **  STEP 12--                            **
C               **  CHECK TO SEE IF PLOT FILE MAY EXIST  **
C               *******************************************
C
      ISTEPN='12'
      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
     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 DPDEP2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      THE DESIRED PLOTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      CANNOT BE STORED ON FILE 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 SUCH PLOTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1216)
 1216 FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1217)ISTAT,IPL1ST,IPL2ST
 1217 FORMAT('ISTAT,IPL1ST,IPL2ST = ',A12,2X,A12,2X,A12)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1290 CONTINUE
C
C               *****************************************
C               **  STEP 20--                          **
C               **  BRANCH TO THE APPROPRIATE CASE--   **
C               **    1) OPEN  THE PLOT FILE;          **
C               **    2) CLOSE THE PLOT FILE.          **
C               *****************************************
C
      ISTEPN='20'
      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IOPERA.EQ.'ON  ')GOTO2100
CCCCC FOLLOWING LINE ADDED MAY, 1990.
      IF(IOPERA.EQ.'OPEN')GOTO2100
      GOTO2200
C
C               ******************************************
C               **  STEP 21--                           **
C               **  OPEN THE PLOT FILE.                 **
C               **  PRIOR VERSIONS OF DATAPLOT HAD      **
C               **  OPEN, BUT NO REWIND                 **
C               ******************************************
C
C  NOTE: MARCH 2006.  ADD A CALL TO DPINF2 TO CHECK IF FILE
C        CAN BE OPENED IN "WRITE" MODE.  UNDER WINDOWS (INTEL
C        COMPILER), ANOTHER DATAPLOT PROCESS CAN HAVE A LOCK
C        ON THE PLOT FILE WHICH CAN CAUSE THE CURRENT SESSION
C        TO HANG.
C
C  NOTE: UNFORTUNETELY, DPINQF2 DOESN'T QUITE DO THE TRICK
C        (IT SIMPLY RETURNS AN "UNKNOWN" STATUS REGARDLESS
C        OF WHETHER A PREVIOUS PROCESS WAS RUNNING OR NOT).
C        FOR WINDOWS, WE REDEFINED THE "PROTECTION" OPTION
C        TO BE "WRITE" FOR THE PLOT FILES.  THIS WILL CAUSE
C        THE OPEN TO FAIL IF ANOTHER PROCESS HAS THE PLOT
C        FILE LOCKED.  ONE ADDITIONAL COMPLICATION IS THAT
C        DATAPLOT WILL TRY TO OPEN THE FILE IN THE DATAPLOT
C        DIRECTORIES IF THE INITIAL OPEN FAILS.  FOR THIS
C        REASON, WE WILL SET A FLAG IN A COMMON BLOCK SO
C        THAT DPOPFI WILL KNOW NOT TO TRY AND OPEN THE
C        FILE IN THE DATAPLOT SUB-DIRECTORIES.
C
 2100 CONTINUE
      ISTEPN='21'
      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDEV=IGENID
C MAY, 1988.  DON'T OPEN IF ALREADY OPEN
      IF(IDEV.EQ.'PLO1'.AND.IPL1CS.EQ.'OPEN')GOTO2199
      IF(IDEV.EQ.'PLO2'.AND.IPL2CS.EQ.'OPEN')GOTO2199
      IF(IDEV.EQ.'SCRE')GOTO2199
C
      IF(IGDFLG.EQ.'ON')GOTO2198
C
      IFGPID=0
 2109 CONTINUE
      IOPPLO=.TRUE.
      IREWIN='OFF'
      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IREWIN,ISUBN0,IERRFI,IBUGO2,ISUBRO,IERROR)
      IOPPLO=.FALSE.
      IF(IERROR.EQ.'YES')THEN
        IF(IGENID.EQ.'PLO1')IPL1CS='CLOSED'
        IF(IGENID.EQ.'PLO2')IPL2CS='CLOSED'
C
        IF(IFGPID.EQ.1)THEN
          WRITE(ICOUT,2181)
 2181     FORMAT('***** WARNING: DATAPLOT STILL UNABLE TO OPEN ',
     1           'THE PLOT FILE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2183)
 2183     FORMAT('      THE PLOT FILE WILL NOT BE GENERATED.')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
C
        IFGPID=1
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2111)
 2111   FORMAT('***** WARNING: DATAPLOT UNABLE TO OPEN THE PLOT FILE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2113)IFILE
 2113   FORMAT('               ',A80)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2115)
 2115   FORMAT('      IN WRITE MODE.  LIKELY CAUSES ARE:')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2117)
 2117   FORMAT('      1. YOU ARE TRYING TO OPEN THE FILE IN A ',
     1         'READ ONLY DIRECTORY.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2119)
 2119   FORMAT('      2. ANOTHER DATAPLOT PROCESS IS ACTIVE AND ',
     1         'HAS A LOCK ON THE FILE.')
        CALL DPWRST('XXX','BUG ')
        IF(IHOST1.EQ.'IBM-' .AND. ICOMPI.EQ.'MS-F')THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2121)
 2121     FORMAT('      3. ON THE WINDOWS PLATFORM, IF A PREVIOUS ',
     1           'GUI SESSION DID NOT CLOSE')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2123)
 2123     FORMAT('         CLEANLY, THE UNDERLYING DATAPLOT ',
     1           'EXECUTABLE MAY STILL BE RUNNING')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2125)
 2125     FORMAT('         AND HAVE A LOCK ON THE FILE.  TO CLEAR ',
     1           'THESE, AFTER EXITING THE CURRENT')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2127)
 2127     FORMAT('         ENTER "CNTRL-ALT-DEL" TO BRING UP THE ',
     1           'TASK MANAGER AND THEN SELECT')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2129)
 2129     FORMAT('         "PROCESSES".  DELETE ANY OCCURENCES OF ',
     1           '"DPLAHEY.EXE".')
          CALL DPWRST('XXX','BUG ')
        ENDIF
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
C
        IF(ITMPFI.EQ.'PID')THEN
          IFGPID=1
          WRITE(ICOUT,2131)
 2131     FORMAT('      DATAPLOT WILL APPEND THE PROCESS-ID TO THE ',
     1           'FILE NAME AND TRY AGAIN.')
          CALL DPWRST('XXX','BUG ')
          CALL DPPID2(IPID,ISUBRO,IERROR)
          IF(IPID.LE.0)THEN
            IERROR='YES'
            GOTO9000
          ELSE
 2139       CONTINUE
            IF(IPID.LT.10)THEN
              NCH=1
            ELSEIF(IPID.LT.100)THEN
              NCH=2
            ELSEIF(IPID.LT.1000)THEN
              NCH=3
            ELSEIF(IPID.LT.10000)THEN
              NCH=4
            ELSEIF(IPID.LT.100000)THEN
              NCH=5
            ELSEIF(IPID.LT.1000000)THEN
              NCH=6
            ELSE
              IPID=IPID/10
              GOTO2139
            ENDIF
            IFORMT=' '
            IFORMT='(I )'
            WRITE(IFORMT(3:3),'(I1)')NCH
          ENDIF
          IF(IGENID.EQ.'PLO1')THEN
            NLAST=80-NCH-1
            DO2141I=72,1,-1
              NLAST=I
              IF(IPL1NA(I:I).NE.' ')GOTO2149
 2141       CONTINUE
 2149       CONTINUE
            IPL1NA(NLAST+1:NLAST+1)='.'
            WRITE(IPL1NA(NLAST+2:NLAST+NCH-1),IFORMT)IPID
            IFILE(1:80)=IPL1NA(1:80)
          ELSEIF(IGENID.EQ.'PLO2')THEN
            NLAST=80-NCH-1
            DO2151I=72,1,-1
              NLAST=I
              IF(IPL2NA(I:I).NE.' ')GOTO2159
 2151       CONTINUE
 2159       CONTINUE
            IPL2NA(NLAST+1:NLAST+1)='.'
            WRITE(IPL2NA(NLAST+2:NLAST+NCH+1),IFORMT)IPID
            IFILE(1:80)=IPL2NA(1:80)
          ENDIF
          GOTO2109
        ELSE
          IERROR='YES'
          GOTO9000
        ENDIF
      ENDIF
C
      IF(IFGPID.EQ.1)THEN
        WRITE(ICOUT,2161)
 2161   FORMAT('      PLOT FILE OPENED AS:')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,2163)IFILE
 2163   FORMAT('      ',A80)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 2198 CONTINUE
      IF(IGENID.EQ.'PLO1')IPL1CS='OPEN'
      IF(IGENID.EQ.'PLO2')IPL2CS='OPEN'
C
 2199 CONTINUE
      GOTO9000
C
C               ******************************************
C               **  STEP 22--                           **
C               **  CLOSE THE PLOT FILE.                **
C               **  PRIOR VERSIONS OF DATAPLOT HAD      **
C               **  ENDFILE, BUT NO REWIND AND NO CLOSE **
C               ******************************************
C
C  MAY, 1990.  REACTIVATE CLOSE FILE (WITH "SYSTEM" COMMAND, CAN NOW
C  PRINT A PLOT FILE WITHOUT EXITING DATAPLOT ON SOME SYSTEMS, BUT
C  NEED PLOT FILE TO BE CLOSED IN ORDER TO DO SO).
C
 2200 CONTINUE
C
      IDEV=IGENID
C
      ISTEPN='22'
      IF(IBUGO2.EQ.'ON'.OR.ISUBRO.EQ.'DEP2')THEN
        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
        WRITE(ICOUT,2211)IOPERA,IDEV,IPL1CS,IPL2CS
 2211   FORMAT('IOPERA,IDEV,IPL1CS,IPL2CS = ',A4,2X,A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(IOPERA.NE.'CLOS')GOTO9000
C
C  FOLLOWING 3 LINES MAY, 1990.  DON'T CLOSE IF NOT OPEN
      IF(IDEV.EQ.'PLO1'.AND.IPL1CS.NE.'OPEN')GOTO2299
      IF(IDEV.EQ.'PLO2'.AND.IPL2CS.NE.'OPEN')GOTO2299
C
CCCCC APRIL 1992.  NEED TO CALL GREXIT IF CLOSE DEVICE.  NEEDED IN
CCCCC PARTICULAR FOR LASER PRINTERS SUCH AS POSTSCRIPT TO GET THE
CCCCC LAST PAGE PRINTED.
      IF(IDEV.EQ.'PLO1')IJUNK=2
      IF(IDEV.EQ.'PLO2')IJUNK=3
      IF(IDEV.EQ.'SCRE')IJUNK=1
      IF(IJUNK.LE.0 .OR. IJUNK.GT.3)GOTO9000
      IMANUF=IDMANU(IJUNK)
      IMODEL=IDMODE(IJUNK)
      IMODE2=IDMOD2(IJUNK)
      IMODE3=IDMOD3(IJUNK)
      IGCODE=IDCODE(IJUNK)
      IGUNIT=IDUNIT(IJUNK)
      NUMHPP=IDNHPP(IJUNK)
      ANUMHP=NUMHPP
      NUMVPP=IDNVPP(IJUNK)
      ANUMVP=NUMVPP
      IGCOLO=IDCOLO(IJUNK)
CCCCC ADD FOLLOWING LINE MARCH 1997.
      IGFONT=IDFONT(IJUNK)
      IGBAUD=IDBAUD(IJUNK)
      ISOFT=IDSOFT(IJUNK)
      ISOFT2=IDSOF2(IJUNK)
      ISOFT3=IDSOF3(IJUNK)
C
      IF(IDEV.EQ.'SCRE'.AND.ICAPSW.EQ.'ON')THEN
        IGUNIT=IGENNU
      ENDIF
C
      CALL GREXIT
      IF(IDEV.EQ.'SCR')GOTO9000
C
      IENDFI='ON'
      IREWIN='OFF'
C  MAY, 1990.  UNCOMMENTED FOLLOWING 3 LINES
      IF(IGDFLG.EQ.'ON')GOTO2298
      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGO2,ISUBRO,IERROR)
      IF(IERRFI.EQ.'YES')GOTO9000
 2298 CONTINUE
C  MAY, 1988.  DO ENDFILE ONLY IN DPEXIT.
C  MAY, 1990.  UNCOMMENT
C  APRIL, 1992.  ENDFILE OF CLOSED FILE CAUSES PC VERSION TO
C  BOMB.  ENDFILE SHOULD BE HANDLED (IF NEEDED) IN DPCLFI.
CCCCC ENDFILE IOUNIT
C
CCCCC THE FOLLOWING 2 LINES WERE FIXED MAY 1992 (JJF)
CCCCC IPL1CS='CLOSED'
CCCCC IPL2CS='CLOSED'
      IF(IDEV.EQ.'PLO1')IPL1CS='CLOSED'
      IF(IDEV.EQ.'PLO2')IPL2CS='CLOSED'
CCCCC JANUARY   2003.  FOR POSTSCRIPT OUTPUT, IF IPSTDV SET TO
CCCCC JPEG, PDG, TIFF, PBM, PNG, PPM, OR PPN, THEN USE GHOSTSCRIPT
CCCCC TO MAKE THE APPROPRIATE IMAGE FILE (ORIGINAL POSTSCRIPT FILE
CCCCC WILL NOT BE CHANGED).  IF CAPTURE HTML HAS BEEN ENTERED,
CCCCC HANDLE SEPARATELY.
C
      IF(ICAPSW.EQ.'OFF'.OR.ICAPTY.NE.'HTML'.OR.ICAPTY.NE.'LATE')THEN
        ICON=0
        IF(IPSTDV.EQ.'JPEG')ICON=1
        IF(IPSTDV.EQ.'TIFF')ICON=1
        IF(IPSTDV.EQ.'PDF ')ICON=1
        IF(IPSTDV.EQ.'PBM  ')ICON=1
        IF(IPSTDV.EQ.'PNG  ')ICON=1
        IF(IPSTDV.EQ.'PGM  ')ICON=1
        IF(IPSTDV.EQ.'PPM  ')ICON=1
        IF(IPSTDV.EQ.'PNM  ')ICON=1
        IF(IMANUF.EQ.'POST'.AND.ICON.GT.0)THEN
C
C  CURRENTLY ONLY AVAILABLE FOR WINDOWS AND UNIX.
C
C  DETERMINE NAME FOR JPEG FILE
C
          IF(IOPSY1.EQ.'UNIX' .OR. IHOST1.EQ.'IBM-')THEN
            ILAST=80
            IPEROD=0
            DO2641I=80,1,-1
              IF(IFILE(I:I).NE.' ')THEN
                ILAST=I
                GOTO2645
              ENDIF
 2641       CONTINUE
            GOTO9000
 2645       CONTINUE
            DO2646I=80,1,-1
              IF(IFILE(I:I).EQ.'.')THEN
                IPEROD=I
                GOTO2649
              ENDIF
 2646       CONTINUE
 2649       CONTINUE
            IF(IPEROD.GT.0)THEN
              IFIL2=' '
              IFIL2(1:IPEROD)=IFILE(1:IPEROD)
              IF(IPSTDV.EQ.'JPEG')THEN
                IFIL2(IPEROD+1:IPEROD+3)='jpg'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PDF ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='pdf'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'TIFF')THEN
                IFIL2(IPEROD+1:IPEROD+3)='tif'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PBM ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='pbm'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PGM ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='pgm'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PNG ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='png'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PNM ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='pnm'
                NCTEMP=IPEROD+3
              ELSEIF(IPSTDV.EQ.'PPM ')THEN
                IFIL2(IPEROD+1:IPEROD+3)='ppm'
                NCTEMP=IPEROD+3
              ENDIF
            ELSE
              IF(ILAST.GT.76)GOTO9000
              IFIL2=' '
              IFIL2(1:ILAST)=IFILE(1:ILAST)
              IF(IPSTDV.EQ.'JPEG')THEN
                IFIL2(ILAST+1:ILAST+4)='.jpg'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PDF ')THEN
                IFIL2(ILAST+1:ILAST+4)='.pdf'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'TIFF')THEN
                IFIL2(ILAST+1:ILAST+4)='.tif'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PBM ')THEN
                IFIL2(ILAST+1:ILAST+4)='.pbm'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PGM ')THEN
                IFIL2(ILAST+1:ILAST+4)='.pgm'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PNG ')THEN
                IFIL2(ILAST+1:ILAST+4)='.png'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PNM ')THEN
                IFIL2(ILAST+1:ILAST+4)='.pnm'
                NCTEMP=ILAST+4
              ELSEIF(IPSTDV.EQ.'PPM ')THEN
                IFIL2(ILAST+1:ILAST+4)='.ppm'
                NCTEMP=ILAST+4
              ENDIF
            ENDIF
C
C  RUN GHOSTSCRIPT TO CONVERT FROM POSTSCRIPT TO REQUESTED FORMAT
C
            IQUOTE='"'
            CALL DPCONA(92,IBASLC)
            ISTRIN=' '
            IF(NCGHPA.GT.0)THEN
              ISTRIN(1:NCGHPA)=IGSTPA(1:NCGHPA)
              N0=NCGHPA
              IF(IGSTPA(NCGHPA:NCGHPA).NE.IBASLC)THEN
                N0=N0+1
                ISTRIN(N0:N0)=IBASLC
              ENDIF
            ELSE
              N0=0
            ENDIF
            IF(IOPSY1.EQ.'UNIX')THEN
              N0=N0+1
              ISTRIN(N0:N0+2)='gs '
              N0=N0+2
            ELSEIF(IHOST1.EQ.'IBM-')THEN
              N0=N0+1
              ISTRIN(N0:N0+12)='GSWIN32C.EXE '
              N0=N0+13
            ENDIF
            N0=N0+1
            ISTRIN(N0:N0+29)='-dNOPAUSE -dBATCH -q -sDEVICE='
            N0=N0+30
            IF(IPSTDV.EQ.'JPEG')THEN
              ISTRIN(N0:N0+4)='jpeg '
              N0=N0+5
            ELSEIF(IPSTDV.EQ.'PDF ')THEN
              ISTRIN(N0:N0+8)='pdfwrite '
              N0=N0+9
            ELSEIF(IPSTDV.EQ.'TIFF')THEN
              ISTRIN(N0:N0+7)='tifflzw '
              N0=N0+8
            ELSEIF(IPSTDV.EQ.'PBM ')THEN
              ISTRIN(N0:N0+3)='pbm '
              N0=N0+4
            ELSEIF(IPSTDV.EQ.'PGM ')THEN
              ISTRIN(N0:N0+3)='pgm '
              N0=N0+4
            ELSEIF(IPSTDV.EQ.'PNG ')THEN
              IF(IHOST1.EQ.'IBM-')THEN
                ISTRIN(N0:N0+5)='png16 '
                N0=N0+6
              ELSE
                ISTRIN(N0:N0+3)='png '
                N0=N0+4
              ENDIF
            ELSEIF(IPSTDV.EQ.'PNM ')THEN
              ISTRIN(N0:N0+3)='pnm '
              N0=N0+4
            ELSEIF(IPSTDV.EQ.'PPM ')THEN
              ISTRIN(N0:N0+3)='ppm '
              N0=N0+4
            ENDIF
            ISTRIN(N0:N0+12)='-sOutputFile='
            N0=N0+13
            ISTRIN(N0:N0)=IQUOTE
            N0=N0+1
            ISTRIN(N0:N0+NCTEMP-1)=IFIL2(1:NCTEMP)
            N0=N0+NCTEMP
            ISTRIN(N0:N0)=IQUOTE
            N0=N0+1
            ISTRIN(N0:N0)=' '
            N0=N0+1
            ISTRIN(N0:N0+ILAST-1)=IFILE(1:ILAST)
            N0=N0+ILAST-1
            CALL DPSYS2(ISTRIN,N0,ISUBRO,IERROR)
          ENDIF
C
        ENDIF
      ENDIF
C
CCCCC SEPTEMBER 2002.  IF,
CCCCCC  1) CAPTURE SWITCH ON
CCCCC   2) CAPTURE IS IN HTML FORMAT
CCCCC   3) DEVICE IS SVG OR GD
CCCCC THEN PUT A "<img ..." OF THE JUST CREATED GRAPHIC FILE
CCCCC IN THE HTML OUTPUT.
CCCCC OCTOBER 2002.  SLIGHTLY DIFFERENT SYNTAX FOR SVG OUTPUT.
CCCCC JANUARY 2003.  SUPPORT POSTSCRIPT GRAPHS AS WELL.  FOR POSTSCRIPT,
CCCCC                RUN GHOSTSCRIPT ON POSTSCRIPT FILE.  SYNTAX WILL
CCCC                 BE DIFFERENT ON UNIX AND WINDOWS.
C
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
        IF(IMANUF.EQ.'GD' .OR. IMANUF.EQ.'SVG' .OR.
     1     (IMANUF.EQ.'POST' .AND. IDEV.EQ.'PLO1'))THEN
          WRITE(ICOUT,2301)
 2301     FORMAT('</PRE>')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
C
          IF(IMANUF.EQ.'GD')THEN
            WRITE(ICOUT,2307)
 2307       FORMAT('<IMG SRC=')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,2309)IFILE
 2309       FORMAT('     "',A80,'"')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,2319)
 2319       FORMAT('     ALT="DATAPLOT GRAPH">')
            CALL DPWRST('XXX','WRIT')
          ELSEIF(IMANUF.EQ.'SVG')THEN
            WRITE(ICOUT,2327)
 2327       FORMAT('<EMBED TYPE="image/svg+xml" SRC=')
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,2329)IFILE
 2329       FORMAT('     "',A80,'">')
            CALL DPWRST('XXX','WRIT')
          ELSEIF(IMANUF.EQ.'POST')THEN
C
C  POSTSCRIPT TO JPEG USES GHOSTSCRIPT, CURRENTLY ONLY AVAILABLE
C  FOR WINDOWS AND UNIX.
C
C  NOTE: IF IPSTDV=PDF, THEN CONVERT TO PDF RATHER THAN JPEG
C
C  DETERMINE NAME FOR JPEG FILE
C
            IF(IOPSY1.EQ.'UNIX' .OR. IHOST1.EQ.'IBM-')THEN
              ILAST=80
              IPEROD=0
              DO2341I=80,1,-1
                IF(IFILE(I:I).NE.' ')THEN
                  ILAST=I
                  GOTO2345
                ENDIF
 2341         CONTINUE
              GOTO9000
 2345         CONTINUE
              DO2346I=80,1,-1
                IF(IFILE(I:I).EQ.'.')THEN
                  IPEROD=I
                  GOTO2349
                ENDIF
 2346         CONTINUE
 2349         CONTINUE
              IF(IPEROD.GT.0)THEN
                IFIL2=' '
                IFIL2(1:IPEROD)=IFILE(1:IPEROD)
                IFIL2(IPEROD+1:IPEROD+3)='jpg'
                IF(IPSTDV.EQ.'PDF')IFIL2(IPEROD+1:IPEROD+3)='pdf'
                NCTEMP=IPEROD+3
              ELSE
                IF(ILAST.GT.76)GOTO9000
                IFIL2=' '
                IFIL2(1:ILAST)=IFILE(1:ILAST)
                IFIL2(ILAST+1:ILAST+4)='.jpg'
                IF(IPSTDV.EQ.'PDF')IFIL2(ILAST+1:ILAST+4)='.pdf'
                NCTEMP=ILAST+4
              ENDIF
C
              IF(IPSTDV.EQ.'PDF')THEN
                WRITE(ICOUT,2371)
 2371           FORMAT('<A HREF=')
                CALL DPWRST('XXX','WRIT')
                WRITE(ICOUT,2373)IFIL2
 2373           FORMAT('     "',A80,'">')
                CALL DPWRST('XXX','WRIT')
                WRITE(ICOUT,2375)
 2375           FORMAT('     DATAPLOT GRAPH (PDF FORMAT)</A>')
                CALL DPWRST('XXX','WRIT')
              ELSE
                WRITE(ICOUT,2357)
 2357           FORMAT('<IMG SRC=')
                CALL DPWRST('XXX','WRIT')
                WRITE(ICOUT,2359)IFIL2
 2359           FORMAT('     "',A80,'"')
                CALL DPWRST('XXX','WRIT')
                WRITE(ICOUT,2369)
 2369           FORMAT('     ALT="DATAPLOT GRAPH">')
                CALL DPWRST('XXX','WRIT')
              ENDIF
C
C  FOR POSTSCRIPT, NEED TO RUN GHOSTSCRIPT TO CONVERT FROM POSTSCRIPT
C  TO JPEG.
C
CCCCC         CALL DPCONA(39,IQUOTE)
              IQUOTE='"'
              IBASLC=CHAR(92)
              ISTRIN=' '
              IF(NCGHPA.GT.0)THEN
                ISTRIN(1:NCGHPA)=IGSTPA(1:NCGHPA)
                N0=NCGHPA
                IF(IGSTPA(NCGHPA:NCGHPA).NE.IBASLC)THEN
                  N0=N0+1
                  ISTRIN(N0:N0)=IBASLC
                ENDIF
              ELSE
                N0=0
              ENDIF
              IF(IOPSY1.EQ.'UNIX')THEN
                N0=N0+1
                ISTRIN(N0:N0+2)='gs '
                N0=N0+2
              ELSEIF(IHOST1.EQ.'IBM-')THEN
                N0=N0+1
                ISTRIN(N0:N0+12)='GSWIN32C.EXE '
                N0=N0+13
              ENDIF
              N0=N0+1
              IF(IPSTDV.EQ.'PDF')THEN
                ISTRIN(N0:N0+38)=
     1             '-dNOPAUSE -dBATCH -q -sDEVICE=pdfwrite '
                N0=N0+39
              ELSE
                ISTRIN(N0:N0+34)='-dNOPAUSE -dBATCH -q -sDEVICE=jpeg '
                N0=N0+35
              ENDIF
              ISTRIN(N0:N0+12)='-sOutputFile='
              N0=N0+13
              ISTRIN(N0:N0)=IQUOTE
              N0=N0+1
              ISTRIN(N0:N0+NCTEMP-1)=IFIL2(1:NCTEMP)
              N0=N0+NCTEMP
              ISTRIN(N0:N0)=IQUOTE
              N0=N0+1
              ISTRIN(N0:N0)=' '
              N0=N0+1
              ISTRIN(N0:N0+ILAST-1)=IFILE(1:ILAST)
              N0=N0+ILAST-1
              CALL DPSYS2(ISTRIN,N0,ISUBRO,IERROR)
            ENDIF
          ENDIF
C
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,2399)
 2399     FORMAT('<PRE>')
          CALL DPWRST('XXX','WRIT')
        ENDIF
      ENDIF
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'LATE')THEN
        IF(IMANUF.EQ.'POST' .AND. IDEV.EQ.'PLO1')THEN
          CALL DPCONA(92,IBASLC)
          WRITE(ICOUT,3001)IBASLC
 3001     FORMAT(A1,'end{verbatim}')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          ILAST=80
          DO3006I=80,1,-1
            IF(IFILE(I:I).NE.' ')THEN
              ILAST=I
              GOTO3009
            ENDIF
 3006     CONTINUE
          ILAST=1
 3009     CONTINUE
          IF(IORNSW.EQ.'PORT' .OR. IORNSW.EQ.'LAN2')THEN
            WRITE(ICOUT,3011)IBASLC,IFILE(1:ILAST)
 3011       FORMAT(A1,'PGRAPHIC{',A80,'}')
            CALL DPWRST('XXX','WRIT')
          ELSE
            WRITE(ICOUT,3016)IBASLC,IFILE(1:ILAST)
 3016       FORMAT(A1,'LGRAPHIC{',A80,'}')
            CALL DPWRST('XXX','WRIT')
          ENDIF
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,3091)IBASLC
 3091     FORMAT(A1,'begin{verbatim}')
          CALL DPWRST('XXX','WRIT')
        ENDIF
      ENDIF
C
 2299 CONTINUE
      GOTO9000
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT.     **
C               ****************
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEP2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEP2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IDEV,IOPERA,IGENNU,IGENID
 9012 FORMAT('IDEV,IOPERA,IGENNU,IGENID = ',
     1A4,2X,A4,2X,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGO2,IERROR
 9013 FORMAT('IBUGO2,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IDEV,IOUNIT
 9014 FORMAT('IDEV,IOUNIT = ',A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IBUGO2,ISUBRO,IERROR
 9019 FORMAT('IBUGO2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IOUNIT
 9021 FORMAT('IOUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IFILE
 9022 FORMAT('IFILE  = ',A80)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)ISTAT
 9023 FORMAT('ISTAT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9024)IFORM
 9024 FORMAT('IFORM  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9025)IACCES
 9025 FORMAT('IACCES = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9026)IPROT
 9026 FORMAT('IPROT  = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)ICURST
 9027 FORMAT('ICURST = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)IENDFI
 9028 FORMAT('IENDFI = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9029)IREWIN
 9029 FORMAT('IREWIN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)ISUBN0
 9031 FORMAT('ISUBN0 = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IERRFI
 9032 FORMAT('IERRFI = ',A12)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)IOPERA,IDEV,IPL1CS,IPL2CS
 9041 FORMAT('IOPERA,IDEV,IPL1CS,IPL2CS = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEPP(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IDEFVP,IDEFHP,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IBUGO2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE NUMBER OF VERTICAL PICTURE POINTS
C              AND HORIZONTAL PICTURE POINTS FOR AN OUTPUT DEVICE.
C              THE NUMBER OF VERTICAL PICTURE POINTS
C              FOR DEVICE I WILL BE PLACED
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE INTEGER
C              VECTOR IDNVPP(.).
C              THE NUMBER OF HORIZONTAL PICTURE POINTS
C              FOR DEVICE I WILL BE PLACED
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE INTEGER
C              VECTOR IDNHPP(.).
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                     --IDEFVP
C                     --IDEFHP
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDNVPP (AN INTEGER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              NUMBER OF VERTICAL PICTURE POINTS
C                              FOR DEVICE I.
C                     --IDNHPP (AN INTEGER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              NUMBER OF HORIZONTAL PICTURE POINTS
C                              FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
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.GE.1.AND.IHARG(NUMARG).EQ.'?')GOTO8100
C
      IF(NUMARG.LE.1)GOTO1199
      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PICT'.AND.
     1IHARG(2).EQ.'POIN')GOTO1110
      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'PICT'.AND.
     1IHARG(3).EQ.'POIN')GOTO1140
      GOTO1199
C
 1110 CONTINUE
      IF(NUMARG.LE.2)GOTO1120
      IF(IHARG(3).EQ.'ON')GOTO1120
      IF(IHARG(3).EQ.'OFF')GOTO1120
      IF(IHARG(3).EQ.'AUTO')GOTO1120
      IF(IHARG(3).EQ.'DEFA')GOTO1120
      IF(NUMARG.GE.4.AND.IARGT(3).EQ.'NUMB'.AND.
     1IARGT(4).EQ.'NUMB')GOTO1125
      GOTO1199
C
 1120 CONTINUE
      IHOLD1=IDEFHP
      IHOLD2=IDEFVP
      GOTO1130
C
 1125 CONTINUE
      IHOLD1=IARG(3)
      IHOLD2=IARG(4)
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDNHPP(I)=IHOLD1
      IDNVPP(I)=IHOLD2
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)
 1136 FORMAT('THE PICTURE POINTS FOR ALL DEVICES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1137)
 1137 FORMAT('HAS JUST BEEN SET TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1138)IHOLD1,IHOLD2
 1138 FORMAT(I8,' (HORIZONTAL) BY ',I8,' (VERTICAL)')
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO1199
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDEPP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... PICTURE POINTS COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 PICTURE POINTS 781 1024')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDEPP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... PICTURE POINTS COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1160 CONTINUE
      IF(NUMARG.LE.3)GOTO1170
      IF(IHARG(4).EQ.'ON')GOTO1170
      IF(IHARG(4).EQ.'OFF')GOTO1170
      IF(IHARG(4).EQ.'AUTO')GOTO1170
      IF(IHARG(4).EQ.'DEFA')GOTO1170
      IF(NUMARG.GE.5.AND.IARGT(4).EQ.'NUMB'.AND.
     1IARGT(5).EQ.'NUMB')GOTO1175
      GOTO1199
C
 1170 CONTINUE
      IHOLD1=IDEFHP
      IHOLD2=IDEFVP
      GOTO1180
C
 1175 CONTINUE
      IHOLD1=IARG(4)
      IHOLD2=IARG(5)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDNHPP(I)=IHOLD1
      IDNVPP(I)=IHOLD2
C
      IF(IFEEDB.EQ.'OFF')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
 1199 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)
 8111 FORMAT('THE CURRENT NUMBER OF PICTURE POINTS IS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8112)IDNHPP(1)
 8112 FORMAT('            --HORIZONTAL = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8113)IDNVPP(1)
 8113 FORMAT('            --VERTICAL   = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8121)
 8121 FORMAT('THE DEFAULT NUMBER OF PICTURE POINTS IS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8122)IDEFHP
 8122 FORMAT('            --HORIZONTAL = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8123)IDEFVP
 8123 FORMAT('            --VERTICAL   = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEPW(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IPL1NU,IPL1NA,
     1IPL2NU,IPL2NA,
     1IDEFPO,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IDNVOF,IDNHOF,
     1ICAPSW,ICAPNU,
     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE POWER STATUS (ON/OFF) FOR AN OUTPUT DEVICE.
C              THE POWER (ON/OFF) FOR DEVICE I
C              WILL BE PLACED IN THE I-TH ELEMENT OF THE CHARACTER
C              VECTOR IDPOWE(.).
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                     --IDEFPO
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDPOWE (A CHARACTER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              POWER (ON/OFF) FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1988.  SEP. UNITS FOR GR & ALPHA I/O (ALAN)
C     UPDATED         --JANUARY   1989.  CALL LIST FOR OFFSET VAR (ALAN)
C     UPDATED         --JANUARY   1989.  DEVICE 2 OFF CASE (ALAN)
C     UPDATED         --MAY       1989.  POSTSCRIPT TRANSLATION FIX (ALAN)
C     UPDATED         --MARCH     1990.  X11 FIX
C     UPDATED         --MAY       1990.  OPEN AS SYNONYM FOR ON, ADD CLOSE
C     UPDATED         --MAY       1992.  IOPERA='CLOS'
C     UPDATED         --MAY       1992.  FIX BUG IGENID WHEN I = 3
C     UPDATED         --MAY       1992.  SKIP MESSAGE FOR DEVICE 3
C     UPDATED         --MAY       1992.  COMMENT OUT ISUBG4 & IBUGG4
C     UPDATED         --JUNE      1992.  DON'T CALL GRINDE FOR ON CASE
C     UPDATED         --OCTOBER   1996.  QWIN PATCH
C     UPDATED         --FEBRUARY  2001.  FOR GD AND GDI DEVICES, DO NOT OPEN OR
C                                        CLOSE OUTPUT FILE (DONE BY UNERLYING C
C                                        CODES), PASS IGDFLG TO DPDEP2
C     UPDATED         --SEPTEMBER 2002.  ICAPSW
C     UPDATED         --AUGUST    2004.  FOR DEVICE 3, CHECK DEFAULT
C                                        COLOR SETTING WHEN DEVICE IS
C                                        POSTSCRIPT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 ICAPSW
C
      CHARACTER*80 IPL1NA
      CHARACTER*80 IPL2NA
C
      CHARACTER*4 IDEFPO
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
C
      CHARACTER*4 IANS
      CHARACTER*4 IBUGO2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
      CHARACTER*4 IOPERA
      CHARACTER*4 IGENID
      CHARACTER*4 IGDFLG
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
C
      DIMENSION IDNVOF(*)
      DIMENSION IDNHOF(*)
C
      DIMENSION IANS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOST.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      IFOUND='NO'
      IERROR='NO'
CCCCC THE FOLLOWING 2 LINES WERE COMMENTED OUT MAY 1992 (JJF)
CCCCC IBUGG4='OFF'
CCCCC ISUBG4='9999'
C
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPW')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('AT THE BEGINNING OF DPDEPW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGO2
   53 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IFOUND,IERROR
   60 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,68)NUMARG
   68 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO70I=1,NUMARG
      WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
   71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
   70 CONTINUE
   90 CONTINUE
C
      IF(NUMARG.LE.0)GOTO9000
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POWE')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'POWE')GOTO1140
      GOTO9000
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1120
      IF(IHARG(2).EQ.'ON')GOTO1120
      IF(IHARG(2).EQ.'OPEN')GOTO1120
      IF(IHARG(2).EQ.'OFF')GOTO1125
      IF(IHARG(2).EQ.'CLOS')GOTO1125
      IF(IHARG(2).EQ.'AUTO')GOTO1120
      IF(IHARG(2).EQ.'DEFA')GOTO1127
      GOTO1120
C
 1120 CONTINUE
      IHOLD='ON'
      GOTO1130
C
 1125 CONTINUE
      IHOLD='OFF'
      GOTO1130
C
 1127 CONTINUE
      IHOLD=IDEFPO
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDPOWE(I)=IHOLD
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)IHOLD
 1136 FORMAT('THE POWER FOR ALL DEVICES HAS JUST BEEN SET TO ',
     1A4)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO9000
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDEPW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... POWER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 POWER ON')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1150 CONTINUE
C
      I=IARG(1)
C
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDEPW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... POWER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C  MAY, 1990, ADD "CLOSE" AND "OPEN"
C  JUNE 1992.  HANDLE "ON" AND "OPEN" DIFFERENTLY
 1160 CONTINUE
      IF(NUMARG.LE.2)GOTO1170
      IF(IHARG(3).EQ.'ON')GOTO1170
CCCCC IF(IHARG(3).EQ.'OPEN')GOTO1170
      IF(IHARG(3).EQ.'OPEN')GOTO1172
      IF(IHARG(3).EQ.'OFF')GOTO1175
      IF(IHARG(3).EQ.'CLOS')GOTO1176
      IF(IHARG(3).EQ.'AUTO')GOTO1170
      IF(IHARG(3).EQ.'DEFA')GOTO1177
      GOTO1170
C
 1170 CONTINUE
      IHOLD='ON'
      GOTO1180
C
CCCCC JUNE 1992.  FOLLOWING BLOCK ADDED TO HANDLE OPEN
 1172 CONTINUE
      IDPOWE(I)='ON'
      IOPERA='OPEN'
      IFOUND='YES'
      IF(I.GT.NUMDEV)NUMDEV=I
      GOTO1179
C
 1175 CONTINUE
      IHOLD='OFF'
      GOTO1180
C
 1176 CONTINUE
      IDPOWE(I)='OFF'
      IFOUND='YES'
      IF(I.GT.NUMDEV)NUMDEV=I
CCCCC THE FOLLOWING LINE WAS ADDED   MAY 1992  (JJF)
      IOPERA='CLOS'
      GOTO1179
C
 1177 CONTINUE
      IHOLD=IDEFPO
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDPOWE(I)=IHOLD
C
      IF(I.GT.NUMDEV.AND.IHOLD.EQ.'ON')NUMDEV=I
C
      IOPERA=IDPOWE(I)
C  FOLLOWING LINE ADDED MAY, 1990.
 1179 CONTINUE
C
C     MAY, 1988.  DEFINE SEPARATE UNITS FOR GRAPHICS AND ALPHANUMERIC
C     OUTPUT.  WILL BE SAME UNIT ON MOST SYSTEMS.  HOWEVER, SOME SUCH
C     AS CDC NOS/VE REQUIRE DIFFERENT ATTRIBUTES FOR GRAPHICS OUTPUT.
CCCCC IGENNU=IPR
      IGENNU=IPRGR
C
      IF(I.EQ.1)THEN
        IGENID='SCRE'
        IF(IDMANU(1).EQ.'LATE'.AND.ICAPSW.EQ.'ON')THEN
          IGENNU=ICAPNU
          IPRGR=ICAPNU
        ELSE
          IGENNU=IPRGR
        ENDIF
      ELSEIF(I.EQ.2)THEN
        IGENNU=IPL1NU
        IGENID='PLO1'
      ELSEIF(I.EQ.3)THEN
        IGENNU=IPL2NU
CCCCC THE FOLLOWING LINE WAS FIXED   MAY 1992 (JJF)
CCCCC IF(I.EQ.2)IGENID='PLO2'
        IGENID='PLO2'
C
      ELSEIF(I.GE.4)THEN
        IGENNU=IDUNIT(I)
        IGENID='GENE'
      ENDIF
C
      IGDFLG='OFF'
      IF(IDMANU(I).EQ.'GD  '.OR.IDMANU(I).EQ.'GDI ')IGDFLG='ON'
C
C     MAY,1988 CHANGE.
CCCCC IF(IGENNU.NE.IPR)
CCCCC IF(IGENNU.NE.IPRGR)
      CALL DPDEP2(IOPERA,IGENNU,IGENID,IGDFLG,
     1ICAPSW,
     1IANS,IWIDTH,IBUGO2,ISUBRO,IFOUND,IERROR)
C
CCCCC JUNE 1992.  DON'T CALL GRINDE FOR ON CASE
      IF(IOPERA.EQ.'OPEN')GOTO2000
      IF(IOPERA.EQ.'ON')GOTO2000
      GOTO2090
 2000 CONTINUE
C
CCCCC AUGUST 2004: FOR DEVICE 3 POSTSCRIPT, CHECK FOR DEFAULT
CCCCC COLOR SETTING (IPSTDC).
C
      IF(I.EQ.3 .AND. IDMANU(I).EQ.'POST')THEN
        IF(IPSTDC.EQ.'ON')THEN
           IDCOLO(I)='ON'
           IGCOLO=IDCOLO(I)
        ELSE
           IDCOLO(I)='OFF'
           IGCOLO=IDCOLO(I)
        ENDIF
      ENDIF
C
      IMANUF=IDMANU(I)
      IMODEL=IDMODE(I)
      IGUNIT=IDUNIT(I)
C  AUGUST, 1988.  FOLLOWING LINE ADDED FOR POSTSCRIPT DEVICE
      ANUMVP=IDNVPP(I)
C  MARCH, 1990.  FOLLOWING LINE ADDED FOR X11 DEVICE
      ANUMHP=IDNHPP(I)
CCCCC THE FOLLOWING 2 LINES WERE ADDED           MAY 1989
CCCCC TO FIX POSTSCRIPT TRANSLATION (ALAN)       MAY 1989
      IOFFSV=IDNVOF(I)
      IOFFSH=IDNHOF(I)
CCCCC THE FOLLOWING LINE WAS COMMENTED OUT MAY 1992 (JJF)
CCCCC IBUGG4=IBUGO2
CCCCC JUNE 1992. FOLLOWING LINE MODIFIED
CCCCC CALL GRINDE
      IF(IOPERA.EQ.'OPEN')CALL GRINDE
CCCCC THE FOLLOWING THREE LINES ADDED MARCH, 1990 (ALAN).  THE X11
CCCCC DEVICE CAN DYNAMICALLY CHANGE THE NUMBER OF PICTURE POINTS.
      IF(IMANUF.NE.'X11'.AND.IMANUF.NE.'QWIN')GOTO2090
      IDNVPP(I)=ANUMVP
      IDNHPP(I)=ANUMHP
 2090 CONTINUE
C
CCCCC THE FOLLOWING 3 LINES WERE ADDED   MAY 1992 (JJF)
      IF(NUMARG.GE.1)THEN
         IF(IARGT(1).EQ.'NUMB'.AND.IARG(1).EQ.3)GOTO1199
      ENDIF
      IF(IFEEDB.EQ.'OFF')GOTO1199
      IF(I.EQ.1.AND.IDMANU(I).EQ.'LATE'.AND.ICAPSW.EQ.'ON')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IF(I.EQ.2)WRITE(ICOUT,1192)IPL1NA
 1192 FORMAT('            FILE NAME (LOCAL)--',A80)
      IF(I.EQ.2)CALL DPWRST('XXX','BUG ')
      IF(I.EQ.3)WRITE(ICOUT,1193)IPL2NA
 1193 FORMAT('            FILE NAME (LOCAL)--',A80)
      IF(I.EQ.3)CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      IF(IBUGO2.EQ.'OFF'.AND.ISUBRO.NE.'DEPW')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('AT THE END       OF DPDEPW--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGO2
 9013 FORMAT('IBUGO2 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGG4,ISUBG4
 9014 FORMAT('IBUGG4,ISUBG4 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IOPERA,IMANUF,IMODEL
 9015 FORMAT('IOPERA,IMANUF,IMODEL = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IFOUND,IERROR
 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMARG
 9028 FORMAT('NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMARG
      WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDERS(NPTS,NLAB,
     1AMEAN,ASD,N,
     1XDL,XDLS2,SEDLK1,SEDLK2,
     1DLOWDL,DHIGDL,DLOWD2,DHIGD2,
     1IWRITE,
     1ICAPSW,ICAPTY,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--IMPLEMENT DERSIMONIAN-Laird APPROACH TO CONSENSUS MEANS.
C              THIS METHOD USES THE GRAYBILL-DEAL ESTIMATE AS THE
C              VALUE FOR THE CONSENSUS MEAN, BUT IT TAKES THE
C              BETWEEN LAB VARIANCE INTO ACCOUT WHEN ESTIMATING
C              THE STANDARD ERROR.
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.
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 XDL
      REAL XDLS2
      REAL SEDLK1
      REAL SEDLK2
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='DPDE'
      ISUBN2='RS  '
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF DPDERS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)NPTS,NLAB
   52   FORMAT('NPTS,NLAB = ',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     STEP 1: GRAYBILL DEAL ESTIMATE OF MEAN.  THIS
C             WILL BE USED AS AN INITIAL ESTIMATE OF
C             THE CONSENSUS MEAN THAT IS USED TO COMPUTE
C             THE DERSIMONIAN WEIGHTS.
C
C             XGD = SUM[n(i)*xmean(i)/xvar(i)]/SUM[n(i)/xvar(i)]
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO910I=1,NLAB
        DNI=DBLE(N(I))
        DMEAN=DBLE(AMEAN(I))
        DVARI=DBLE(ASD(I))**2
        DSUM1=DSUM1 + DMEAN*DNI/DVARI
        DSUM2=DSUM2 + DNI/DVARI
  910 CONTINUE
      XGD=REAL(DSUM1/DSUM2)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
        WRITE(ICOUT,912)XGD,DSUM1,DSUM2
  912   FORMAT('XGD,DSUM1,DSUM2 = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     STEP 2: ESTIMATE YDL (ESTIMATE OF BETWEEN LAB VARIANCE)
C
C                YDL = MAX[0,DTERM1/(DTERM2 - DTERM3*DTERM4)]
C
C             WHERE
C
C                DTERM1 = SUM[n(i)*(xmean(i)-xgd)**2/xvari(i)] - NLAB + 1
C                DTERM2 = SUM[n(i)/xvari(i)]
C                DTERM3 = SUM[n(i)**2/xvari(i)**2]
C                DTERM4 = 1/SUM[n(i)/xvari(i)]
C
      DP=DBLE(NLAB)
      DPP=1.0D0/DBLE(NLAB-1)
      DRR=DP**(DP*DPP/2.0D0)
C
      DTERM2=DSUM2
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO920I=1,NLAB
        DMEAN=DBLE(AMEAN(I))
        DVARI=DBLE(ASD(I))**2
        DNI=DBLE(N(I))
        DSUM1=DSUM1 + DNI*(DMEAN - XGD)**2/DVARI
        DSUM2=DSUM2 + (DNI/DVARI)**2
  920 CONTINUE
      DTERM1=DSUM1 - DP + 1.0D0
      DTERM3=DTERM2 - DSUM2/DTERM2
      YDL=MAX(0.0D0,DTERM1/DTERM3)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
        WRITE(ICOUT,921)DTERM1,DTERM2,DTERM3
  921   FORMAT('DTERM1,DTERM2,DTERM3 = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,922)YDL,DSUM1,DSUM2
  922   FORMAT('YDL,DSUM1,DSUM2 = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     STEP 3: ESTIMATE THE DERSIMONIAN-LAIRD WEIGHTS AND USE
C             THIS TO COMPUTE THE DERSIMONIAN-LAIRD CONSENSUS
C             MEAN.
C
C             STEP 3A: COMPUTE THE SUM OF THE WEIGHTS
C
      DSUM1=0.0D0
      DO930I=1,NLAB
        DVARI=DBLE(ASD(I))**2
        DNI=DBLE(N(I))
        DSUM1=DSUM1 + 1.0D0/((DVARI/DNI) + YDL)
  930 CONTINUE
      DWS=DSUM1
C
C             STEP 3B: COMPUTE THE SCALED WEIGHT TIMES THE LAB MEAN
C
      DSUM1=0.0D0
      DO935I=1,NLAB
        DMEAN=DBLE(AMEAN(I))
        DVARI=DBLE(ASD(I))**2
        DNI=DBLE(N(I))
        DTERM1=1.0D0/((DVARI/DNI) + YDL)
        DWI=DTERM1/DWS
        DSUM1=DSUM1 + DMEAN*DWI
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
          WRITE(ICOUT,937)DWS,DWI,DSUM1
  937     FORMAT('DWS,DWI,DSUM1 = ',3G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
  935 CONTINUE
      XDL=DSUM1
C
C     STEP 4: ESTIMATE THE STANDARD ERROR OF THE DERSIMONIAN-LAIRD
C             CONSENSUS MEAN ESTIMATE
C
      IDF=NLAB-1
      ALPHA=0.975
      CALL TPPF(REAL(ALPHA),IDF,APPF)
      DPH=DBLE(APPF)/DRR/(DSQRT(DP-1.0D0))
      DSUM1=0.0D0
      DSUM2=0.0D0
      DPROD1=1.0D0
      DO940I=1,NLAB
        DNI=DBLE(N(I))
        DMEAN=DBLE(AMEAN(I))
        DVARI=DBLE(ASD(I))**2
        DTERM1=1.0D0/((DVARI/DNI) + YDL)
        DWI=DTERM1/DWS
        DSUM1=DSUM1 + DWI*DWI*(DMEAN - XDL)**2/(1.0D0 - DWI)
        DSUM2=DSUM2 + DWI*(DMEAN - XDL)**2
        DPROD1=DPROD1*DWI
  940 CONTINUE
      XDLS2=REAL(DSUM1)
      SEDLK1=SQRT(XDLS2)
      SEDLK2=2.0*SQRT(XDLS2)
      DPROD1=DPROD1**DPP
      DRI=DPH*DSQRT(DSUM2)/DSQRT(DPROD1)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
        WRITE(ICOUT,942)XDLS2,DSUM1,SEDLK1,SEDLK2
  942   FORMAT('XDLS2,DSUM1,SEDLK1,SEDLK2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     STEP 4: COMPUTE THE 95% CONFIDENCE INTERVAL FOR THE
C             CONSENSUS MEAN ESTIMATE
C
      DLOWDL=DBLE(XDL - APPF*SQRT(XDLS2))
      DHIGDL=DBLE(XDL + APPF*SQRT(XDLS2))
      DLOWD2=DBLE(XDL) - DRI
      DHIGD2=DBLE(XDL) + DRI
C
      IF(IPRINT.EQ.'ON')THEN
      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN
C
        WRITE(ICOUT,5107)
 5107   FORMAT('<UL>')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5111)
 5111   FORMAT('<TABLE NOBORDER>')
        CALL DPWRST('XXX','WRIT')
C
 5121   FORMAT('   <TR>')
 5123   FORMAT('      <TD ALIGN=LEFT VALIGN=BOTTOM WIDTH=400>')
 5127   FORMAT('      </TD>')
 5126   FORMAT('      <TD ALIGN=RIGHT VALIGN=BOTTOM WIDTH=150>')
 5128   FORMAT('   </TR>')
 5151   FORMAT('         ',I8)
 5152   FORMAT('         ',F15.7)
 5155   FORMAT('         &nbsp;')
 5191   FORMAT('</TABLE>')
 5193   FORMAT('</UL>')
C
        WRITE(ICOUT,5121)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5123)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5170)
 5170   FORMAT('         <b>10. Method: DerSimonian Laird</b>')
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     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)XDL
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         'Estimate of Variance of the Mean:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5126)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5152)XDLS2
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         'Estimate of Between-Lab Variance:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5126)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5152)YDL
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         'Standard Uncertainty (<i>k</i> = 1):')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5126)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5152)SEDLK1
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         'Expanded Uncertainty (<i>k</i> = 2):')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5127)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5126)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,5152)SEDLK2
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     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(DLOWDL)
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     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(DHIGDL)
        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,5187)
 5187   FORMAT('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     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(DLOWD2)
        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,5188)
 5188   FORMAT('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     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(DHIGD2)
        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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         'Note: DerSimonian Laird 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('         &nbsp;&nbsp;&nbsp;&nbsp; ',
     1         '&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ',
     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 10. Method: DerSimonian-Laird:} & ',
     1         2X,A1,A1)
 8012   FORMAT(5X,'Estimate of Consensus Mean: & ',
     1         F15.7,2X,A1,A1)
 8013   FORMAT(5X,'Estimate of Variance of Consensus Mean: & ',
     1         F15.7,2X,A1,A1)
 8014   FORMAT(5X,'Estimate of Between-Lab Variance: & ',
     1         F15.7,2X,A1,A1)
C
        WRITE(ICOUT,8011)IBASLC,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8012)XDL,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8013)XDLS2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8014)YDL,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
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)SEDLK1,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8021)SEDLK2,IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
C
 8024   FORMAT(5X,'Lower 95',A1,'% Confidence Interval (t-value): & ',
     1         F15.7,2X,A1,A1)
 8025   FORMAT(5X,'Upper 95',A1,'% Confidence Interval (t-value): & ',
     1         F15.7,2X,A1,A1)
 8026   FORMAT(5X,'Lower 95',A1,'% Confidence Interval (Rukhin): & ',
     1         F15.7,2X,A1,A1)
 8027   FORMAT(5X,'Upper 95',A1,'% Confidence Interval (Rukhin): & ',
     1         F15.7,2X,A1,A1)
 8028   FORMAT(5X,'Note: DerSimonian-Laird Best Usage: & ',
     1         2X,A1,A1)
 8029   FORMAT(5X,'      Any Number of Labs & ',
     1         2X,A1,A1)
        WRITE(ICOUT,8024)IBASLC,REAL(DLOWDL),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8025)IBASLC,REAL(DHIGDL),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8026)IBASLC,REAL(DLOWD2),IBASLC,IBASLC
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,8027)IBASLC,REAL(DHIGD2),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 10. Method: DerSimonian-Laird'
        IVALUE(1)(1:1)=IBASLC
        NCHAR(1)=32
        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)=XDL
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=42
        IVALUE(1)='   Estimate of Variance of Consensus Mean:'
        AVALUE(2)=XDLS2
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=36
        IVALUE(1)='   Estimate of Between-Lab Variance:'
        AVALUE(2)=YDL
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=32
        IVALUE(1)='   Standard Uncertainty (k = 1):'
        AVALUE(2)=SEDLK1
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=32
        IVALUE(1)='   Expanded Uncertainty (k = 2):'
        AVALUE(2)=SEDLK2
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=40
        IVALUE(1)='   Lower 95% (t-value) Confidence Limit:'
        AVALUE(2)=REAL(DLOWDL)
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=40
        IVALUE(1)='   Upper 95% (t-value) Confidence Limit:'
        AVALUE(2)=REAL(DHIGDL)
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=39
        IVALUE(1)='   Lower 95% (Rukhin) Confidence Limit:'
        AVALUE(2)=REAL(DLOWD2)
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        NCHAR(1)=39
        IVALUE(1)='   Upper 95% (Rukhin) Confidence Limit:'
        AVALUE(2)=REAL(DHIGD2)
        CALL DPRTF5(IVALUE(1),NCHAR(1),AVALUE,NHEAD,IFLAG1)
C
        IVALUE(1)='   Note: DerSimonian-Laird Best Usage:'
        NCHAR(1)=38
        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
        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('10. Method: DerSimonian Laird')
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4002)XDL
 4002   FORMAT('    Estimate of Consensus Mean:             ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4003)XDLS2
 4003   FORMAT('    Estimate of Variance of Consensus Mean: ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4004)YDL
 4004   FORMAT('    Estimate of Between-Lab Variance:       ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4013)SEDLK1
 4013   FORMAT('    Standard Uncertainty (k = 1):           ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4014)SEDLK2
 4014   FORMAT('    Expanded Uncertainty (k = 2):           ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4021)IDF
 4021   FORMAT('    Degrees of Freedom:                     ',
     1         I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4022)APPF
 4022   FORMAT('    t Percent Point Value:                  ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4026)REAL(DLOWDL)
 4026   FORMAT('    Lower 95% (t-value) Confidence Limit:   ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4027)REAL(DHIGDL)
 4027   FORMAT('    Upper 95% (t-value) Confidence Limit:   ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4028)REAL(DLOWD2)
 4028   FORMAT('    Lower 95% (Rukhin) Confidence Limit:    ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4029)REAL(DHIGD2)
 4029   FORMAT('    Upper 95% (Rukhin) Confidence Limit:    ',
     1         F15.7)
        CALL DPWRST('XXX','WRIT')
C
        WRITE(ICOUT,4031)
 4031   FORMAT('    Note: DerSimonian-Laird Best Usage:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,4032)
 4032   FORMAT('          Any Number of Labs')
        CALL DPWRST('XXX','WRIT')
C
      ENDIF
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DERS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF DPDERS--')
        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)XDL,XDLS2
 9014   FORMAT('XDL,XDLS2 = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)DLOWDL,DHIGDL
 9015   FORMAT('DLOWDL,DHIGDL = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPDERV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
     1IA,PARAM,IPARN,IPARN2,
     1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1,
     1NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L,
     1NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R,
     1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--TREAT THE LET CASE FOR
C              FINDING THE DERIVATIVE OF A FUNCTION.
C     NOTE--THE OUTPUT MAY BE THE DERIVATIVE FUNCTION,
C           OR MAY BE THE DERIVATIVE EVALUATE AT A POINT
C           OR AT A SERIES OF POINTS.
C     EXAMPLE--LET A = DERIVATIVE X**3+2*X**2-4*X+5 FOR X = 1
C            --LET X = DERIVATIVE SIN(2*X) WRT X FOR X = 2
C            --LET X = DERIVATIVE SIN(A*B*X+2*C)+E*X**4 WRT X FOR X = Z
C            --LET X = DERIVATIVE F1 WRT X FOR X = 7
C            --LET FUNCTION X = DERIVATIVE F1 WRT X
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --MARCH     1979.
C     UPDATED         --JULY      1981.
C     UPDATED         --JANUARY   1982.
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IA
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IFOUNZ
      CHARACTER*4 ITYPE
      CHARACTER*4 IHOL
      CHARACTER*4 IHOL2
      CHARACTER*4 IERRO1
C
      CHARACTER*4 ITYW1L
      CHARACTER*4 ICAT1L
      CHARACTER*4 INLI1L
      CHARACTER*4 ITYW2L
      CHARACTER*4 ITYW1R
      CHARACTER*4 ICAT1R
      CHARACTER*4 INLI1R
      CHARACTER*4 ITYW2R
C
      CHARACTER*4 IANGLU
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      CHARACTER*4 IDUMV
      CHARACTER*4 IDUMV2
      CHARACTER*4 ILAB
      CHARACTER*4 IOLD
      CHARACTER*4 IOLD2
      CHARACTER*4 INEW
      CHARACTER*4 IFUNC4
C
      CHARACTER*4 ITYPED
      CHARACTER*4 IWD1
      CHARACTER*4 IWD12
      CHARACTER*4 IWD2
      CHARACTER*4 IWD22
      CHARACTER*4 IKEY
      CHARACTER*4 IKEY2
      CHARACTER*4 IHOUT
      CHARACTER*4 IHOUT2
      CHARACTER*4 NEWNAM
      CHARACTER*4 INCLUN
      CHARACTER*4 IOLDNA
      CHARACTER*4 IOLDN2
      CHARACTER*4 MESSAG
      CHARACTER*4 IHLEFT
      CHARACTER*4 IHLEF2
      CHARACTER*4 IFOUN1
      CHARACTER*4 IFOUN2
      CHARACTER*4 IDUQT1
      CHARACTER*4 IDUMVQ
      CHARACTER*4 INEW2
      CHARACTER*4 IUOUT
      CHARACTER*4 IHXPT1
      CHARACTER*4 IHPARN
      CHARACTER*4 IHPAR2
      CHARACTER*4 ICASEL
      CHARACTER*4 ITTEST
      CHARACTER*4 JUSE
      CHARACTER*4 IERRO2
      CHARACTER*4 IHL
      CHARACTER*4 IHL2
C
      CHARACTER*4 IFOUN3
      CHARACTER*4 IBUGIV
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION IFOUNZ(*)
      DIMENSION IBEGIN(*)
      DIMENSION IEND(*)
      DIMENSION ITYPE(*)
      DIMENSION IHOL(*)
      DIMENSION IHOL2(*)
      DIMENSION INT1(*)
      DIMENSION FLOAT1(*)
      DIMENSION IERRO1(*)
C
      DIMENSION ITYPEH(*)
      DIMENSION IW21HO(*)
      DIMENSION IW22HO(*)
      DIMENSION W2HOLD(*)
C
      DIMENSION IA(*)
      DIMENSION PARAM(*)
      DIMENSION IPARN(*)
      DIMENSION IPARN2(*)
C
      DIMENSION IDUMV(100)
      DIMENSION IDUMV2(100)
      DIMENSION JLOC(100)
C
      DIMENSION ILAB(10)
      DIMENSION IOLD(10)
      DIMENSION IOLD2(10)
      DIMENSION INEW(10)
      DIMENSION INEW2(10)
C
      DIMENSION IFUNC4(1000)
      DIMENSION RESULT(MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZ2.INC'
      EQUIVALENCE (G2RBAG(IGAR45),RESULT(1))
CCCCC END CHANGE
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPDE'
      ISUBN2='RV  '
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
C               *******************************************
C               **  TREAT THE DEFINITE INTEGRAL SUBCASE  **
C               **  OF THE LET COMMAND                   **
C               *******************************************
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO
   52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGCO,IBUGEV
   53 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)IBUGQ
   54 FORMAT('IBUGQ = ',A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C               **********************************
C               **  STEP 1--                    **
C               **  INITIALIZE SOME VARIABLES.  **
C               **********************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NEWNAM='NO'
C
      MAXN2=MAXCHF
      MAXN3=MAXCHF
      MAXN4=MAXCHF
C
C               *******************************************************
C               **  STEP 1.5--                                       **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
C               *******************************************************
C
      ISTEPN='1.5'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=1
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
     1IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ****************************************************************
C               **  STEP 2--                                                   *
C               **  EXAMINE THE LEFT-HAND SIDE--                               *
C               **  IS THE VARIABLE 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'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ITYPED='V'
      IF(IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')ITYPED='F'
C
      IF(ITYPED.EQ.'F')IHLEFT=IHARG(2)
      IF(ITYPED.EQ.'F')IHLEF2=IHARG2(2)
      IF(ITYPED.EQ.'V')IHLEFT=IHARG(1)
      IF(ITYPED.EQ.'V')IHLEF2=IHARG2(1)
      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)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2201)
 2201 FORMAT('***** ERROR IN DPDERV--')
      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'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IWD1='DERI'
      IWD12='VATI'
      IWD2='WRT '
      IWD22='    '
      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,IFUNC2,N2,
     1IBUGA3,IFOUND,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IF(IFOUND.EQ.'YES')GOTO3900
C
      IWD1='DIFF'
      IWD12='EREN'
      IWD2='WRT '
      IWD22='    '
      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,IFUNC2,N2,
     1IBUGA3,IFOUND,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      IF(IFOUND.EQ.'YES')GOTO3900
C
      IWD1='PART'
      IWD12='IAL '
      IWD2='WRT '
      IWD22='    '
      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,IFUNC2,N2,
     1IBUGA3,IFOUND,IERROR)
      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 DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3102)
 3102 FORMAT('      INVALID COMMAND FORM FOR DERIVATIVE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3103)
 3103 FORMAT('      GENERAL FORM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3104)
 3104 FORMAT('      LET FUNCTION ... = DERIVATIVE ... WRT ... ',
     1'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,IWIDTH)
 3106 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3900 CONTINUE
C
C               ***********************************************************
C               **  STEP 4--                                             **
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'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL 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
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO5090
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,IFUNC3,N3,IBUGA3)
C
      WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1)
 5081 FORMAT('DIFFERENTIATION VARIABLE  = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
C
 5090 CONTINUE
C
C               *************************************
C               **  STEP 5--                       **
C               **  EXTRACT QUALIFIER INFORMATION. **
C               *************************************
C
      ISTEPN='5'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *********************************************************
C               **  STEP 5.1--                                         **
C               **  DETERMINE THE DUMMY VARIABLE FOR THE INTEGRATION.  **
C               *********************************************************
C
      ISTEPN='5.1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IKEY='WRT '
      IKEY2='    '
      ISHIFT=1
      ILOCA=1
      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(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO5119
      IDUMV(1)=IHOUT
      IDUMV2(1)=IHOUT2
      NUMDV=1
      ILOCDV=ILOC2
      GOTO5190
 5119 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5181)
 5181 FORMAT('***** ERROR IN DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5182)
 5182 FORMAT('      INVALID COMMAND FORM FOR DIFFERENTIATION.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5183)
 5183 FORMAT('      NO VARIABLE OF DIFFERENTIATION DEFINED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5185)
 5185 FORMAT('      GENERAL FORM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5186)
 5186 FORMAT('      LET ... = DERIVATIVE ... WRT ... ',
     1'FOR ... = ... ...')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5187)
 5187 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,5189)(IANS(I),I=1,IWIDTH)
 5189 FORMAT('      ',100A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 5190 CONTINUE
C
C               *************************************************
C               **  STEP 6.1--                                 **
C               **  DETERMINE THE EXACT ANALYTICAL DERIVATIVE  **
C               **  OF THE FUNCTION.                           **
C               *************************************************
C
      ISTEPN='6'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IPASS=2
      NUMPAR=0
CCCCC CALL COMPID(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPAR,IANGLE,
CCCCC1IDUMV,IDUMV2,NUMDV,IFUNC4,N4,IBUGA3,IFOUND,IERROR)
      CALL COMPID(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPAR,
     1IDUMV,IDUMV2,NUMDV,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,IFUNC4,N4,
     1IBUGCO,IBUGEV,ISUBRO,IERROR)
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO6139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6121)
 6121 FORMAT('IN DPDERV, AFTER RETURNING FROM COMPID--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6122)IPASS
 6122 FORMAT('IPASS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6123)N3,IFOUND
 6123 FORMAT('N3,IFOUND = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6124)(IFUNC3(I),I=1,N3)
 6124 FORMAT('IFUNC3(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6125)N4
 6125 FORMAT('N4 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6126)(IFUNC4(I),I=1,N4)
 6126 FORMAT('IFUNC4(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6127)NUMPAR
 6127 FORMAT('NUMPAR = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO6128I=1,NUMPAR
      WRITE(ICOUT,6129)I,IPARN(I),IPARN2(I)
 6129 FORMAT('I,IPARN(I),IPARN2(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 6128 CONTINUE
 6139 CONTINUE
C
      IF(IERROR.EQ.'YES')GOTO9000
C
C               *******************************************
C               **  STEP 6.2--                           **
C               **  PRINT OUT A BRIEF MESSAGE            **
C               **  INDICATING WHETHER OR NOT THE        **
C               **  ANALYTIC DERIVATIVE HAS BEEN FOUND,  **
C               **  AND (IF FOUND) GIVING EXPLICITELY    **
C               **  WHAT THE ANALYSTIC FUNCTION IS.      **
C               **  IF NOT FOUND, COPY IFUNC3(.)         **
C               **  INTO IFUNC4(.), AND COPY N3 INTO N4. **
C               *******************************************
C
      ISTEPN='6.2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
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,IFUNC3,N3,IBUGA3)
C
      ILAB(1)='DIFF'
      ILAB(2)='EREN'
      ILAB(3)='TIAT'
      ILAB(4)='ION '
      ILAB(5)='VAR.'
      ILAB(6)='  = '
      NUMWDL=6
CCCCC CALL DPPRIF(ILAB,NUMWDL,IDUMV,1,IBUGA3)
      WRITE(ICOUT,6141)(ILAB(I),I=1,NUMWDL),IDUMV(1),IDUMV2(1)
 6141 FORMAT(20X,6A4,2A4)
      CALL DPWRST('XXX','BUG ')
C
      IF(IFOUND.EQ.'YES')GOTO6219
      IFUNC4(1)='N'
      IFUNC4(2)='O'
      IFUNC4(3)='T'
      IFUNC4(4)=' '
      IFUNC4(5)='F'
      IFUNC4(6)='O'
      IFUNC4(7)='U'
      IFUNC4(8)='N'
      IFUNC4(9)='D'
      N4=9
 6219 CONTINUE
C
      ILAB(1)='DERI'
      ILAB(2)='VATI'
      ILAB(3)='VE F'
      ILAB(4)='UNCT'
      ILAB(5)='ION '
      ILAB(6)='  = '
      NUMWDL=6
      CALL DPPRIF(ILAB,NUMWDL,IFUNC4,N4,IBUGA3)
C
      IF(IFOUND.EQ.'YES')GOTO6290
      IF(N3.LE.0)GOTO6229
      DO6220I=1,N3
      IFUNC4(I)=IFUNC3(I)
 6220 CONTINUE
 6229 CONTINUE
      N4=N3
C
 6290 CONTINUE
C
C               **************************************************************
C               **  STEP 6.3--                                              **
C               **  DISTINGUISH 4 CASES--                                   **
C               **       1.  IF THE OUTPUT IS TO BE A FUNCTION,             **
C               **           AND IF THE ANALYTIC DERIVATIVE WAS NOT FOUND,  **
C               **           THEN EXIT.                                     **
C               **       2.  IF THE OUTPUT IS TO BE A FUNCTION,             **
C               **           AND IF THE ANALYTIC DERIVATIVE WAS FOUND,      **
C               **           THEN SCAN ALL "FOR" QUALIFIERS                 **
C               **           FOR VARIABLE, PARAMETER, FUNCTION,             **
C               **           AND VALUE CHANGES IN THE ANALYTIC DERIVATIVE.  **
C               **       3.  IF THE OUTPUT IS TO BE A VALUE OR VALUES,      **
C               **           AND IF THE ANALYTIC DERIVATIVE WAS NOT FOUND,  **
C               **           THEN SCAN ALL "FOR" QUALIFIERS--               **
C               **           USE THE FIRST "FOR" QUALIFIER                  **
C               **           TO DEFINE THE POINT AT WHICH                   **
C               **           THE DERIVATIVE IS TO BE EVALUATED;             **
C               **           USE THE OTHER "FOR" QUALIFIERS TO DETERMINE    **
C               **           THE VARIABLE, PARAMETER, FUNCTION,             **
C               **           AND VALUE CHANGES IN THE ORIGINAL FUNCTION     **
C               **           (PRIOR TO THE NUMERICAL DIFFERENTIATION).      **
C               **       4.  IF THE OUTPUT IS TO BE A VALUE OR VALUES,      **
C               **           AND IF THE ANALYTIC DERIVATIVE WAS FOUND,      **
C               **           THEN SCAN ALL "FOR" QUALIFIERS--               **
C               **           USE THE FIRST "FOR" QUALIFIER                  **
C               **           TO DEFINE THE POINT AT WHICH                   **
C               **           THE DERIVATIVE IS TO BE EVALUATED;             **
C               **           USE THE OTHER "FOR" QUALIFIERS TO DETERMINE    **
C               **           THE VARIABLE, PARAMETER, FUNCTION,             **
C               **           AND VALUE CHANGES IN THE ANALYTIC DERIVATIVE   **
C               **           (PRIOR TO THE EXACT DIFFERENTIATION).          **
C               **  NOTE--THE OUTPUT FROM THIS SECTION WILL BE THE          **
C               **  UPDATED DERIVATIVE FUNCTION IFUNC4(.) WITH ALL CHANGES  **
C               **  AS DICTATED BY THE VARIOUS 'FOR' QUALIFICATIONS         **
C               **  INCORPORATED DIRECTLY INTO IFUNC4(.)                    **
C               **  WITH THE EXCEPTION OF ANY 'FOR' QUALIFICATION           **
C               **  INVOLVING THE VARIABLE OF DIFFERENTIATION               **
C               **  (SUCH QUALIFICATIONS WILL BE DEALT WITH LATER).         **
C               **************************************************************
C
      ISTEPN='6.3'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ITYPED.EQ.'F'.AND.IFOUND.EQ.'NO')GOTO9000
C
      NCHANG=0
      ISHIFT=1
      ILOC3=ILOCDV
      IKEY='FOR '
      IKEY2='    '
      ISHIFT=1
      IHXPT1='UNKN'
      IDUMVQ='NO'
      DO6350IFORI=1,10
C
      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')GOTO6370
C
      IF(ITYPED.EQ.'V'.AND.IHARG(ILOC2).EQ.IDUMV(1).AND.
     1IHARG2(ILOC2).EQ.IDUMV2(1))GOTO6351
      GOTO6355
C
 6351 CONTINUE
      ILOC3=ILOC1+3
      IF(ILOC3.GT.NUMARG)GOTO6380
      IHXPT1=IHARG(ILOC3)
      ISHIF3=ISHIFT+2
      INCLUN='NO'
      CALL DPEXQU(IKEY,IKEY2,ISHIF3,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')GOTO6380
      IDUQT1=IUOUT
      IF(IDUQT1.EQ.'N')DUMVV1=VOUT
      IF(IDUQT1.EQ.'P')JLOCQ1=ILOUT
      IF(IDUQT1.EQ.'V')JLOCQ1=ILOUT
      IF(IDUQT1.EQ.'U')GOTO6380
      IDUMVQ='YES'
      GOTO6350
C
 6355 CONTINUE
      ILOC3=ILOC1+3
      IF(ILOC3.GT.NUMARG)GOTO6380
      NCHANG=NCHANG+1
      IOLD(NCHANG)=IHARG(ILOC2)
      IOLD2(NCHANG)=IHARG2(ILOC2)
      INEW(NCHANG)=IHARG(ILOC3)
      INEW2(NCHANG)=IHARG2(ILOC3)
      GOTO6350
C
 6350 CONTINUE
 6370 CONTINUE
      GOTO6390
C
 6380 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6381)
 6381 FORMAT('***** ERROR IN DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6382)
 6382 FORMAT('      INVALID COMMAND FORM FOR DERIVATIVE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6383)
 6383 FORMAT('      GENERAL FORM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6384)
 6384 FORMAT('      LET FUNCTION ... = DERIVATIVE ... WRT ... ',
     1'FOR ... = ...')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6385)
 6385 FORMAT('      LET ... = DERIVATIVE ... WRT ... ',
     1'FOR ... = ...')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6386)
 6386 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,6387)(IANS(I),I=1,IWIDTH)
 6387 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'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NCHANG.LE.0)GOTO6490
C
      IF(IPRINT.EQ.'OFF')GOTO6419
      IF(IFEEDB.EQ.'OFF')GOTO6419
      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)
 6419 CONTINUE
C
      CALL COMPIC(IFUNC4,N4,IOLD,IOLD2,INEW,INEW2,NCHANG,
     1IFUNC4,N4,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IF(IPRINT.EQ.'OFF')GOTO6429
      IF(IFEEDB.EQ.'OFF')GOTO6429
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      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)
 6429 CONTINUE
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'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ITYPED.EQ.'F'.AND.IFOUND.EQ.'YES')GOTO6519
      GOTO6590
 6519 CONTINUE
C
      CALL DPINFU(IFUNC4,N4,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
     1NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,NEWNAM,MAXN2,
     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               **  THEN EXIT.                              **
C               **********************************************
C
      ISTEPN='6.6'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ITYPED.EQ.'F'.AND.IFOUND.EQ.'YES')GOTO6619
      GOTO6690
 6619 CONTINUE
C
      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,IFUNC4,N4,IBUGA3)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 6690 CONTINUE
C
C               **********************************************************
C               **  STEP 7--                                            **
C               **  STEPS 7 THROUGH 10 DEAL ONLY                        **
C               **  WITH A DERIVATIVE EVALUATION                        **
C               **  (AS OPPOSED TO A DERIVATIVE FUNCTION).              **
C               **********************************************************
C
      ISTEPN='7'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               **********************************************
C               **  STEP 7.1--                              **
C               **  CARRY OUT THE VARIABLE,                 **
C               **  PARAMETER, AND FUNCTION CHANGES         **
C               **  IN THE ORIGINAL FUNCTION.               **
C               **********************************************
C
      ISTEPN='7.1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,
     1IFUNC3,N3,IBUGA3,IERROR)
C
C               **********************************************************
C               **  STEP 7.2--                                          **
C               **  IF THE ANALYTIC DERIVATIVE WAS FOUND, OR            **
C               **  IF THE ANALYTIC DERIVATIVE WAS NOT FOUND, MAKE      **
C               **  A NON-CALCULATING PASS AT THE ORIGINAL   FUNCTION   **
C               **  SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES.  **
C               **  NOTE--AT THE END OF THIS STEP,                      **
C               **  NUMPV WILL CONTAIN THE TOTAL NUMBER                 **
C               **  OF PARAMETERS AND VARIABLES IN THE                  **
C               **  ORIGINAL FUNCTION (AFTER CHANGES HAVE BEEN          **
C               **  MADE FOR ALL (EXCEPT THE DUMMY VARIABLE).           **
C               **  HOWEVER, THE DUMMY VARIABLE ITSELF                  **
C               **  WILL BE INCLUDED IN THE COUNT IN NUMPV.             **
C               **  NOTE THAT NUMPV SHOULD ALWAYS BE 1 OR               **
C               **  LARGER (UNLESS THE ORIGINAL FUNCTION                **
C               **  WAS A NUMBER OR COMBINATION OF NUMBERS.             **
C               **  EXAMPLE--SIN(3) WRT X, NUMPV = 0                    **
C               **  EXAMPLE--SIN(X) WRT X, NUMPV = 1                    **
C               **  EXAMPLE--SIN(X) WRT X FOR X=3, NUMPV = 1            **
C               **  EXAMPLE--SIN(A*X) WRT X, NUMPV = 2                  **
C               **  EXAMPLE--SIN(A*X) WRT X FOR X=Y, NUMPV = 2          **
C               **********************************************************
C
      ISTEPN='7.2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IPASS=1
      CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
     1IBUGCO,IBUGEV,IERROR)
      IF(IERROR.EQ.'YES')RETURN
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO7900
      WRITE(ICOUT,7901)
 7901 FORMAT('IN DPDERV, AFTER RETURNING FROM COMPIM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7902)N4,IPASS
 7902 FORMAT('N4,IPASS = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO7903I=1,N3
      WRITE(ICOUT,7904)I,IFUNC3(I)
 7904 FORMAT('I,IFUNC3(I) = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 7903 CONTINUE
      WRITE(ICOUT,7906)NUMPV
 7906 FORMAT('NUMPV = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO7907I=1,NUMPAR
      WRITE(ICOUT,7908)I,IPARN(I),IPARN2(I)
 7908 FORMAT('I,IPARN(I),IPARN2(I) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 7907 CONTINUE
 7900 CONTINUE
C
C               ***********************************************
C               **  STEP 8.1--                               **
C               **  MAKE SURE THAT THE DUMMY VARIABLE        **
C               **  APPEARS IN IPARN(. )                     **
C               **  MAKE SURE THAT NUMPV IS 1 OR LARGER.     **
C               **  THIS IS TO BE DONE EVEN THOUGH           **
C               **  THE DUMMY VARIABLE MAY NOT               **
C               **  EXPLICITELY APPEAR                       **
C               **  IN THE ORIGINAL FUNCTION                 **
C               **  (EXAMPLE--SIN(A) WRT X).                 **
C               **  THE ABOVE WILL ASSURE THAT THE FIRST AND **
C               **  LAST POINTS AT WHICH THE DERIVATIVE      **
C               **  IS TO BE EVALUATED WILL IN FACT          **
C               **  BE PRINTED OUT IN STEP 9 BELOW.          **
C               **  -------                                  **
C               **  CHECK THAT ALL PARAMETERS AND VARIABLES  **
C               **  IN THE FUNCTION ARE ALREADY PRESENT      **
C               **  IN THE AVAILABLE NAME LIST IHNAME(.).    **
C               **  CHECK ALSO THAT ALL VARIABLES IN THE     **
C               **  FUNCTION        HAVE THE SAME LENGTH     **
C               **  AND THAT THEIR LENGTH IS GREATER THAN    **
C               **  ZERO.                                    **
C               **  IF A 'FOR' QUALIFICATION EXISTS FOR      **
C               **  THE DUMMY VARIABLE, THEN SKIP THE        **
C               **  CHECK FOR THE DUMMY VARIABLE (ONLY)      **
C               **  (BUT DO THE OTHER VARIABLES AND          **
C               **  PARAMETERS).                             **
C               **  IF NO 'FOR' QUALIFICATION EXISTS FOR     **
C               **  THE DUMMY VARIABLE, THEN DO THE          **
C               **  CHECK FOR THE DUMMY VARIABLE AS WELL AS  **
C               **  FOR THE OTHER VARIABLES AND              **
C               **  PARAMETERS.                              **
C               ***********************************************
C
      ISTEPN='8.1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IP=0
      IV=0
      NUMEL=0
      IOLDNA='-999'
      IOLDN2='-999'
      IOLDNI=-999
      ITTEST='EITH'
      MESSAG='YES'
C
      IF(NUMPV.LE.0)NUMPV=0
      IF(NUMPV.LE.0)GOTO8590
      DO8500I=1,NUMPV
      IHPARN=IPARN(I)
      IHPAR2=IPARN2(I)
      IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))GOTO8599
 8500 CONTINUE
 8590 CONTINUE
      NUMPV=NUMPV+1
      IPARN(NUMPV)=IDUMV(1)
      IPARN2(NUMPV)=IDUMV2(1)
 8599 CONTINUE
C
      IF(NUMPV.LE.0)GOTO8670
      DO8600J=1,NUMPV
      I2=I
      IHPARN=IPARN(J)
      IHPAR2=IPARN2(J)
      IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1).AND.
     1IDUMVQ.EQ.'YES')GOTO8600
      CALL CHECN2(IHPARN,IHPAR2,ITTEST,
     1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,IN,NUMNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,
     1JVALUE,AVALUE,JUSE,JN,
     1IOLDNA,IOLDN2,IOLDNI,IFOUN3,IBUGA3,ISUBRO,IERRO2)
      IF(IFOUN3.EQ.'NO')GOTO8650
      IF(IERRO2.EQ.'YES')GOTO8650
      IF(JUSE.EQ.'P')GOTO8610
      IF(JUSE.EQ.'V')GOTO8620
      GOTO8600
C
 8610 CONTINUE
      IP=IP+1
      JLOC(J)=ILOC
      GOTO8600
C
 8620 CONTINUE
      IV=IV+1
      JLOC(J)=ILOC
      IF(IV.EQ.1)JNOLD=JN
      IF(IV.EQ.1)GOTO8627
      IF(IV.GE.2.AND.JN.EQ.JNOLD)GOTO8627
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8621)
 8621 FORMAT('***** ERROR IN DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8622)
 8622 FORMAT('      NOT ALL VARIABLES INVOLVED IN THE DERIVATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8623)
 8623 FORMAT('      EVALUATION HAVE THE SAME LENGTH.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8624)JNOLD
 8624 FORMAT('      PREVIOUS VARIABLES          HAD LENGTH ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8625)IHNAME(ILOC),IHNAM2(ILOC),JN
 8625 FORMAT('      THIS     VARIABLE  (',A4,A4,') HAS LENGTH ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 8627 CONTINUE
      JNOLD=JN
      GOTO8600
C
 8650 CONTINUE
      IERROR='YES'
      GOTO9000
C
 8600 CONTINUE
      GOTO8680
 8670 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8671)IDUMV(1),IDUMV2(1)
 8671 FORMAT('NOTE--VARIABLE OF DIFFERENTIATION (= ',A4,A4,')')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8672)
 8672 FORMAT('      NOT FOUND IN ORIGINAL FUNCTION.')
      CALL DPWRST('XXX','BUG ')
C
 8680 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO8690
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8681)
 8681 FORMAT('***** AT THE END OF STEP 8.1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8682)NUMPV,IP,IV
 8682 FORMAT('NUMPV,IP,IV = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO8684I=1,NUMPV
      WRITE(ICOUT,8685)I,JLOC(I)
 8685 FORMAT('I,JLOC(I) = ',I8,2X,I8)
      CALL DPWRST('XXX','BUG ')
 8684 CONTINUE
 8690 CONTINUE
C
C               ***********************************************
C               **  STEP 8.2--                               **
C               **  IF A "FOR" QUALIFIER EXISTS              **
C               **  FOR THE DUMMY VARIABLE,                  **
C               **  CHECK THAT ALL PARAMETERS AND VARIABLES  **
C               **  IN THIS QUALIFICATION ARE ALREADY PRESENT**
C               **  IN THE AVAILABLE NAME LIST IHNAME(.).    **
C               **  CHECK ALSO THAT ALL VARIABLES IN THE     **
C               **  THIS QUALIFICATION HAVE THE SAME LENGTH  **
C               **  AND THAT THEIR LENGTH IS GREATER THAN    **
C               **  ZERO.                                    **
C               ***********************************************
C
      ISTEPN='8.2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IDUMVQ.EQ.'NO')GOTO8729
C
      IF(IDUQT1.EQ.'N')GOTO8729
C
      IF(IDUQT1.EQ.'P')IP=IP+1
      IF(IDUQT1.EQ.'P')GOTO8729
C
      IF(IDUQT1.EQ.'V')IV=IV+1
      IF(IDUQT1.EQ.'V')JN=IN(JLOCQ1)
      IF(IV.EQ.1)JNOLD=JN
      IF(IV.EQ.1)GOTO8727
      IF(IV.GE.2.AND.JN.EQ.JNOLD)GOTO8727
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8721)
 8721 FORMAT('***** ERROR IN DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8722)
 8722 FORMAT('      NOT ALL VARIABLES INVOLVED IN THE DERIVATIVE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8723)
 8723 FORMAT('      EVALUATION HAVE THE SAME LENGTH.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8724)JNOLD
 8724 FORMAT('      PREVIOUS VARIABLES          HAD LENGTH ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8725)IHNAME(ILOC),IHNAM2(ILOC),JN
 8725 FORMAT('      THIS     VARIABLE  (',A4,A4,') HAS LENGTH ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 8727 CONTINUE
      JNOLD=JN
 8729 CONTINUE
C
      NUMPAR=IP
      NUMVAR=IV
      NUMEL=JN
C
      ICASEL='P'
      IF(NUMVAR.GE.1)ICASEL='V'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO8790
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8781)
 8781 FORMAT('***** AT THE END OF STEP 8.2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8782)NUMPV,NUMPAR,NUMVAR,NUMEL
 8782 FORMAT('NUMPV,NUMPAR,NUMVAR,NUMEL = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8783)ICASEL,IDUMV(1),IDUMV2(1),IHXPT1,JLOCQ1
 8783 FORMAT('ICASEL,IDUMV(1),IDUMV2(1),IHXPT1,JLOCQ1 = ',
     1A4,2X,A4,2X,A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
 8790 CONTINUE
C
C               *****************************************
C               **  STEP 9--                           **
C               **  EVALUATE THE DERIVATIVE AT THE     **
C               **  SPECIFIED POINT (OR POINTS).       **
C               **  IF THE EXACT ANALYTIC DERIVATIVE   **
C               **  HAD BEEN FOUND,                    **
C               **  DO A FUNCTION EVALUTION ON         **
C               **  THE DERIVATIVE;                    **
C               **  IF THE EXACT ANALYTIC DERIVATIVE   **
C               **  HAD NOT BEEN FOUND (NEVER),        **
C               **  COMPUTE A NUMERICAL DERIVATIVE.    **
C               **  NOTE--FROM STEP 8.1 ABOVE,         **
C               **  NUMPV SHOULD BE 1 OR LARGER,       **
C               **  AND THE DUMMY VARIABLE SHOULD      **
C               **  APPEAR SOMEWHERE IN IPARN(.).      **
C               **  THIS IS TO COVER THE INFREQUENT    **
C               **  CASE OF THE ORIGINAL FUNCTION      **
C               **  NOT CONTAINING THE DUMMY VARIABLE  **
C               **  (AND SO THE DERIVATIVE WILL BE 0)  **
C               **  AND YET WE WANT THE FIRST AND      **
C               **  LAST POINTS WHERE THE EVALUATION   **
C               **  WAS DONE TO BE DONE AND PRINTED    **
C               **  (FOR CONSISTENCY SAKE).            **
C               *****************************************
C
      ISTEPN='9'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(ICASEL.EQ.'P')IMAX=1
      IF(ICASEL.EQ.'V')IMAX=NUMEL
      DO8810I=1,IMAX
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8811)I,IMAX,ICASEL,IDUQT1,JLOCQ1,
     1NUMPV
 8811 FORMAT('I,IMAX,ICASEL,IDUQT1,JLOCQ1,NUMPV = ',2I8,
     12X,A4,2X,A4,2I8)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8812)IDUMV(1),IDUMV2(1),IDUMVQ
 8812 FORMAT('IDUMV(1),IDUMV2(1),IDUMVQ = ',A4,2X,A4,2X,A4)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(NUMPV.LE.0)GOTO8860
C
      DO8820J=1,NUMPV
      IHPARN=IPARN(J)
      IHPAR2=IPARN2(J)
      IF(IHPARN.NE.IDUMV(1).OR.IHPAR2.NE.IDUMV2(1))GOTO8859
      IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1).AND.
     1IDUMVQ.EQ.'NO')GOTO8821
      IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1).AND.
     1IDUMVQ.EQ.'YES')GOTO8825
C
      IBRAN=8816
      WRITE(ICOUT,8816)
 8816 FORMAT('***** INTERNAL ERROR IN DPDERV SUBROUTINE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8817)IBRAN
 8817 FORMAT('      IMPOSSIBLE CONDITION AT BRANCH POINT ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8818)J,IHPARN,IHPAR2,IDUMV(1),IDUMV2(1),IDUMVQ
 8818 FORMAT('J,IHPARN,IHPAR2,IDUMV(1),IDUMV2(1),IDUMVQ = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 8821 CONTINUE
      KLOC=JLOC(J)
      K2LOC=IVALUE(KLOC)
      IF(IUSE(KLOC).EQ.'P')PARAM(J)=VALUE(KLOC)
CCCCC IF(IUSE(KLOC).EQ.'V')PARAM(J)=V(I,K2LOC)
      IF(IUSE(KLOC).EQ.'V')IJ=MAXN*(K2LOC-1)+I
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
      IF(I.NE.1.AND.I.NE.IMAX)GOTO8820
      IF(ICASEL.EQ.'P')WRITE(ICOUT,999)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'P')WRITE(ICOUT,8822)PARAM(J)
 8822 FORMAT('EVALUATION POINT      = ',E15.7)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,999)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,8823)PARAM(J)
 8823 FORMAT('FIRST EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)WRITE(ICOUT,8824)PARAM(J)
 8824 FORMAT('LAST  EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)CALL DPWRST('XXX','BUG ')
      GOTO8820
C
 8825 CONTINUE
      IF(IDUQT1.EQ.'N')GOTO8830
      IF(IDUQT1.EQ.'P')GOTO8840
      IF(IDUQT1.EQ.'V')GOTO8850
C
      IBRAN=8826
      WRITE(ICOUT,8826)
 8826 FORMAT('***** INTERNAL ERROR IN DPDERV SUBROUTINE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8827)IBRAN
 8827 FORMAT('      IMPOSSIBLE CONDITION AT BRANCH POINT ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8828)J,IHPARN,IHPAR2,IDUMV(1),IDUMV2(1),IDUMVQ,IDUQT1
 8828 FORMAT('J,IHPARN,IHPAR2,IDUMV(1),IDUMV2(1),IDUMVQ,IDUQT1 = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 8830 CONTINUE
      PARAM(J)=DUMVV1
      IF(ICASEL.EQ.'P')WRITE(ICOUT,999)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'P')WRITE(ICOUT,8832)PARAM(J)
 8832 FORMAT('EVALUATION POINT      = ',E15.7)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,999)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,8833)PARAM(J)
 8833 FORMAT('FIRST EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)WRITE(ICOUT,8834)PARAM(J)
 8834 FORMAT('LAST  EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)CALL DPWRST('XXX','BUG ')
      GOTO8820
C
 8840 CONTINUE
      KLOC=JLOCQ1
      PARAM(J)=VALUE(KLOC)
      IF(ICASEL.EQ.'P')WRITE(ICOUT,999)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'P')WRITE(ICOUT,8842)PARAM(J)
 8842 FORMAT('EVALUATION POINT      = ',E15.7)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,999)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,8843)PARAM(J)
 8843 FORMAT('FIRST EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)WRITE(ICOUT,8844)PARAM(J)
 8844 FORMAT('LAST  EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)CALL DPWRST('XXX','BUG ')
      GOTO8820
C
 8850 CONTINUE
      KLOC=JLOCQ1
      K2LOC=IVALUE(KLOC)
CCCCC PARAM(J)=V(I,K2LOC)
      IJ=MAXN*(K2LOC-1)+I
      IF(K2LOC.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(K2LOC.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(K2LOC.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(K2LOC.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(K2LOC.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(K2LOC.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(K2LOC.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
      IF(ICASEL.EQ.'P')WRITE(ICOUT,999)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'P')WRITE(ICOUT,8852)PARAM(J)
 8852 FORMAT('EVALUATION POINT      = ',E15.7)
      IF(ICASEL.EQ.'P')CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,999)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)WRITE(ICOUT,8853)PARAM(J)
 8853 FORMAT('FIRST EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.1)CALL DPWRST('XXX','BUG ')
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)WRITE(ICOUT,8854)PARAM(J)
 8854 FORMAT('LAST  EVALUATION PT.  = ',E15.7)
      IF(ICASEL.EQ.'V'.AND.I.EQ.IMAX)CALL DPWRST('XXX','BUG ')
      GOTO8820
 8859 CONTINUE
C
      KLOC=JLOC(J)
      K2LOC=IVALUE(KLOC)
      IF(IUSE(KLOC).EQ.'P')PARAM(J)=VALUE(KLOC)
CCCCC IF(IUSE(KLOC).EQ.'V')PARAM(J)=V(I,K2LOC)
      IF(IUSE(KLOC).EQ.'V')IJ=MAXN*(K2LOC-1)+I
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.LE.MAXCOL)PARAM(J)=V(IJ)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP1)PARAM(J)=PRED(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP2)PARAM(J)=RES(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP3)PARAM(J)=YPLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP4)PARAM(J)=XPLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP5)PARAM(J)=X2PLOT(I)
      IF(IUSE(KLOC).EQ.'V'.AND.K2LOC.EQ.MAXCP6)PARAM(J)=TAGPLO(I)
C
 8820 CONTINUE
 8860 CONTINUE
C
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8861)J,PARAM(J),KLOC,K2LOC,IFOUND
 8861 FORMAT('J,PARAM(J),KLOC,K2LOC,IFOUND = ',I8,E15.7,2I8,2X,A4)
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(IBUGA3.EQ.'ON')WRITE(ICOUT,8862)
 8862 FORMAT('IN DPDERV, BEFORE ENTERING COMPIM/DERIVC--')
      IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ')
C
      IF(IFOUND.EQ.'YES')GOTO8871
      GOTO8872
C
 8871 CONTINUE
      IPASS=1
      CALL COMPIM(IFUNC4,N4,IPASS,PARAM,IPARN,IPARN2,NUMPV,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
     1IBUGCO,IBUGEV,IERROR)
C
      IPASS=2
      CALL COMPIM(IFUNC4,N4,IPASS,PARAM,IPARN,IPARN2,NUMPV,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,CALCD,
     1IBUGCO,IBUGEV,IERROR)
      GOTO8875
C
 8872 CONTINUE
      CALL DERIVC(IFUNC4,N4,PARAM,IPARN,IPARN2,NUMPV,
     1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
     1IDUMV,IDUMV2,NUMDV,X0,CALCD,IBUGA3,IBUGCO,IBUGEV,IERROR)
 8875 CONTINUE
      IF(ICASEL.EQ.'P')RESULP=CALCD
      IF(ICASEL.EQ.'V')RESULT(I)=CALCD
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO8889
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8881)I
 8881 FORMAT('IN DPDERV, STEP ',I8,' AFTER RETURNING FROM ',
     1'COMPIM/DERIVC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8882)N4,IPASS,CALCD
 8882 FORMAT('N4,IPASS,CALCD = ',2I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8883)(IFUNC4(L),L=1,N4)
 8883 FORMAT('IFUNC4(.) = ',100A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8884)NUMPV
 8884 FORMAT('NUMPV = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO8886L=1,NUMPV
      WRITE(ICOUT,8887)L,IPARN(L),IPARN2(L)
 8887 FORMAT('L,IPARN(L),IPARN2(L) = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 8886 CONTINUE
 8889 CONTINUE
C
 8810 CONTINUE
C
C               *****************************************
C               **  STEP 10--                          **
C               **  IF THE OUTPUT IS A PARAMETER VALUE,**
C               **  ENTER THE CALCULATED DERIVATIVE    **
C               **  INTO THE DATAPLOT PARAMETER.       **
C               **  IF THE OUTPUT IS A VARIABLE,       **
C               **  ENTER THE CALCULATED DERIVATIVES   **
C               **  INTO THE DATAPLOT ARRAY V(.)     **
C               *****************************************
C
      ISTEPN='10'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'DERV')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IBUGIV=IBUGA3
C
      IHL=IHLEFT
      IHL2=IHLEF2
      CALL DPINVP(IHL,IHL2,ICASEL,RESULT,NUMEL,RESULP,IJUNK,
     1ISUBN1,ISUBN2,IBUGA3,IERROR)
C
C               ****************
C               **  STEP 90-- **
C               **  EXIT      **
C               ****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'DERV')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END OF DPDERV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO
 9012 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGCO,IBUGEV
 9013 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IBUGQ
 9014 FORMAT('IBUGQ = ',A4)
      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)NUMCHF,MAXCHF,IWIDTH,N2
 9017 FORMAT('NUMCHF,MAXCHF,IWIDTH,N2 = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)(IFUNC(I),I=1,IWIDTH)
 9018 FORMAT('IFUNC(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)(IFUNC2(I),I=1,N2)
 9019 FORMAT('IFUNC2(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)N3
 9020 FORMAT('N3 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)(IFUNC3(I),I=1,N3)
 9021 FORMAT('IFUNC3(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9030)N4
 9030 FORMAT('N4 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9031)(IFUNC4(I),I=1,N4)
 9031 FORMAT('IFUNC4(.) = ',115A1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)NUMPV
 9032 FORMAT('NUMPV = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)IP,IV,IDUMV(1),IDUMV2(1),ILOCDV
 9033 FORMAT('IP,IV,IDUMV(1),IDUMV2(1),ILOCDV = ',I8,I8,2X,A4,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9034)IHLEFT,IHLEF2
 9034 FORMAT('IHLEFT,IHLEF2 = ',A4,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9035)IFOUND,IERROR
 9035 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9036)X0,CALCD
 9036 FORMAT('X0,CALCD = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9037)ITYPED,ICASEL,NUMEL
 9037 FORMAT('ITYPED,ICASEL,NUMEL = ',A4,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDET2(PMIN,PMAX,FMIN,FMAX,
     1ITICSW,ISCASW,
     1NMJT,INMJSW,
     1PTCOOR,ATCOOR,NMJT2,
     1NMNT,INMNSW,
     1PTCOMN,ATCOMN,NMNT2,
     1PTCOFL,PTCOFR,ITICUN)
C  ABOVE LINE ADDED MAY, 1990. (ALAN)
C
C     PURPOSE--DETERMINE AND SET TIC MARKS FOR A SINGLE FRAME LINE.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--JANUARY 1988. (TO ALLOW TIC LABELS WITHOUT TICS)
C     UPDATED       --???     19??. WEIBULL SCALE
C     UPDATED       --MAY     1990. TIC OFFSETS FOR LINEAR & LOG SCALES
C     UPDATED       --JUNE    1990. NORMAL SCALE
C     UPDATED       --JUNE    1994. RESTORE LOST MOD WHERE MINOR TICS
C                                   GO ONE MORE CYCLE WHEN THERE IS AN
C                                   OFFSET.
C     UPDATED       --JULY    1996. ALLOW ONLY 1 CYCLE FOR LOG SCALE
C
C-----NON-COMMON VARIABLES (GRAPHICS)----------------------------------
C
      CHARACTER*4 ITICSW
      CHARACTER*4 ISCASW
      CHARACTER*4 INMJSW
      CHARACTER*4 INMNSW
C FOLLOWING LINE ADDED MAY, 1990.
      CHARACTER*4 ITICUN
C
      DIMENSION PTCOOR(*)
      DIMENSION ATCOOR(*)
      DIMENSION PTCOMN(*)
      DIMENSION ATCOMN(*)
C
      DIMENSION WEIB21(25)
C
CCCCC THE FOLLOWING LINE WAS ADDED JUNE 1990
      DIMENSION ANORM(27)
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-----DATA STATEMENTS---------------------------------------------------
C
      DATA WEIB21( 1),WEIB21( 2),WEIB21( 3),WEIB21( 4),WEIB21( 5),
     1     WEIB21( 6),WEIB21( 7),WEIB21( 8),WEIB21( 9),WEIB21(10),
     1     WEIB21(11),WEIB21(12),WEIB21(13),WEIB21(14),WEIB21(15),
     1     WEIB21(16),WEIB21(17),WEIB21(18),WEIB21(19),WEIB21(20),
     1     WEIB21(21)
     1/0.000001,0.00001,0.0001,0.001,0.01,0.1,
     1 0.5,1.0,5.0,10.0,20.0,30.0,40.0,50.0,
     1 60.0,70.0,80.0,90.0,95.0,99.0,99.9/
C
CCCCC THE FOLLOWING DATA STATEMENT WAS ADDED JUNE 1990
      DATA ANORM( 1),ANORM( 2),ANORM( 3),ANORM( 4),ANORM( 5),
     1     ANORM( 6),ANORM( 7),ANORM( 8),ANORM( 9),ANORM(10),
     1     ANORM(11),ANORM(12),ANORM(13),ANORM(14),ANORM(15),
     1     ANORM(16),ANORM(17),ANORM(18),ANORM(19),ANORM(20),
     1     ANORM(21),ANORM(22),ANORM(23),ANORM(24),ANORM(25),
     1     ANORM(26),ANORM(27)
     1/0.000001,0.00001,0.0001,0.001,0.01,0.1,0.5,
     1 1.0,5.0,10.0,20.0,30.0,40.0,
     1 50.0,
     1 60.0,70.0,80.0,90.0,95.0,99.0,
     1 99.5,99.9,99.99,99.999,99.9999,99.99999,99.999999/
C
C-----START POINT-----------------------------------------------------
C
      EPS=0.0001
C
      EXPMIN=0.0
      EXPMAX=0.0
      IEXMIN=0
      IEXMAX=0
      DENOM=0.0
      NUMCYC=0
      NUMCYP=0
      PRANGE=0.0
      J=0
      XIMIN=0.0
      XIMAX=0.0
      NUMMAJ=0
      NUMMIN=0
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DET2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDET2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)PMIN,PMAX
   52 FORMAT('PMIN,PMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)FMIN,FMAX
   53 FORMAT('FMIN,FMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)ITICSW,ISCASW
   54 FORMAT('ITICSW,ISCASW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)NMJT,INMJSW
   55 FORMAT('NMJT,INMJSW = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)NMNT,INMNSW
   56 FORMAT('NMNT,INMNSW = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)ITICUN
   70 FORMAT('ITICUN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)PTCOFL,PTCOFR
   71 FORMAT('PTCOFL,PTCOFR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
   72 FORMAT('PX1TOR,PX2TOR,PY1TOT,PY2TOT = ',4E15.7)
   90 CONTINUE
C
C               *************************************
C               **  STEP 1--                       **
C               **  TREAT THE    TICS OFF    CASE  **
C               *************************************
C
      NMJT2=0
      NMNT2=0
CCCCC IF(ITICSW.EQ.'OFF')GOTO9000
C
C               ********************************
C               **  STEP 2--                  **
C               **  TREAT THE LOG SCALE CASE  **
C               ********************************
C
      IF(ISCASW.EQ.'LOG')GOTO1200
      GOTO1290
C
C               *******************************
C               **  STEP 2.1--               **
C               **  COMPUTE MAJOR TIC MARKS  **
C               **  FOR THE LOG    CASE      **
C               *******************************
C
 1200 CONTINUE
      IF(FMIN.GT.0.0.AND.FMAX.GT.0.0)GOTO1209
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1201)
 1201 FORMAT('***** ERROR IN DPDET2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1202)
 1202 FORMAT('      A LOG SCALE MAY NOT BE USED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1203)
 1203 FORMAT('      WHEN FRAME LIMITS ARE NON-POSITIVE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1204)FMIN,FMAX
 1204 FORMAT('      THE FRAME LIMITS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1205)
 1205 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1206)
 1206 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1209 CONTINUE
C
CCCCC FOLLOWING CODE MODIFIED TO HANDLE CASE WHERE FMIN=FMAX, I.E.,
CCCCC ONLY 1 MAJOR TIC, MINOR TICS HANDLED VIA TIC OFFSET,  JULY 1996.
      EXPMIN=ALOG10(FMIN)
      EXPMAX=ALOG10(FMAX)
      DENOM=EXPMAX-EXPMIN
C
      IF(FMIN.NE.FMAX)THEN
        IEXMIN=EXPMIN+0.01
        IF(EXPMIN.LT.0.0)IEXMIN=EXPMIN-0.01
        IEXMAX=EXPMAX+0.01
        IF(EXPMAX.LT.0.0)IEXMAX=EXPMAX-0.01
        IF(IEXMAX.EQ.IEXMIN)IEXMAX=IEXMIN+1
C
        NUMCYC=IEXMAX-IEXMIN
        NUMCYP=NUMCYC+1
        PRANGE=PMAX-PMIN
      ELSE
        IEXMIN=EXPMIN+0.01
        IF(EXPMIN.LT.0.0)IEXMIN=EXPMIN-0.01
        IEXMAX=IEXMIN
        NUMCYC=1
      ENDIF
C
C  ALGORITHIM ADJUSTED MAY, 1990 TO SUPPORT TIC OFFSETS.  NOTE THAT
C  OFFSET MAY BE DONE IN EITHER DATAPLOT UNITS OR DATA UNITS.
C
      IF(ITICUN.NE.'ABSO')GOTO1285
C
C  OFFSET IN DATAPLOT UNITS
C
      IF(FMIN.NE.FMAX)THEN
        PMIN2=PMIN+PTCOFL
        PMAX2=PMAX-PTCOFR
        IF(PMIN2.LT.PMAX2)GOTO1283
        PMIN2=PMIN
        PMAX2=PMAX
        PRANG2=PRANGE
        FMIN2=FMIN
        FMAX2=FMAX
        GOTO1289
 1283   CONTINUE
        PRANG2=PMAX2-PMIN2
        FMIN2=FMIN
        FMAX2=FMAX
        ATEMP=(EXPMAX-EXPMIN)/(PMAX2-PMIN2)
        ATMPMX=EXPMAX+(PTCOFR*ATEMP)
        ATMPMN=EXPMIN-(PTCOFL*ATEMP)
        FMAX=10.**ATMPMX
        FMIN=10.**ATMPMN
        GOTO1289
      ELSE
CCCCC   FOR 1 CYCLE CASE, TIC OFFSETS WILL BE CALCULATED IN DATA
CCCCC   UNITS REGARDLESS OF TIC OFFSET UNITS.
      ENDIF
C
C  OFFSET IN DATA UNITS
C
 1285 CONTINUE
      IF(FMIN.NE.FMAX)THEN
        FMIN2=FMIN
        FMAX2=FMAX
        FMIN=FMIN2-PTCOFL
        FMAX=FMAX2+PTCOFR
        IF(FMIN.GT.0.0)GOTO1287
        FMIN=FMIN2
        FMAX=FMAX2
        PMIN2=PMIN
        PMAX2=PMAX
        PRANG2=PMAX2-PMIN2
        GOTO1289
 1287   CONTINUE
        ATMPMN=ALOG10(FMIN)
        ATMPMX=ALOG10(FMAX)
        ATEMP=(ATMPMX-ATMPMN)/(PMAX-PMIN)
        PTEMP=(EXPMIN-ATMPMN)/ATEMP
        PMIN2=PMIN+PTEMP
        PTEMP=(ATMPMX-EXPMAX)/ATEMP
        PMAX2=PMAX-PTEMP
        PRANG2=PMAX2-PMIN2
        GOTO1289
      ELSE
        IF(PTCOFL.EQ.0.0 .AND. PTCOFR.EQ.0.0)THEN
          FMIN2=FMIN
          FMAX2=FMAX
          FMIN=FMIN2-FMIN/2.
          FMAX=FMAX2+FMAX/2.
        ELSE
          FMIN2=FMIN
          FMAX2=FMAX
          FMIN=FMIN2-PTCOFL
          IF(FMIN.LE.0.0)FMIN=FMIN2-FMIN/2.
          FMAX=FMAX2+PTCOFR
        ENDIF
        ATMPMN=ALOG10(FMIN)
        ATMPMX=ALOG10(FMAX)
        ATEMP=(ATMPMX-ATMPMN)/(PMAX-PMIN)
        PTEMP=(EXPMIN-ATMPMN)/ATEMP
        PMIN2=PMIN+PTEMP
        PMAX2=PMIN2
        PRANG2=PMAX2-PMIN2
        GOTO1289
      ENDIF
C
 1289 CONTINUE
C
CCCC A COUPLE OF LINES MODIFIED IN FOLLOWING LOOP MAY, 1990.
      IF(FMIN2.EQ.FMAX2)THEN
        PTCOOR(1)=PMIN2
        ATCOOR(1)=EXPMIN
        PTCOOR(2)=PMIN
        ATCOOR(2)=ALOG10(FMIN)
        PTCOOR(3)=PMAX
        ATCOOR(3)=ALOG10(FMAX)
        NMJT2=3
        GOTO1231
      ENDIF
C
      K=0
      DO1210I=1,NUMCYP
      AI=I
CCCCC ACYCST=FMIN*10.0**(I-1)
      ACYCST=FMIN2*10.0**(I-1)
      K=K+1
      XI=ACYCST
CCCCC XRATIO=(ALOG10(XI)-ALOG10(FMIN))/DENOM
      XRATIO=(ALOG10(XI)-ALOG10(FMIN2))/DENOM
CCCCC PTCOOR(K)=PMIN+XRATIO*PRANGE
      PTCOOR(K)=PMIN2+XRATIO*PRANG2
CCCCC ATCOOR(K)=XI
      ATCOOR(K)=EXPMIN+(AI-1.0)
      IF(I.EQ.NUMCYP.AND.J.LE.1)GOTO1229
 1210 CONTINUE
 1229 CONTINUE
      NMJT2=K
 1231 CONTINUE
C
C               *******************************
C               **  STEP 2.2--               **
C               **  COMPUTE MINOR TIC MARKS  **
C               **  FOR THE LOG    CASE      **
C               *******************************
C
CCCCC COUPLE LINES CHANGED MAY, 1990 IN FOLLOWING LOOP.
CCCCC JUNE 1994.  ADD ONE CYCLE OF MINOR TICS WHEN THERE IS A TIC
CCCCC OFFSET.  TWO CASES, AT LOW END AND AT HIGH END.
      IF(FMIN2.EQ.FMAX2)THEN
        K=0
        IF(FMIN2.LE.FMIN)GOTO11259
        ACYST=FMIN2*10.0**(-1)
        DO11250J=2,9
          AJ=J
          XI=AJ*ACYST
          IF(XI.LT.FMIN)GOTO11250
          K=K+1
          XRATIO=(ALOG10(FMIN2)-ALOG10(XI))/
     1           (ALOG10(FMIN2)-ALOG10(FMIN))
          PTCOMN(K)=PMIN2-XRATIO*(PMIN2-PMIN)
          ATCOMN(K)=XI
11250   CONTINUE
11259   CONTINUE
        ACYST=FMIN2*10.0**(0)
        DO11260J=2,9
          AJ=J
          XI=AJ*ACYST
          IF(XI.GT.FMAX)GOTO11260
          K=K+1
          XRATIO=(ALOG10(XI)-ALOG10(FMIN2))/
     1           (ALOG10(FMAX)-ALOG10(FMIN2))
          PTCOMN(K)=PMIN2+XRATIO*(PMAX-PMIN2)
          ATCOMN(K)=XI
11260   CONTINUE
11269   CONTINUE
        NMNT2=K
        GOTO9000
      ENDIF
C
      K=0
CCCCC JUNE 1994.  CASE FOR LOW END.
      IF(FMIN2.LE.FMIN)GOTO1259
      ACYST=FMIN2*10.0**(-1)
      DO1250J=2,9
      AJ=J
      XI=AJ*ACYST
      IF(XI.LT.FMIN)GOTO1250
      K=K+1
CCCCC XRATIO=(ALOG10(XI)-ALOG10(FMIN2))/DENOM
      XRATIO=(ALOG10(FMIN2)-ALOG10(XI))/DENOM
      PTCOMN(K)=PMIN2-XRATIO*PRANG2
      ATCOMN(K)=XI
 1250 CONTINUE
 1259 CONTINUE
C
      DO1260I=1,NUMCYC
CCCCC ACYCST=FMIN*10.0**(I-1)
      ACYCST=FMIN2*10.0**(I-1)
      DO1270J=2,9
      K=K+1
      AJ=J
      XI=AJ*ACYCST
CCCCC XRATIO=(ALOG10(XI)-ALOG10(FMIN))/DENOM
      XRATIO=(ALOG10(XI)-ALOG10(FMIN2))/DENOM
CCCCC PTCOMN(K)=PMIN+XRATIO*PRANGE
      PTCOMN(K)=PMIN2+XRATIO*PRANG2
      ATCOMN(K)=XI
      IF(I.EQ.NUMCYP.AND.J.LE.1)GOTO1279
 1270 CONTINUE
 1260 CONTINUE
 1279 CONTINUE
CCCCC JUNE 1994.  CASE FOR HIGH END.
      IF(FMAX2.GE.FMAX)GOTO1299
      ACYST=FMAX2
      DO1280J=2,9
      AJ=J
      XI=AJ*ACYST
      IF(XI.GT.FMAX)GOTO1280
      K=K+1
      XRATIO=(ALOG10(XI)-ALOG10(FMAX2))/DENOM
      PTCOMN(K)=PMAX2+XRATIO*PRANG2
      ATCOMN(K)=XI
 1280 CONTINUE
 1299 CONTINUE
C
      NMNT2=K
      GOTO9000
C
 1290 CONTINUE
C
C               ************************************
C               **  STEP 3--                      **
C               **  TREAT THE WEIBULL SCALE CASE  **
C               **  NOTE THAT THE COORDINATES WILL GO  **
C               **  FROM 0 TO 100 RATHER THAN FROM THE **
C               **  USUAL 0 TO 1                       **
C               ************************************
C
      IF(ISCASW.EQ.'WEIB')GOTO1300
      GOTO1390
C
C               *******************************
C               **  STEP 2.1--               **
C               **  COMPUTE MAJOR TIC MARKS  **
C               **  FOR THE WEIBULL CASE     **
C               *******************************
C
 1300 CONTINUE
      H=100.0
      IF(0.0.LT.FMIN.AND.FMIN.LT.100.0.AND.
     1   0.0.LT.FMAX.AND.FMAX.LT.100.0)GOTO1309
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1301)
 1301 FORMAT('***** ERROR IN DPDET2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1302)
 1302 FORMAT('      A WEIBULL SCALE MAY NOT BE USED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1303)
 1303 FORMAT('      UNLESS THE FRAME LIMITS ARE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1304)
 1304 FORMAT('      STRICTLY GREATER THAN 0 AND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1305)
 1305 FORMAT('      STRICTLY LESS THAN 100.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1306)FMIN,FMAX
 1306 FORMAT('      THE FRAME LIMITS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1307)
 1307 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1308)
 1308 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1309 CONTINUE
C
      EXPMIN=ALOG(ALOG(H/(H-FMIN)))
      EXPMAX=ALOG(ALOG(H/(H-FMAX)))
      DENOM=EXPMAX-EXPMIN
C
      PRANGE=PMAX-PMIN
      FRANGE=FMAX-FMIN
C
      NUMMAJ=NMJT
      IF(NMJT.LE.16)NUMMAJ=16
      IF(NMJT.GE.21)NUMMAJ=21
C
      K=0
      DO1310I=1,NUMMAJ
      K=K+1
      IP=I+(21-NUMMAJ)
      XI=WEIB21(IP)
      XRATIO=(ALOG(ALOG(H/(H-XI)))-ALOG(ALOG(H/(H-FMIN))))/DENOM
      PTCOOR(K)=PMIN+XRATIO*PRANGE
      ATCOOR(K)=XI
 1310 CONTINUE
 1329 CONTINUE
      NMJT2=K
C
C               *******************************
C               **  STEP 2.2--               **
C               **  COMPUTE MINOR TIC MARKS  **
C               **  FOR THE WEIBULL CASE     **
C               *******************************
C
      NMNT2=0
      GOTO9000
C
 1390 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1990
C               ************************************
C               **  STEP 4--                      **
C               **  TREAT THE NORMAL SCALE CASE   **
C               **  NOTE THAT THE COORDINATES WILL GO  **
C               **  FROM 0 TO 100 RATHER THAN FROM THE **
C               **  USUAL 0 TO 1                       **
C               ************************************
C
      IF(ISCASW.EQ.'NORM')GOTO1400
      GOTO1490
C
C               *******************************
C               **  STEP 2.1--               **
C               **  COMPUTE MAJOR TIC MARKS  **
C               **  FOR THE NORMAL CASE      **
C               *******************************
C
 1400 CONTINUE
      H=100.0
      IF(0.0.LT.FMIN.AND.FMIN.LT.100.0.AND.
     1   0.0.LT.FMAX.AND.FMAX.LT.100.0)GOTO1409
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1401)
 1401 FORMAT('***** ERROR IN DPDET2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1402)
 1402 FORMAT('      A NORMAL SCALE MAY NOT BE USED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1403)
 1403 FORMAT('      UNLESS THE FRAME LIMITS ARE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1404)
 1404 FORMAT('      STRICTLY GREATER THAN 0 AND')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1405)
 1405 FORMAT('      STRICTLY LESS THAN 100.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1406)FMIN,FMAX
 1406 FORMAT('      THE FRAME LIMITS = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1407)
 1407 FORMAT('      CORRECTIVE ACTION--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1408)
 1408 FORMAT('      CHANGE DATA OR CHANGE LIMITS.')
      CALL DPWRST('XXX','BUG ')
      IERRG4='YES'
      GOTO9000
 1409 CONTINUE
C
CCCCC EXPMIN=ALOG(ALOG(H/(H-FMIN)))
      ARG=FMIN/H
      CALL NORPPF(ARG,EXPMIN)
CCCCC EXPMAX=ALOG(ALOG(H/(H-FMAX)))
      ARG=FMAX/H
      CALL NORPPF(ARG,EXPMAX)
      DENOM=EXPMAX-EXPMIN
C
      PRANGE=PMAX-PMIN
      FRANGE=FMAX-FMIN
C
      NUMMAJ=NMJT
      IF(NMJT.LE.15)NUMMAJ=15
      IF(NMJT.GE.27)NUMMAJ=27
      IHALF=NUMMAJ/2
      I1=14-IHALF
      I2=14+IHALF
      IF(I1.LE.1)I1=1
      IF(I2.GE.NUMMAJ)I2=NUMMAJ
C
      K=0
      DO1410I=1,NUMMAJ
      K=K+1
      IP=I1+(I-1)
      XI=ANORM(IP)
CCCCC XRATIO=(ALOG(ALOG(H/(H-XI)))-ALOG(ALOG(H/(H-FMIN))))/DENOM
      ARG1=XI/H
      ARG2=FMIN/H
      CALL NORPPF(ARG1,XOUT1)
      CALL NORPPF(ARG2,XOUT2)
      XRATIO=(XOUT1-XOUT2)/DENOM
      PTCOOR(K)=PMIN+XRATIO*PRANGE
      ATCOOR(K)=XI
 1410 CONTINUE
 1429 CONTINUE
      NMJT2=K
C
C               *******************************
C               **  STEP 2.2--               **
C               **  COMPUTE MINOR TIC MARKS  **
C               **  FOR THE NORMAL CASE      **
C               *******************************
C
      NMNT2=0
      GOTO9000
C
 1490 CONTINUE
C
C               ***********************************
C               **  STEP 38--                    **
C               **  TREAT THE LINEAR SCALE CASE  **
C               ***********************************
C
C               *******************************
C               **  STEP 38.1--              **
C               **  COMPUTE MAJOR TIC MARKS  **
C               **  FOR THE LINEAR CASE      **
C               *******************************
C
 4800 CONTINUE
C
      NUMMAJ=NMJT
      IF(INMJSW.EQ.'FLOA')CALL DPDETN(FMIN,FMAX,NUMMAJ)
C
      ANUMMA=NUMMAJ
      DENOM=ANUMMA-1.0
      PRANGE=PMAX-PMIN
      FRANGE=FMAX-FMIN
C
C  ALGORITHIM ADJUSTED MAY, 1990 TO SUPPORT TIC OFFSETS.  NOTE THAT
C  OFFSET MAY BE DONE IN EITHER DATAPLOT UNITS OR DATA UNITS.
C
      IF(ITICUN.NE.'ABSO')GOTO4805
C
C  OFFSET IN DATAPLOT UNITS
C
      PMIN2=PMIN+PTCOFL
      PMAX2=PMAX-PTCOFR
      IF(PMIN2.LT.PMAX2)GOTO4803
      PMIN2=PMIN
      PMAX2=PMAX
      PRANG2=PRANGE
      FMIN2=FMIN
      FMAX2=FMAX
      FRANG2=FRANGE
      GOTO4809
 4803 CONTINUE
      PRANG2=PMAX2-PMIN2
      FMIN2=FMIN
      FMAX2=FMAX
      FRANG2=FRANGE
      FSCALE=FRANG2/PRANG2
      FMIN=FMIN2-FSCALE*PTCOFL
      FMAX=FMAX2+FSCALE*PTCOFR
      FRANGE=FMAX-FMIN
      GOTO4809
C
C  OFFSET IN DATA UNITS
C
 4805 CONTINUE
      FMIN2=FMIN
      FMAX2=FMAX
      FMIN=FMIN2-PTCOFL
      FMAX=FMAX2+PTCOFR
      FRANG2=FMAX2-FMIN2
      FRANGE=FMAX-FMIN
      PSCALE=PRANGE/FRANGE
      PMIN2=PMIN+PSCALE*PTCOFL
      PMAX2=PMAX-PSCALE*PTCOFR
      PRANG2=PMAX2-PMIN2
      GOTO4809
C
 4809 CONTINUE
C
      K=0
      IF(NUMMAJ.LE.0)GOTO4819
      DO4815I=1,NUMMAJ
      AI=I
      XRATIO=(AI-1.0)/DENOM
      K=K+1
CCCCC PTCOOR(K)=PMIN+XRATIO*PRANGE
CCCCC ATCOOR(K)=FMIN+XRATIO*FRANGE
      PTCOOR(K)=PMIN2+XRATIO*PRANG2
      ATCOOR(K)=FMIN2+XRATIO*FRANG2
      IF(FRANGE.GE.1.AND.
     1(-EPS).LE.ATCOOR(K).AND.
     1ATCOOR(K).LE.EPS)ATCOOR(K)=0.0
 4815 CONTINUE
C
 4819 CONTINUE
      NMJT2=K
C
C               *******************************
C               **  STEP 8.2--               **
C               **  COMPUTE MINOR TIC MARKS  **
C               **  FOR THE LINEAR CASE      **
C               *******************************
C
 4900 CONTINUE
      K=0
C
      XIMIN=ATCOOR(1)
      XIMAX=ATCOOR(2)
C
      NUMMIN=NMNT
      IF(INMNSW.EQ.'FLOA')NUMMIN=1
C
      ANUMMI=NUMMIN
      DENOM=ANUMMI+1.0
C
      NUMMAM=NUMMAJ-1
      IF(NUMMAM.LE.0)GOTO4919
      IF(NMJT2.LE.1)GOTO4919
CCCCC JUNE 1994.  ADD ONE CYCLE OF MINOR TICS WHEN THERE IS A TIC
CCCCC OFFSET.  TWO CASES, AT LOW END AND AT HIGH END.
CCCCC JUNE 1994.  CASE FOR LOW END.
      IF(NUMMIN.LE.0)GOTO4919
      IF(FMIN2.LE.FMIN)GOTO4929
      PRANGE=PTCOOR(2)-PTCOOR(1)
      FRANGE=ATCOOR(2)-ATCOOR(1)
      PSTART=PTCOOR(1)-PRANGE
      FSTART=ATCOOR(1)-FRANGE
      DO4926J=1,NUMMIN
      AJ=J
      XRATIO=AJ/DENOM
      PTTEMP=PSTART+XRATIO*PRANGE
      IF(PTTEMP.LT.PMIN)GOTO4926
      K=K+1
      PTCOMN(K)=PTTEMP
      ATCOMN(K)=FSTART+XRATIO*FRANGE
 4926 CONTINUE
 4929 CONTINUE
C
      DO4915I=1,NUMMAM
      IP1=I+1
      PRANGE=PTCOOR(IP1)-PTCOOR(I)
      FRANGE=ATCOOR(IP1)-ATCOOR(I)
      IF(NUMMIN.LE.0)GOTO4919
      DO4916J=1,NUMMIN
      AJ=J
      XRATIO=AJ/DENOM
      K=K+1
      PTCOMN(K)=PTCOOR(I)+XRATIO*PRANGE
      ATCOMN(K)=ATCOOR(I)+XRATIO*FRANGE
 4916 CONTINUE
 4915 CONTINUE
C
CCCCC JUNE 1994.  CASE FOR HIGH END.
      IF(FMAX2.GE.FMAX)GOTO4939
      PRANGE=PTCOOR(2)-PTCOOR(1)
      FRANGE=ATCOOR(2)-ATCOOR(1)
      DO4936J=1,NUMMIN
      AJ=J
      XRATIO=AJ/DENOM
      PTTEMP=PTCOOR(NUMMAJ)+XRATIO*PRANGE
      IF(PTTEMP.GT.PMAX)GOTO4939
      K=K+1
      PTCOMN(K)=PTTEMP
      ATCOMN(K)=ATCOOR(NUMMAJ)+XRATIO*FRANGE
 4936 CONTINUE
 4939 CONTINUE
C
 4919 CONTINUE
      NMNT2=K
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DET2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDET2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)PMIN,PMAX
 9012 FORMAT('PMIN,PMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)FMIN,FMAX
 9013 FORMAT('FMIN,FMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)ITICSW,ISCASW
 9014 FORMAT('ITICSW,ISCASW = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)NMJT,INMJSW,NUMMAJ
 9015 FORMAT('NMJT,INMJSW,NUMMAJ = ',I8,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)NMNT,INMNSW
 9016 FORMAT('NMNT,INMNSW = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)NMJT2
 9021 FORMAT('NMJT2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)FMIN,PMIN
 9022 FORMAT('  FMIN     ,PMIN      = ',8X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NMJT2.LE.0)GOTO9029
      DO9023I=1,NMJT2
      WRITE(ICOUT,9024)I,ATCOOR(I),PTCOOR(I)
 9024 FORMAT('I,ATCOOR(I),PTCOOR(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9023 CONTINUE
      WRITE(ICOUT,9025)FMAX,PMAX
 9025 FORMAT('  FMAX     ,PMAX      = ',8X,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9029 CONTINUE
      WRITE(ICOUT,9031)NMNT2
 9031 FORMAT('NMNT2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)FMIN,PMIN
 9032 FORMAT('  FMIN     ,PMIN      = ',8X,2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(NMNT2.LE.0)GOTO9039
      DO9033I=1,NMNT2
      WRITE(ICOUT,9034)I,ATCOMN(I),PTCOMN(I)
 9034 FORMAT('I,ATCOMN(I),PTCOMN(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9033 CONTINUE
      WRITE(ICOUT,9035)FMAX,PMAX
 9035 FORMAT('  FMAX     ,PMAX      = ',8X,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9039 CONTINUE
      WRITE(ICOUT,9041)EXPMIN,EXPMAX,DENOM
 9041 FORMAT('EXPMIN,EXPMAX,DENOM = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9042)IEXMIN,IEXMAX
 9042 FORMAT('IEXMIN,IEXMAX = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9043)NUMCYC,NUMCYP,PRANGE
 9043 FORMAT('NUMCYC,NUMCYP,PRANGE = ',2I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9044)NUMMAJ
 9044 FORMAT('NUMMAJ = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9045)NUMMIN
 9045 FORMAT('NUMMIN = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9047)XIMIN,XIMAX
 9047 FORMAT('XIMIN,XIMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9049)IBUGG4,ISUBG4,IERRG4
 9049 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)PMIN2,PMAX2
 9052 FORMAT('PMIN2,PMAX2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9053)FMIN2,FMAX2
 9053 FORMAT('FMIN2,FMAX2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9054)FRANG2,PRANG2
 9054 FORMAT('FRANG2,PRANG2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)ITICUN
 9055 FORMAT('ITICUN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9056)PTCOFL,PTCOFR
 9056 FORMAT('PTCOFL,PTCOFR = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDETM(PXMIN,PYMIN,PXMAX,PYMAX,
     1ICASPL,ICAS3D,
     1FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1FX2MIN,FX2MAX,FY2MIN,FY2MAX,
     1IX1TSW,IX2TSW,IY1TSW,IY2TSW,
     1IX1JSW,IX2JSW,IY1JSW,IY2JSW,
     1NMJX1T,NMJX2T,NMJY1T,NMJY2T,
     1IX1TSC,IX2TSC,IY1TSC,IY2TSC,
     1PX1COO,PX2COO,PY1COO,PY2COO,
     1X1COOR,X2COOR,Y1COOR,Y2COOR,
     1NX1COO,NX2COO,NY1COO,NY2COO,
     1IX1NSW,IX2NSW,IY1NSW,IY2NSW,
     1NMNX1T,NMNX2T,NMNY1T,NMNY2T,
     1PX1CMN,PX2CMN,PY1CMN,PY2CMN,
     1X1COMN,X2COMN,Y1COMN,Y2COMN,
     1NX1CMN,NX2CMN,NY1CMN,NY2CMN,
     1PX1TOL,PX2TOL,PY1TOB,PY2TOB,
     1PX1TOR,PX2TOR,PY1TOT,PY2TOT,
     1ITICUN)
CCCC ABOVE 3 LINES ADDED TO CALL SEQUENCE MAY, 1990 (TO ADD TIC OFFSETS)
C
C     PURPOSE--DETERMINE AND SET TIC MARKS
C             ON ALL 4 FRAME LINES.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C     UPDATED--MAY        1990.  ADD SUPPORT FOR TIC OFFSETS
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ICAS3D
C
      CHARACTER*4 IX1TSW
      CHARACTER*4 IX2TSW
      CHARACTER*4 IY1TSW
      CHARACTER*4 IY2TSW
C
      CHARACTER*4 IX1JSW
      CHARACTER*4 IX2JSW
      CHARACTER*4 IY1JSW
      CHARACTER*4 IY2JSW
C
      CHARACTER*4 IX1NSW
      CHARACTER*4 IX2NSW
      CHARACTER*4 IY1NSW
      CHARACTER*4 IY2NSW
C
      CHARACTER*4 IX1TSC
      CHARACTER*4 IX2TSC
      CHARACTER*4 IY1TSC
      CHARACTER*4 IY2TSC
C FOLLOWING LINE ADDED MAY, 1990.
      CHARACTER*4 ITICUN
C
      DIMENSION PX1COO(*)
      DIMENSION PX2COO(*)
      DIMENSION PY1COO(*)
      DIMENSION PY2COO(*)
C
      DIMENSION X1COOR(*)
      DIMENSION X2COOR(*)
      DIMENSION Y1COOR(*)
      DIMENSION Y2COOR(*)
C
      DIMENSION PX1CMN(*)
      DIMENSION PX2CMN(*)
      DIMENSION PY1CMN(*)
      DIMENSION PY2CMN(*)
C
      DIMENSION X1COMN(*)
      DIMENSION X2COMN(*)
      DIMENSION Y1COMN(*)
      DIMENSION Y2COMN(*)
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.'DETM')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDETM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)PXMIN,PYMIN,PXMAX,PYMAX
   52 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)FX1MIN,FX1MAX,FY1MIN,FY1MAX
   53 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)FX2MIN,FX2MAX,FY2MIN,FY2MAX
   54 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IX1TSW,IX2TSW,IY1TSW,IY2TSW
   56 FORMAT('IX1TSW,IX2TSW,IY1TSW,IY2TSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,57)IX1JSW,IX2JSW,IY1JSW,IY2JSW
   57 FORMAT('IX1JSW,IX2JSW,IY1JSW,IY2JSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,58)NMJX1T,NMJX2T,NMJY1T,NMJY2T
   58 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IX1NSW,IX2NSW,IY1NSW,IY2NSW
   61 FORMAT('IX1NSW,IX2NSW,IY1NSW,IY2NSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,62)NMNX1T,NMNX2T,NMNY1T,NMNY2T
   62 FORMAT('NMNX1T,NMNX2T,NMNY1T,NMNY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)ICASPL,ICAS3D
   63 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,70)ITICUN
   70 FORMAT('ITICUN = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)PX1TOL,PX2TOL,PY1TOB,PY2TOB
   71 FORMAT('PX1TOL,PX2TOL,PY1TOB,PY2TOB = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)PX1TOR,PX2TOR,PY1TOT,PY2TOT
   72 FORMAT('PX1TOR,PX2TOR,PY1TOT,PY2TOT = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ******************************************************
C               **  STEP 1--                                        **
C               **  DETERMINE MAJOR TIC MARKS ON BOTTOM HORIZONTAL AXIS  **
C               ******************************************************
C
      CALL DPDET2(PXMIN,PXMAX,FX1MIN,FX1MAX,
     1IX1TSW,IX1TSC,
     1NMJX1T,IX1JSW,
     1PX1COO,X1COOR,NX1COO,
     1NMNX1T,IX1NSW,
     1PX1CMN,X1COMN,NX1CMN,
     1PX1TOL,PX1TOR,ITICUN)
C  ABOVE LINE ADDED MAY, 1990.
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 2--                                        **
C               **  DETERMINE MAJOR TIC MARKS ON TOP  HORIZONTAL   AXIS  **
C               ******************************************************
C
      CALL DPDET2(PXMIN,PXMAX,FX2MIN,FX2MAX,
     1IX2TSW,IX2TSC,
     1NMJX2T,IX2JSW,
     1PX2COO,X2COOR,NX2COO,
     1NMNX2T,IX2NSW,
     1PX2CMN,X2COMN,NX2CMN,
     1PX2TOL,PX2TOR,ITICUN)
C  ABOVE LINE ADDED MAY, 1990.
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 3--                                        **
C               **  DETERMINE MAJOR TIC MARKS ON LEFT    VERTICAL AXIS  **
C               ******************************************************
C
      CALL DPDET2(PYMIN,PYMAX,FY1MIN,FY1MAX,
     1IY1TSW,IY1TSC,
     1NMJY1T,IY1JSW,
     1PY1COO,Y1COOR,NY1COO,
     1NMNY1T,IY1NSW,
     1PY1CMN,Y1COMN,NY1CMN,
     1PY1TOB,PY1TOT,ITICUN)
C  ABOVE LINE ADDED MAY, 1990.
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               ******************************************************
C               **  STEP 4--                                        **
C               **  DETERMINE MAJOR TIC MARKS ON RIGHT   VERTICAL   AXIS  **
C               ******************************************************
C
      CALL DPDET2(PYMIN,PYMAX,FY2MIN,FY2MAX,
     1IY2TSW,IY2TSC,
     1NMJY2T,IY2JSW,
     1PY2COO,Y2COOR,NY2COO,
     1NMNY2T,IY2NSW,
     1PY2CMN,Y2COMN,NY2CMN,
     1PY2TOB,PY2TOT,ITICUN)
C  ABOVE LINE ADDED MAY, 1990.
      IF(IERRG4.EQ.'YES')GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETM')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDETM--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)PXMIN,PYMIN,PXMAX,PYMAX
 9012 FORMAT('PXMIN,PYMIN,PXMAX,PYMAX = ',4F10.5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)FX1MIN,FX1MAX,FY1MIN,FY1MAX
 9013 FORMAT('FX1MIN,FX1MAX,FY1MIN,FY1MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)FX2MIN,FX2MAX,FY2MIN,FY2MAX
 9014 FORMAT('FX2MIN,FX2MAX,FY2MIN,FY2MAX = ',4E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IX1TSW,IX2TSW,IY1TSW,IY2TSW
 9016 FORMAT('IX1TSW,IX2TSW,IY1TSW,IY2TSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IX1JSW,IX2JSW,IY1JSW,IY2JSW
 9017 FORMAT('IX1JSW,IX2JSW,IY1JSW,IY2JSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)NMJX1T,NMJX2T,NMJY1T,NMJY2T
 9018 FORMAT('NMJX1T,NMJX2T,NMJY1T,NMJY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)NX1COO,NX2COO,NY1COO,NY2COO
 9020 FORMAT('NX1COO,NX2COO,NY1COO,NY2COO = ',4I8)
      CALL DPWRST('XXX','BUG ')
C
      IF(NX1COO.LE.0)GOTO9029
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9021I=1,NX1COO
      WRITE(ICOUT,9022)I,PX1COO(I),X1COOR(I)
 9022 FORMAT('I,PX1COO(I),X1COOR(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)ICASPL,ICAS3D
 9023 FORMAT('ICASPL,ICAS3D = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
 9029 CONTINUE
C
      IF(NX2COO.LE.0)GOTO9039
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9031I=1,NX2COO
      WRITE(ICOUT,9032)I,PX2COO(I),X2COOR(I)
 9032 FORMAT('I,PX2COO(I),X2COOR(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9039 CONTINUE
C
      IF(NY1COO.LE.0)GOTO9049
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9041I=1,NY1COO
      WRITE(ICOUT,9042)I,PY1COO(I),Y1COOR(I)
 9042 FORMAT('I,PY1COO(I),Y1COOR(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9049 CONTINUE
C
      IF(NY2COO.LE.0)GOTO9059
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9051I=1,NY2COO
      WRITE(ICOUT,9052)I,PY2COO(I),Y2COOR(I)
 9052 FORMAT('I,PY2COO(I),Y2COOR(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9051 CONTINUE
 9059 CONTINUE
C
      WRITE(ICOUT,9117)IX1NSW,IX2NSW,IY1NSW,IY2NSW
 9117 FORMAT('IX1NSW,IX2NSW,IY1NSW,IY2NSW = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9118)NMNX1T,NMNX2T,NMNY1T,NMNY2T
 9118 FORMAT('NMNX1T,NMNX2T,NMNY1T,NMNY2T = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9120)NX1CMN,NX2CMN,NY1CMN,NY2CMN
 9120 FORMAT('NX1CMN,NX2CMN,NY1CMN,NY2CMN = ',4I8)
      CALL DPWRST('XXX','BUG ')
C
      IF(NX1CMN.LE.0)GOTO9129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9121I=1,NX1CMN
      WRITE(ICOUT,9122)I,PX1CMN(I)
 9122 FORMAT('I,PX1CMN(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9121 CONTINUE
 9129 CONTINUE
C
      IF(NX2CMN.LE.0)GOTO9139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9131I=1,NX2CMN
      WRITE(ICOUT,9132)I,PX2CMN(I)
 9132 FORMAT('I,PX2CMN(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9131 CONTINUE
 9139 CONTINUE
C
      IF(NY1CMN.LE.0)GOTO9149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9141I=1,NY1CMN
      WRITE(ICOUT,9142)I,PY1CMN(I)
 9142 FORMAT('I,PY1CMN(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9141 CONTINUE
 9149 CONTINUE
C
      IF(NY2CMN.LE.0)GOTO9159
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      DO9151I=1,NY2CMN
      WRITE(ICOUT,9152)I,PY2CMN(I)
 9152 FORMAT('I,PY2CMN(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9151 CONTINUE
 9159 CONTINUE
C
      WRITE(ICOUT,9189)IBUGG4,ISUBG4,IERRG4
 9189 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDETN(FMIN,FMAX,NUMTIC)
C
C     PURPOSE--GIVEN FRAME LIMITS,
C              COMPUTE THE NUMBER OF MAJOR TIC MARKS
C              (INCLUDING THE ENDS)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ICINT
C
      DIMENSION NINTER(100)
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---------------------------------------------------------------------
C
      DATA (NINTER(I),I=1,100)
     1/4,4,6,4,5,6,7,8,9,10,
     1 11,6,4,7,3,8,4,9,4,4,
     1 7,11,4,8,5,4,9,7,4,6,
     1 4,8,11,4,7,12,4,4,6,8,
     1 4,7,4,11,9,4,4,8,7,5,
     1 4,4,4,9,11,7,6,4,4,6,
     1 4,4,7,8,5,11,4,4,6,7,
     1 4,9,4,4,5,4,11,4,4,8,
     1 9,4,4,7,5,4,6,11,4,9,
     1 7,8,6,4,5,8,4,7,11,10/
C
C-----START POINT-----------------------------------------------------
C
      IEXP=(-999)
      XTDEL=(-999)
      NINT=(-999)
      NUMINT=(-999)
C
      EPS=0.0001
      ONEMEP=1.0-EPS
      ONEPEP=1.0+EPS
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETN')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDETN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)FMIN,FMAX
   52 FORMAT('FMIN,FMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************
C               **  STEP 1--                       **
C               **  COPY OVER THE INPUT VARAIBLES  **
C               **  INTO TEMPORARY VARIABLES       **
C               *************************************
C
      XTMIN=FMIN
      XTMAX=FMAX
      IF(FMAX.LT.FMIN)XTMIN=FMAX
      IF(FMAX.LT.FMIN)XTMAX=FMIN
      IF(FMIN.EQ.FMAX)NUMTIC=5
      IF(FMIN.EQ.FMAX)GOTO9000
C
C               *******************************************************
C               **  STEP 2--                                         **
C               **  SCALE DOWN (OR UP) THE DIFFERENCE IN THE LIMITS  **
C               **  UNTIL THE DIFFERENCE IS IN THE REGION 1 TO 10.   **
C               *******************************************************
C
      IEXP=0
 1200 CONTINUE
      XTDEL=XTMAX-XTMIN
      IF(IBUGG4.EQ.'ON')WRITE(ICOUT,1205)XTMIN,XTMAX,XTDEL,IEXP
 1205 FORMAT('XTMIN,XTMAX,XTDEL,IEXP = ',3F12.5,I8)
      IF(IBUGG4.EQ.'ON')CALL DPWRST('XXX','BUG ')
      IF(XTDEL.LT.1.0)GOTO1210
      IF(XTDEL.GT.10.0)GOTO1220
      GOTO1250
C
 1210 CONTINUE
      XTMIN=XTMIN*10.0
      XTMAX=XTMAX*10.0
      IEXP=IEXP+1
      GOTO1200
C
 1220 CONTINUE
      XTMIN=XTMIN/10.0
      XTMAX=XTMAX/10.0
      IEXP=IEXP-1
      GOTO1200
C
C               ********************************************
C               **  STEP 3--                              **
C               **  DETERMINE A NEAT NUMBER OF TIC MARKS  **
C               **  BASED ON THE ROUNDED DIFFERENCE       **
C               **  IN THE 1 TO 10 RANGE.                 **
C               ********************************************
C
 1250 CONTINUE
      XTMAX2=XTDEL
      CALL CKINTE(XTMAX2,EPS,ONEMEP,ONEPEP,ICINT,IXTMX2)
      IF(ICINT.EQ.'YES')GOTO1259
C
      XTMAX2=XTMAX2*10.0
      CALL CKINTE(XTMAX2,EPS,ONEMEP,ONEPEP,ICINT,IXTMX2)
      IF(ICINT.EQ.'YES')GOTO1259
C
      XTMAX2=XTMAX2*10.0
      CALL CKINTE(XTMAX2,EPS,ONEMEP,ONEPEP,ICINT,IXTMX2)
      GOTO1259
 1259 CONTINUE
C
      NINT=IXTMX2
      IF(NINT.GT.100)NINT=100
      NUMINT=NINTER(NINT)
      NUMTIC=NUMINT+1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'DETN')GOTO9090
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDETN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)FMIN,FMAX
 9012 FORMAT('FMIN,FMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)IEXP
 9014 FORMAT('IEXP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)XTDEL,XTMAX2,EPS,ICINT,IXTMX2
 9021 FORMAT('XTDEL,XTMAX2,EPS,ICINT,IXTMX2 = ',3E15.7,2X,A4,I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IXTMX2,NINT,NUMINT,NUMTIC
 9022 FORMAT('IXTMX2,NINT,NUMINT,NUMTIC = ',4I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4
 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
CCCCC DEBUG TRACE,INIT
CCCCC AT 90
CCCCC TRACE ON
      END
      SUBROUTINE DPDETR(IP,IC,XS,YS,IVIS,NS,
     1IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,
     1XMIN,XMAX,IPASS,
     1XOUT,YOUT,TAGOUT,NOUT,NTRACE,
     1IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--FOR A PAIR OF POINTS WITH INDICES IP AND IC,
C              (THAT IS, FOR POINT 1 = (XS(IP),YS(IP))
C              AND           POINT 2 = (XS(IP),YS(IP))
C              DETERMINE DRAWABLE OUTPUT TRACES BASED ON
C              COMPARISON OF THE (ASSUMED) LINEAR TRACE
C              BETWEEN THE 2 POINTS, AND
C              WITH CURRENT INTERMEDIATE HORIZON TABLES VALUES.
C              ALSO, UPDATE THE HORIZON TABLES AFTER THE FACT.
C     NOTE--THE 2 POINTS HAVE INDICES IP AND IC
C           WITHIN THE DATA VECTORS XS(.), YS(.), AND IVIS(.);
C           THE SAME 2 POINTS HAVE INDICES IPHORI AND IVHORI
C           WITHIN THE HORIZON VECTORS AUPPER(.), ALOWER(.), AND XHORIZ(.).
C     REFERENCE--ROGERS, DAVID F. (1985).  PROCEDURAL
C                ELEMENTS FOR COMPUTER GRAPHICS.
C                MCGRAW-HILL, NEW YORK, PAGE 197-201.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/9
C     ORIGINAL VERSION--AUGUST    1988.
C     UPDATED         --APRIL     1992. DEFINE 6 SCALARS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IVIS
      CHARACTER*4 IPVIS
      CHARACTER*4 ICVIS
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ICASEF
C
      CHARACTER*4 ICASHO
      CHARACTER*4 ICASIN
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION XS(*)
      DIMENSION YS(*)
      DIMENSION IVIS(*)
C
      DIMENSION AUPPER(*)
      DIMENSION ALOWER(*)
      DIMENSION XHORIZ(*)
C
      DIMENSION XOUT(*)
      DIMENSION YOUT(*)
      DIMENSION TAGOUT(*)
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='DPDE'
      ISUBN2='TR  '
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED   APRIL 1992
      XTEMPO=(-999.0)
      YTEMPO=(-999.0)
      YCUTOL=(-999.0)
      XTEMP=(-999.0)
      YTEMP=(-999.0)
      YCUT=(-999.0)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGU2,ISUBRO,IERROR
   52 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IP,IC,NS
   53 FORMAT('IP,IC,NS = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=IP,IC
      WRITE(ICOUT,56)I,XS(I),YS(I),IVIS(I)
   56 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,61)IPHORI,ICHORI,NHORP
   61 FORMAT('IPHORI,ICHORI,NHORP = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=IPHORI,ICHORI
      WRITE(ICOUT,66)I,AUPPER(I),ALOWER(I),XHORIZ(I)
   66 FORMAT('I,AUPPER(I),ALOWER(I),XHORIZ(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
      WRITE(ICOUT,71)XMIN,XMAX
   71 FORMAT('XMIN,XMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)IPASS
   72 FORMAT('IPASS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,81)NOUT,NTRACE
   81 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO85I=1,NOUT
      WRITE(ICOUT,86)I,XOUT(I),YOUT(I),TAGOUT(I)
   86 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
   85 CONTINUE
   90 CONTINUE
C
      XP=XS(IP)
      YP=YS(IP)
      IPVIS=IVIS(IP)
C
      XC=XS(IC)
      YC=YS(IC)
      ICVIS=IVIS(IC)
C
      YPU=AUPPER(IPHORI)
      YPL=ALOWER(IPHORI)
      YCU=AUPPER(ICHORI)
      YCL=ALOWER(ICHORI)
C
      XCUT=(XHORIZ(IPHORI)+XHORIZ(ICHORI))/2.0
      SLOEPS=0.000001
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO110
      GOTO119
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** FROM THE EARLY MIDDLE OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)IPHORI,ICHORI
  112 FORMAT('IPHORI,ICHORI = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)XP,YP,YPU,YPL,IPVIS
  113 FORMAT('XP,YP,YPU,YPL,IPVIS = ',4E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)XC,YC,YCU,YCL,ICVIS
  114 FORMAT('XC,YC,YCU,YCL,ICVIS = ',4E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)XCUT
  115 FORMAT('XCUT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  119 CONTINUE
C
C               **************************************************
C               **  STEP 10--                                   **
C               **  BRANCH TO 1 OF 6 CASES--                    **
C               **     1. SAME CELL,         INFINITE SLOPE     **
C               **     2. SAME CELL,         FINITE   SLOPE     **
C               **     3. ADJACENT CELL,     INFINITE SLOPE (IMPOSSIBLE)     **
C               **     4. ADJACENT CELL,     FINITE   SLOPE     **
C               **     5. NON-ADJACENT CELL, INFINITE SLOPE (IMPOSSIBLE)     **
C               **     6. NON-ADJACENT CELL, FINITE   SLOPE     **
C               **************************************************
C
      IDEL=ICHORI-IPHORI
      IF(IDEL.EQ.0)GOTO1000
      IF(IDEL.EQ.1)GOTO1100
      GOTO1200
C
 1000 CONTINUE
      IF(XC.EQ.XP)GOTO2000
      GOTO3000
 1100 CONTINUE
      IF(XC.EQ.XP)GOTO4000
      GOTO5000
 1200 CONTINUE
      IF(XC.EQ.XP)GOTO6000
      GOTO7000
C
C               **************************************************
C               **  STEP 20--                                   **
C     ----------**  TREAT THE CASE OF SAME HORIZON CELL         **----------
C               **  AND INFINITE SLOPE                          **
C               **************************************************
C
 2000 CONTINUE
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'YES')GOTO2100
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'NO')GOTO2200
      IF(IPVIS.EQ.'NO'.AND.ICVIS.EQ.'YES')GOTO2300
      GOTO2400
C
C               **************************************************
C               **  STEP 21--                                   **
C               **  FOR THE SAME CELL & INFINITE SLOPE CASE,    **
C               **  TREAT THE VISIBLE/VISIBLE SUBCASE.          **
C               **************************************************
C
 2100 CONTINUE
      ISTEPN='2100'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU.AND.YC.GE.YCU)GOTO2110
      IF(YP.LE.YPL.AND.YC.LE.YCL)GOTO2120
      IF(YP.LE.YPL.AND.YC.GE.YCU)GOTO2130
      GOTO2140
C
 2110 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      IF(YC.GT.YP)AUPPER(ICHORI)=YC
      GOTO9000
C
 2120 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      IF(YC.LT.YP)ALOWER(ICHORI)=YC
      GOTO9000
C
 2130 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      AUPPER(ICHORI)=YC
      GOTO9000
C
 2140 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 22--                                   **
C               **  FOR THE SAME CELL & INFINITE SLOPE CASE,    **
C               **  TREAT THE VISIBLE/INVISIBLE SUBCASE.        **
C               **************************************************
C
 2200 CONTINUE
      ISTEPN='2200'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU)GOTO2210
      GOTO2220
C
 2210 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      GOTO9000
C
 2220 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      GOTO9000
C
C               **************************************************
C               **  STEP 23--                                   **
C               **  FOR THE SAME CELL & INFINITE SLOPE CASE,    **
C               **  TREAT THE INVISIBLE/VISIBLE SUBCASE.        **
C               **************************************************
C
 2300 CONTINUE
      ISTEPN='2300'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YC.GE.YCU)GOTO2310
      GOTO2320
C
 2310 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(ICHORI)=YC
      GOTO9000
C
 2320 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 24--                                   **
C               **  FOR THE SAME CELL & INFINITE SLOPE CASE,    **
C               **  TREAT THE INVISIBLE/INVISIBLE SUBCASE.      **
C               **************************************************
C
 2400 CONTINUE
      ISTEPN='2400'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      GOTO9000
C
C               **************************************************
C               **  STEP 30--                                   **
C     ----------**  TREAT THE CASE OF SAME HORIZON CELL         **----------
C               **  AND FINITE SLOPE                            **
C               **************************************************
C
 3000 CONTINUE
      ISTEPN='3000'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      SLOPE=(YC-YP)/(XC-XP)
      ABSSLO=ABS(SLOPE)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO3010
      GOTO3019
 3010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3011)
 3011 FORMAT('***** FROM THE MIDDLE OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3012)YC,YP,XC,XP,SLOPE
 3012 FORMAT('YC,YP,XC,XP,SLOPE = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
 3019 CONTINUE
C
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'YES')GOTO3100
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'NO')GOTO3200
      IF(IPVIS.EQ.'NO'.AND.ICVIS.EQ.'YES')GOTO3300
      GOTO3400
C
C               **************************************************
C               **  STEP 31--                                   **
C               **  FOR THE SAME CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/VISIBLE SUBCASE.          **
C               **************************************************
C
 3100 CONTINUE
      ISTEPN='3100'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU.AND.YC.GE.YCU)GOTO3110
      IF(YP.LE.YPL.AND.YC.LE.YCL)GOTO3120
      IF(YP.LE.YPL.AND.YC.GE.YCU)GOTO3130
      GOTO3140
C
 3110 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      IF(YC.GT.YP)AUPPER(ICHORI)=YC
      GOTO9000
C
 3120 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      IF(YC.LT.YP)ALOWER(ICHORI)=YC
      GOTO9000
C
 3130 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPL-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCU-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      AUPPER(ICHORI)=YC
      GOTO9000
C
 3140 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPU-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCL-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 32--                                   **
C               **  FOR THE SAME CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/INVISIBLE SUBCASE.        **
C               **************************************************
C
 3200 CONTINUE
      ISTEPN='3200'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU)GOTO3210
      GOTO3220
C
 3210 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPU-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      GOTO9000
C
 3220 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPL-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      GOTO9000
C
C               **************************************************
C               **  STEP 33--                                   **
C               **  FOR THE SAME CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE INVISIBLE/VISIBLE SUBCASE.        **
C               **************************************************
C
 3300 CONTINUE
      ISTEPN='3300'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YC.GE.YCU)GOTO3310
      GOTO3320
C
 3310 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCU-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(ICHORI)=YC
      GOTO9000
C
 3320 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCL-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 34--                                   **
C               **  FOR THE SAME CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE INVISIBLE/INVISIBLE SUBCASE.      **
C               **************************************************
C
 3400 CONTINUE
      ISTEPN='3400'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      GOTO9000
C
C               **************************************************
C               **  STEP 40--                                   **
C     ----------**  TREAT THE CASE OF ADJACENT HORIZON CELL     **----------
C               **  AND INFINITE SLOPE                          **
C               **  (SHOULD BE IMPOSSIBLE)                      **
C               **************************************************
C
 4000 CONTINUE
      ISTEPN='4000'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4010)
 4010 FORMAT('***** INTERNAL ERROR IN DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4011)
 4011 FORMAT('      AT BRANCH POINT 4000 (AN IMPOSSIBLE BRANCH)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4012)
 4012 FORMAT('      CONDITION = ADJACENT CELL BUT INFINITE SLOPE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4013)
 4013 FORMAT('      IF HAVE INFINITE SLOPE, THEN NECESSARILY MUST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4014)
 4014 FORMAT('      BE IN SAME CELL.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4015)IP,IC
 4015 FORMAT('IP,IC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4016)IPHORI,ICHORI
 4016 FORMAT('IPHORI,ICHORI = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4017)XS(IP),YS(IP),XS(IC),YS(IC)
 4017 FORMAT('XS(IP),YS(IP),XS(IC),YS(IC) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               **************************************************
C               **  STEP 50--                                   **
C     ----------**  TREAT THE CASE OF ADJACENT HORIZON CELL     **----------
C               **  AND FINITE SLOPE                            **
C               **************************************************
C
 5000 CONTINUE
      ISTEPN='5000'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      SLOPE=(YC-YP)/(XC-XP)
      ABSSLO=ABS(SLOPE)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO5010
      GOTO5019
 5010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5011)
 5011 FORMAT('***** FROM THE MIDDLE OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5012)YC,YP,XC,XP,SLOPE
 5012 FORMAT('YC,YP,XC,XP,SLOPE = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
 5019 CONTINUE
C
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'YES')GOTO5100
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'NO')GOTO5200
      IF(IPVIS.EQ.'NO'.AND.ICVIS.EQ.'YES')GOTO5300
      GOTO5400
C
C               **************************************************
C               **  STEP 51--                                   **
C               **  FOR ADJACENT CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/VISIBLE SUBCASE.          **
C               **  5130 AND 5140 ASSUMES HIGH RES. HOR. GRID   **
C               **************************************************
C
 5100 CONTINUE
      ISTEPN='5100'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU.AND.YC.GE.YCU)GOTO5110
      IF(YP.LE.YPL.AND.YC.LE.YCL)GOTO5120
      IF(YP.LE.YPL.AND.YC.GE.YCU)GOTO5130
      GOTO5140
C
 5110 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      AUPPER(ICHORI)=YC
      GOTO9000
C
 5120 CONTINUE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      ALOWER(ICHORI)=YC
      GOTO9000
C
 5130 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPL-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCU-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      AUPPER(ICHORI)=YC
      GOTO9000
C
 5140 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPU-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCL-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 52--                                   **
C               **  FOR ADJACENT CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/INVISIBLE SUBCASE.        **
C               **  5210 AND 5220 ASSUMES HIGH RES. HOR. GRID   **
C               **************************************************
C
 5200 CONTINUE
      ISTEPN='5200'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU)GOTO5210
      GOTO5220
C
 5210 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPU-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPU
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      GOTO9000
C
 5220 CONTINUE
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XP+(YPL-YP)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YPL
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      GOTO9000
C
C               **************************************************
C               **  STEP 53--                                   **
C               **  FOR ADJACENT CELL & FINITE SLOPE   CASE,    **
C               **  5310 AND 5320 ASSUMES HIGH RES. HOR. GRID   **
C               **  TREAT THE INVISIBLE/VISIBLE SUBCASE.        **
C               **************************************************
C
 5300 CONTINUE
      ISTEPN='5300'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YC.GE.YCU)GOTO5310
      GOTO5320
C
 5310 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCU-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCU
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(ICHORI)=YC
      GOTO9000
C
 5320 CONTINUE
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      IF(ABSSLO.LE.SLOEPS)XTEMP=XCUT
      IF(ABSSLO.GT.SLOEPS)XTEMP=XC+(YCL-YC)/SLOPE
      IF(SLOPE.NE.0.0.AND.XTEMP.GT.XCUT)XOUTT=XCUT
      XOUT(NOUT)=XTEMP
      YOUT(NOUT)=YCL
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(ICHORI)=YC
      GOTO9000
C
C               **************************************************
C               **  STEP 54--                                   **
C               **  FOR ADJACENT CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE INVISIBLE/INVISIBLE SUBCASE.      **
C               **************************************************
C
 5400 CONTINUE
      ISTEPN='5400'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      GOTO9000
C
C               **************************************************
C               **  STEP 60--                                   **
C     ----------**  TREAT THE CASE OF NON-ADJ. HORIZON CELL     **----------
C               **  AND INFINITE SLOPE                          **
C               **  (SHOULD BE IMPOSSIBLE)                      **
C               **************************************************
C
 6000 CONTINUE
      ISTEPN='6000'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6010)
 6010 FORMAT('***** INTERNAL ERROR IN DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6011)
 6011 FORMAT('      AT BRANCH POINT 4000 (AN IMPOSSIBLE BRANCH)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6012)
 6012 FORMAT('      CONDITION = ADJACENT CELL BUT INFINITE SLOPE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6013)
 6013 FORMAT('      IF HAVE INFINITE SLOPE, THEN NECESSARILY MUST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6014)
 6014 FORMAT('      BE IN SAME CELL.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6015)IP,IC
 6015 FORMAT('IP,IC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6016)IPHORI,ICHORI
 6016 FORMAT('IPHORI,ICHORI = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,6017)XS(IP),YS(IP),XS(IC),YS(IC)
 6017 FORMAT('XS(IP),YS(IP),XS(IC),YS(IC) = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               **************************************************
C               **  STEP 70--                                   **
C     ----------**  TREAT THE CASE OF NON-ADJ. HORIZON CELL     **----------
C               **  AND FINITE SLOPE                            **
C               **************************************************
C
 7000 CONTINUE
      ISTEPN='7000'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      SLOPE=(YC-YP)/(XC-XP)
      ABSSLO=ABS(SLOPE)
C
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO7010
      GOTO7019
 7010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7011)
 7011 FORMAT('***** FROM THE MIDDLE OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,7012)YC,YP,XC,XP,SLOPE
 7012 FORMAT('YC,YP,XC,XP,SLOPE = ',5E15.7)
      CALL DPWRST('XXX','BUG ')
 7019 CONTINUE
C
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'YES')GOTO7100
      IF(IPVIS.EQ.'YES'.AND.ICVIS.EQ.'NO')GOTO7200
      IF(IPVIS.EQ.'NO'.AND.ICVIS.EQ.'YES')GOTO7300
      GOTO7400
C
C               **************************************************
C               **  STEP 71--                                   **
C               **  FOR NON-ADJ. CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/VISIBLE SUBCASE.          **
C               **  7130 AND 7140 ASSUMES DENSE DATA POINTS     **
C               **  TO AVOID SLOPED LINE GOING THROUGH          **
C               **  INVISIBLE REGION MORE THAN ONCE.            **
C               **************************************************
C
 7100 CONTINUE
      ISTEPN='7100'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU.AND.YC.GE.YCU)GOTO7110
      IF(YP.LE.YPL.AND.YC.LE.YCL)GOTO7120
      IF(YP.LE.YPL.AND.YC.GE.YCU)GOTO7130
      GOTO7150
C
 7110 CONTINUE
      ISTEPN='7110'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      AUPPER(ICHORI)=YC
      ICASEF='UPPE'
      CALL FILLHT(IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
 7120 CONTINUE
      ISTEPN='7120'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      ALOWER(ICHORI)=YC
      ICASEF='LOWE'
      CALL FILLHT(IPHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
 7130 CONTINUE
      ISTEPN='7130'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='LOWE'
      ICASIN='GE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      ICASEF='LOWE'
      CALL FILLHT(IPHORI,ITHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
C
 7140 CONTINUE
      ISTART=ITHORI
      ICASHO='UPPE'
      ICASIN='GE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(ICHORI)=YC
      ICASEF='UPPE'
      CALL FILLHT(ITHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
 7150 CONTINUE
      ISTEPN='7150'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='UPPE'
      ICASIN='LE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      ICASEF='UPPE'
      CALL FILLHT(IPHORI,ITHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
CCCCC GOTO9000   SHOULD THIS BE COMMENTED OUT?--IT WAS IN ORIG. VERSION OF D
C
 7160 CONTINUE
      ISTART=ITHORI
      ICASHO='LOWE'
      ICASIN='LE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(ICHORI)=YC
      ICASEF='LOWE'
      CALL FILLHT(ITHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
C               **************************************************
C               **  STEP 72--                                   **
C               **  FOR NON-ADJ. CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE VISIBLE/INVISIBLE SUBCASE.        **
C               **  7210 AND 7220 ASSUMES HIGH RES. HOR. GRID   **
C               **  TO AVOID SLOPED LINE HITTING MULTIPLE STEPS **
C               **************************************************
C
 7200 CONTINUE
      ISTEPN='7200'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YP.GE.YPU)GOTO7210
      GOTO7220
C
 7210 CONTINUE
      ISTEPN='7210'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='UPPE'
      ICASIN='LE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      AUPPER(IPHORI)=YP
      ICASEF='UPPE'
      CALL FILLHT(IPHORI,ITHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
 7220 CONTINUE
      ISTEPN='7220'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='LOWE'
      ICASIN='GE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      ALOWER(IPHORI)=YP
      ICASEF='LOWE'
      CALL FILLHT(IPHORI,ITHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
C               **************************************************
C               **  STEP 73--                                   **
C               **  FOR NON-ADJ. CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE INVISIBLE/VISIBLE SUBCASE.        **
C               **  7310 AND 7320 ASSUMES HIGH RES. HOR. GRID   **
C               **  TO AVOID SLOPED LINE HITTING MULTIPLE STEPS **
C               **************************************************
C
 7300 CONTINUE
      ISTEPN='7300'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      IF(YC.GE.YCU)GOTO7310
      GOTO7320
C
 7310 CONTINUE
      ISTEPN='7310'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='UPPE'
      ICASIN='GE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      AUPPER(ICHORI)=YC
      ICASEF='UPPE'
      CALL FILLHT(ITHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
 7320 CONTINUE
      ISTEPN='7320'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      ISTART=IPHORI
      ICASHO='LOWE'
      ICASIN='LE'
      CALL DPCOIP(XP,YP,XC,YC,SLOPE,ABSSLO,SLOEPS,
     1XHORIZ,AUPPER,ALOWER,NHORP,IPHORI,ICHORI,
     1ISTART,ICASHO,ICASIN,
     1XMIN,XMAX,
     1XTEMP2,YTEMP2,ITHORI,
     1IBUGU2,ISUBRO,IERROR)
      NTRACE=NTRACE+1
      NOUT=NOUT+1
      XOUT(NOUT)=XTEMP2
      YOUT(NOUT)=YTEMP2
      TAGOUT(NOUT)=NTRACE
      NOUT=NOUT+1
      XOUT(NOUT)=XC
      YOUT(NOUT)=YC
      TAGOUT(NOUT)=NTRACE
      ALOWER(ICHORI)=YC
      ICASEF='LOWE'
      CALL FILLHT(ITHORI,ICHORI,AUPPER,ALOWER,XHORIZ,NHORP,ICASEF,
     1IBUGU2,ISUBRO,IERROR)
      GOTO9000
C
C               **************************************************
C               **  STEP 74--                                   **
C               **  FOR NON-ADJ. CELL & FINITE SLOPE   CASE,    **
C               **  TREAT THE INVISIBLE/INVISIBLE SUBCASE.      **
C               **************************************************
C
 7400 CONTINUE
      ISTEPN='7400'
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
      GOTO9000
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
 9000 CONTINUE
      IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'DETR')GOTO9010
      GOTO9090
 9010 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDETR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGU2,ISUBRO,IERROR
 9012 FORMAT('IBUGU2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IP,IC,NS
 9013 FORMAT('IP,IC,NS = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO9015I=IP,IC
      WRITE(ICOUT,9016)I,XS(I),YS(I),IVIS(I)
 9016 FORMAT('I,XS(I),YS(I),IVIS(I) = ',I8,2E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9015 CONTINUE
      WRITE(ICOUT,9021)IPHORI,ICHORI,NHORP
 9021 FORMAT('IPHORI,ICHORI,NHORP = ',3I8)
      CALL DPWRST('XXX','BUG ')
      DO9025I=IPHORI,ICHORI
      WRITE(ICOUT,9026)I,AUPPER(I),ALOWER(I),XHORIZ(I)
 9026 FORMAT('I,AUPPER(I),ALOWER(I),XHORIZ(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      WRITE(ICOUT,9031)XMIN,XMAX
 9031 FORMAT('XMIN,XMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IPASS
 9032 FORMAT('IPASS = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)NOUT,NTRACE
 9041 FORMAT('NOUT,NTRACE = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO9045I=1,NOUT
      WRITE(ICOUT,9046)I,XOUT(I),YOUT(I),TAGOUT(I)
 9046 FORMAT('I,XOUT(I),YOUT(I),TAGOUT(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 9045 CONTINUE
CCCCC WRITE(ICOUT,9051)I2
C9051 FORMAT('I2 (TOO FAR) = ',I8)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9052)XTEMPO,YTEMPO,YCUTOL
 9052 FORMAT('XTEMPO,YTEMPO,YCUTOL = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9053)XTEMP,YTEMP,YCUT
 9053 FORMAT('XTEMP,YTEMP,YCUT = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9055)XTEMP2,YTEMP2
 9055 FORMAT('XTEMP2,YTEMP2 = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEUN(IHARG,IHARG2,IARGT,IARG,NUMARG,
     1IDEFUN,
     1NUMDEV,MAXDEV,
     1IDMANU,IDMODE,IDMOD2,IDMOD3,
     1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1IBUGO2,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE LOGICAL I/O UNIT NUMBER
C              FOR AN OUTPUT DEVICE.
C              THE LOGICAL I/O UNIT NUMBER
C              FOR DEVICE I WILL BE PLACED
C              IN THE I-TH ELEMENT OF THE INTEGER
C              VECTOR IDUNIT(.).
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                     --IDEFUN
C                     --MAXDEV
C     OUTPUT ARGUMENTS--IDUNIT (AN INTEGER VECTOR
C                              WHOSE I-TH ELEMENT CONTAINS THE
C                              LOGICAL I/O UNIT NUMBER
C                              FOR DEVICE I.
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1980.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHARG
      CHARACTER*4 IHARG2
      CHARACTER*4 IARGT
C
      CHARACTER*4 IDMANU
      CHARACTER*4 IDMODE
      CHARACTER*4 IDMOD2
      CHARACTER*4 IDMOD3
C
      CHARACTER*4 IDPOWE
      CHARACTER*4 IDCONT
      CHARACTER*4 IDCOLO
C
      CHARACTER*4 IBUGO2
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION IHARG(*)
      DIMENSION IHARG2(*)
      DIMENSION IARGT(*)
      DIMENSION IARG(*)
C
      DIMENSION IDMANU(*)
      DIMENSION IDMODE(*)
      DIMENSION IDMOD2(*)
      DIMENSION IDMOD3(*)
C
      DIMENSION IDPOWE(*)
      DIMENSION IDCONT(*)
      DIMENSION IDCOLO(*)
      DIMENSION IDNVPP(*)
      DIMENSION IDNHPP(*)
      DIMENSION IDUNIT(*)
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)GOTO1199
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'UNIT')GOTO1110
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NUMB')GOTO1110
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'UNIT')GOTO1140
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'NUMB')GOTO1140
      GOTO1199
C
 1110 CONTINUE
      IF(NUMARG.LE.1)GOTO1120
      IF(IHARG(2).EQ.'ON')GOTO1120
      IF(IHARG(2).EQ.'OFF')GOTO1120
      IF(IHARG(2).EQ.'AUTO')GOTO1120
      IF(IHARG(2).EQ.'DEFA')GOTO1120
      GOTO1125
C
 1120 CONTINUE
      IHOLD=IDEFUN
      GOTO1130
C
 1125 CONTINUE
      IHOLD=IARG(2)
      GOTO1130
C
 1130 CONTINUE
      IFOUND='YES'
      DO1135I=1,NUMDEV
      IDUNIT(I)=IHOLD
      IDPOWE(I)='OFF'
 1135 CONTINUE
C
      IF(IFEEDB.EQ.'OFF')GOTO1139
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1136)
 1136 FORMAT('THE UNIT NUMBER FOR ALL DEVICES ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1137)IHOLD
 1137 FORMAT('HAS JUST BEEN SET TO',I8)
      CALL DPWRST('XXX','BUG ')
 1139 CONTINUE
      GOTO1199
C
 1140 CONTINUE
      IF(IARGT(1).EQ.'NUMB')GOTO1150
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1141)
 1141 FORMAT('***** ERROR IN DPDEUN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1142)
 1142 FORMAT('      IN THE DEVICE ... UNIT NUMBER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1143)
 1143 FORMAT('      THE DEVICE IS IDENTIFIED BY A NUMBER, AS IN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1144)
 1144 FORMAT('      DEVICE 3 UNIT NUMBER 25 ')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1150 CONTINUE
      I=IARG(1)
      IF(1.LE.I.AND.I.LE.MAXDEV)GOTO1160
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN DPDEUN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      IN THE DEVICE ... UNIT NUMBER COMMAND,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      THE NUMBER OF DEVICES MUST BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)MAXDEV
 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)I
 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
     1'DEVICE.')
      CALL DPWRST('XXX','BUG ')
      GOTO1199
C
 1160 CONTINUE
      IF(NUMARG.LE.2)GOTO1170
      IF(IHARG(3).EQ.'ON')GOTO1170
      IF(IHARG(3).EQ.'OFF')GOTO1170
      IF(IHARG(3).EQ.'AUTO')GOTO1170
      IF(IHARG(3).EQ.'DEFA')GOTO1170
      GOTO1175
C
 1170 CONTINUE
      IHOLD=IDEFUN
      GOTO1180
C
 1175 CONTINUE
      IHOLD=IARG(3)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      IDUNIT(I)=IHOLD
      IDPOWE(I)='OFF'
C
      IF(IFEEDB.EQ.'OFF')GOTO1199
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)I
 1181 FORMAT('            DEVICE           --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)IDUNIT(I)
 1182 FORMAT('            I/O UNIT         --',I4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)IDMANU(I)
 1183 FORMAT('            MANUFACTURER     --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1184)IDMODE(I),IDMOD2(I),IDMOD3(I)
 1184 FORMAT('            MODEL            --',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1185)IDPOWE(I)
 1185 FORMAT('            POWER            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1186)IDCONT(I)
 1186 FORMAT('            CONTINUITY       --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1187)IDCOLO(I)
 1187 FORMAT('            COLOR            --',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1188)IDNHPP(I)
 1188 FORMAT('            HORIZONTAL PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1189)IDNVPP(I)
 1189 FORMAT('            VERTICAL   PIXELS--',I8)
      CALL DPWRST('XXX','BUG ')
 1199 CONTINUE
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEV(ID,IOP,ICOMP,ICAPSW,IBUGXX,ISUBRO,IERROR)
C
C     PURPOSE--DEFINE, OPEN, OR CLOSE 1, 2, OR 3 (DEPENDING ON SETTING
C              IN IOP)
C     INPUT ARGUMENTS--ID     = INTEGER NUMBER OF DEVICE:
C                               1, 2, 3, ..., 10
C                      IOP    = CHARACTER*4 FOR DESIRED OPERATION:
C                               DEFI(NE), OPEN, OR CLOS(E)
C                      ICOMP  = CHARACTER*4 FOR COMPANY
C                               TEKT, POST, HPGL, GENE, ...
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92.6
C     ORIGINAL VERSION--MAY       1992.
C     UPDATED         --SEPTEMBER 2002. ICAPSW
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      INCLUDE 'DPCOPA.INC'
C
      CHARACTER*4 IOP
      CHARACTER*4 ICOMP
      CHARACTER*4 ICAPSW
      CHARACTER*4 IBUGXX
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IFOUND
C
      CHARACTER*1 ICJUNK
C
      CHARACTER*4 ICM
      CHARACTER*4 ICM2
      CHARACTER*4 IHRG
      CHARACTER*4 IHRG2
      CHARACTER*4 IRGT
C
      DIMENSION IHRG(MAXSTR)
      DIMENSION IHRG2(MAXSTR)
      DIMENSION IRGT(MAXSTR)
      DIMENSION IRG(MAXSTR)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOPC.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
      IF(IBUGXX.EQ.'OFF'.AND.ISUBRO.NE.'DEV')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ID,IOP,ICOMP
   52 FORMAT('ID,IOP,ICOMP = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IBUGXX,ISUBRO
   53 FORMAT('IBUGXX,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,60)IERROR
   60 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)IPL1CS,IPL2CS
   61 FORMAT('IPL1CS,IPL2CS = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
 1000 CONTINUE
      ICM='DEVI'
      ICM2='CE  '
C
      IF(ID.EQ.1)IHRG(1)='1   '
      IF(ID.EQ.2)IHRG(1)='2   '
      IF(ID.EQ.3)IHRG(1)='3   '
      IF(ID.EQ.4)IHRG(1)='4   '
      IF(ID.EQ.5)IHRG(1)='5   '
      IF(ID.EQ.6)IHRG(1)='6   '
      IF(ID.EQ.7)IHRG(1)='7   '
      IF(ID.EQ.8)IHRG(1)='8   '
      IF(ID.EQ.9)IHRG(1)='9   '
      IF(ID.EQ.10)IHRG(1)='10  '
      IHRG2(1)='    '
      IRGT(1)='NUMB'
      IRG(1)=ID
C
      IF(IOP.EQ.'DEFI')THEN
         IHRG(2)=ICOMP
         IHRG2(2)='    '
         IRGT(2)='WORD'
         IRG(2)=(-99)
         NUMRG=2
         CALL DPDEMN(IHRG,IHRG2,IRGT,IRG,NUMRG,
     1   IPL1NU,IPL1NA,
     1   IPL2NU,IPL2NA,
CCCCC AUGUST 1992.  ADD FOLLOWING LINE
     1   IPL1CS,IPL2CS,
     1   IDEFMA,IDEFMO,IDEFM2,IDEFM3,
     1   IDEFPO,IDEFCN,IDEFDC,IDEFVP,IDEFHP,IDEFUN,
     1   NUMDEV,MAXDEV,
     1   IDMANU,IDMODE,IDMOD2,IDMOD3,
     1   IDPOWE,IDCONT,IDCOLO,IDFONT,IDNVPP,IDNHPP,IDUNIT,
     1   IDNVOF,IDNHOF,
     1   ICAPSW,ICAPNU,
     1   IANS,IWIDTH,IBUGXX,ISUBRO,IFOUND,IERROR)
      ENDIF
C
      IF(IOP.EQ.'OPEN'.OR.IOP.EQ.'CLOS')THEN
         IHRG(2)='POWE'
         IHRG2(2)='R   '
         IRGT(2)='WORD'
         IRG(2)=(-99)
         IHRG(3)=IOP
         IHRG2(3)='    '
         IRGT(3)='WORD'
         IRG(3)=(-99)
         NUMRG=3
         CALL DPDEPW(IHRG,IHRG2,IRGT,IRG,NUMRG,
     1   IPL1NU,IPL1NA,
     1   IPL2NU,IPL2NA,
     1   IDEFPO,
     1   NUMDEV,MAXDEV,
     1   IDMANU,IDMODE,IDMOD2,IDMOD3,
     1   IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1   IDNVOF,IDNHOF,
     1   ICAPSW,ICAPNU,
     1   IANS,IWIDTH,IBUGXX,ISUBRO,IFOUND,IERROR)
      ENDIF
C
      IF(IERROR.EQ.'YES')THEN
         WRITE(ICOUT,1011)
 1011    FORMAT('***** ERROR IN DPDEV--')
      CALL DPWRST('XXX','BUG ')
         IF(IOP.EQ.'DEFI')WRITE(ICOUT,1012)ID
 1012    FORMAT('      COULD NOT DEFINE DEVICE ',I8)
         IF(IOP.EQ.'DEFI')CALL DPWRST('XXX','BUG ')
         IF(IOP.EQ.'OPEN')WRITE(ICOUT,1013)ID
 1013    FORMAT('      COULD NOT OPEN DEVICE ',I8)
         IF(IOP.EQ.'OPEN')CALL DPWRST('XXX','BUG ')
         IF(IOP.EQ.'CLOS')WRITE(ICOUT,1014)ID
 1014    FORMAT('      COULD NOT CLOSE DEVICE ',I8)
         IF(IOP.EQ.'CLOS')CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,1015)
 1015    FORMAT('HIT ENTER/CARRIAGE-RETURN TO CONTINUE...')
      CALL DPWRST('XXX','BUG ')
         READ(IRD,1016)ICJUNK
 1016    FORMAT(A1)
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGXX.EQ.'OFF'.AND.ISUBRO.NE.'DEV')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEV--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ID,IOP,ICOMP
 9012 FORMAT('ID,IOP,ICOMP = ',I8,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IBUGXX,ISUBRO
 9013 FORMAT('IBUGXX,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9020)IERROR
 9020 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)IFOUND
 9021 FORMAT('IFOUND (BUT NOT AN OUTPUT RGUMENT) = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9022)IPL1CS,IPL2CS
 9022 FORMAT('IPL1CS,IPL2CS = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9027)ICM,ICM2
 9027 FORMAT('ICM,ICM2 = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9028)NUMRG
 9028 FORMAT('NUMRG = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9030I=1,NUMRG
      WRITE(ICOUT,9031)I,IHRG(I),IHRG2(I),IRGT(I),IRG(I)
 9031 FORMAT('I,IHRG(I),IHRG2(I),IRGT(I),IRG(I) = ',
     1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEWI(IHARG,ARG,NUMARG,DEFDEW,
     1DEXWID,IFOUND,IERROR)
C
C     PURPOSE--DEFINE THE DESIGN OF EXPERIMENT PLOT WIDTH
C              OF THE LEVELS WITHIN A FACTOR.
C                     --IHARG  (A  HOLLERITH VECTOR)
C     INPUT  ARGUMENTS--IHARG (A HOLLARITH VECTOR)
C                     --ARG    (A REAL VECTOR)
C                     --NUMARG
C                     --DEFDEW
C     OUTPUT ARGUMENTS--DEXWID (A REAL VARIABLE
C                       DENOTING THE PLOT WIDTH OF THE LEVELS
C                     --IFOUND ('YES' OR 'NO' )
C                     --IERROR ('YES' OR 'NO' )
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/5
C     ORIGINAL VERSION--MAY       1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
CCCCC CHARACTER*4 ICOM
      CHARACTER*4 IHARG
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
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
 1100 CONTINUE
      IF(NUMARG.EQ.1)GOTO1150
      IF(IHARG(2).EQ.'ON')GOTO1150
      IF(IHARG(2).EQ.'OFF')GOTO1150
      IF(IHARG(2).EQ.'AUTO')GOTO1150
      IF(IHARG(2).EQ.'DEFA')GOTO1150
      GOTO1160
C
 1150 CONTINUE
      HOLD=DEFDEW
      GOTO1180
C
 1160 CONTINUE
      HOLD=ARG(NUMARG)
      GOTO1180
C
 1180 CONTINUE
      IFOUND='YES'
      DEXWID=HOLD
C
      IF(IFEEDB.EQ.'OFF')GOTO1189
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('THE DESIGN OF EXPERIMENT WIDTH (WITHIN A FACTOR)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)HOLD
 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7)
      CALL DPWRST('XXX','BUG ')
 1189 CONTINUE
      GOTO1900
C
 1199 CONTINUE
C
 1900 CONTINUE
      RETURN
      END
      SUBROUTINE DPDEXP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
     1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
     1ISEED,
     1ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
C
C     PURPOSE--GENERATE ONE OF THE FOLLOWING DESIGN OF EXPERIMENT
C              STATISTIC PLOTS--
C                 DEX SCATTER PLOT (NOT A STATISTIC)
C                 DEX SIGN PLOT (NOT A STATISTIC)
C                 DEX MEAN XXX YYY  PLOT
C                 DEX MIDM XXX YYY  PLOT
C                 DEX MEDI XXX YYY  PLOT
C                 DEX SD XXX YYY  PLOT
C                 DEX MAD XXX YYY  PLOT
C                 DEX AAD XXX YYY  PLOT
C                 DEX VARI XXX YYY  PLOT
C                 DEX RSD XXX YYY  PLOT
C                 DEX RANG XXX YYY  PLOT
C                 DEX MINI XXX YYY  PLOT
C                 DEX MAXI XXX YYY  PLOT
C                 DEX SKEW XXX YYY  PLOT
C                 DEX KURT XXX YYY  PLOT
C                 DEX AUCR XXX YYY PLOT
C                 DEX SDM XXX YYY  PLOT
C                 DEX AUCV XXX YYY PLOT
C                 DEX LOWH XXX YYY  PLOT
C                 DEX UPPH XXX YYY  PLOT
C                 DEX LOWQ XXX YYY  PLOT
C                 DEX UPPQ XXX YYY  PLOT
C                 DEX TRIM XXX YYY  PLOT
C                 DEX WINM XXX YYY  PLOT
C                 DEX MIDQ XXX YYY  PLOT
C                 DEX 1DEC  XXX YYY PLOT
C                 DEX 2DEC  XXX YYY PLOT
C                 DEX 3DEC  XXX YYY PLOT
C                 DEX 4DEC  XXX YYY PLOT
C                 DEX 5DEC XXX YYY PLOT
C                 DEX 6DEC XXX YYY PLOT
C                 DEX 7DEC XXX YYY PLOT
C                 DEX 8DEC XXX YYY PLOT
C                 DEX 9DEC XXX YYY PLOT
C                 DEX SINE FREQUENCY XXX YYY PLOT
C                 DEX SINE AMPLITUDE XXX YYY PLOT
C                 DEX LINEAR INTERCEPT XXX YYY PLOT
C                 DEX LINEAR SLOPE XXX YYY PLOT
C                 DEX LINEAR RESSD XXX YYY PLOT
C                 DEX LINEAR CORRELATION XXX YYY PLOT
C                 DEX TAGUCHI SIGNAL-TO-NOISE XXX YYY PLOTS
C                 DEX 2-LEVEL ... PLOT
C                 DEX 3-LEVEL ... PLOT
C                 DEX PROPORTION XXX YYY PLOT
C                 DEX PROPORTION XXX YYY PLOT
C                 DEX CP XXX YYY PLOT
C                 DEX CPK XXX YYY PLOT
C                 DEX CNPK XXX YYY PLOT
C                 DEX CPM XXX YYY PLOT
C                 DEX CC XXX YYY PLOT
C                 DEX PERCENT DEFECTIVE XXX YYY PLOT
C                 DEX EXPECTED LOSS XXX YYY PLOT
C                 DEX BIWEIGHT LOCATION XXX YYY  PLOT
C                 DEX BIWEIGHT SCALE XXX YYY  PLOT
C                 DEX INTERQUARTILE RANGE XXX YYY  PLOT
C                 DEX HARMONIC MEAN XXX YYY  PLOT
C                 DEX GEOMETRIC MEAN XXX YYY  PLOT
C                 DEX GEOMETRIC SD XXX YYY  PLOT
C                 DEX WINSORIZED VARIANCE XXX YYY  PLOT
C                 DEX WINSORIZED SD XXX YYY  PLOT
C                 DEX CORRELATION XXX YYY PLOT
C                 DEX COVARIANCE XXX YYY PLOT
C                 DEX RANK CORRELATION XXX YYY PLOT
C                 DEX RANK COVARIANCE XXX YYY PLOT
C                 DEX KENDELLS TAU XXX YYY PLOT
C                 DEX WINSORIZED COVARIANCE XXX YYY  PLOT
C                 DEX WINSORIZED CORRELATION XXX YYY  PLOT
C                 DEX BIWEIGHT MIDVARIANCE XXX YYY  PLOT
C                 DEX BIWEIGHT MIDCOVARIANCE XXX YYY  PLOT
C                 DEX BIWEIGHT MIDCORRELATION XXX YYY  PLOT
C                 DEX PERCENTAGE BEND MIDVARIANCE XXX YYY  PLOT
C                 DEX HODGES LEHMAN XXX YYY  PLOT
C                 DEX QUANTILE XXX YYY  PLOT
C                 DEX QUANTILE STANDARD ERROR XXX YYY  PLOT
C                 DEX TRIMMED MEAN STANDARD ERROR XXX YYY  PLOT
C                 DEX SN XXX YYY  PLOT
C                 DEX QN XXX YYY  PLOT
C         WHERE XXX MAY BE
C                   (OMITTED)
C                   EFFECTS
C                   ABSOLUTE EFFECTS
C         AND WHERE YYY MAY BE
C                   (OMITTED)
C                   PARETO
C                   YOUDEN
C                 DEX ... PARETO PLOT
C                 DEX ... YOUDEN PLOT (2**K DESIGNS ONLY)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/6
C     ORIGINAL VERSION--MAY       1989.
C     UPDATED         --JANUARY   1990.  INITE & ININTE TO NXINTE
C     UPDATED         --JANUARY   1990.  MAX VECTOR SIZE TO 10*MAXOBV
C     UPDATED         --JANUARY   1990.  CHECK FOR OVERFLOWING VECTORS
C     UPDATED         --JUNE      1990.  TEMPORARY ARRAYS TO GARBAGE COMMON
C                                        MOVE DIMENSION OF STAT FROM DPDEX2
C     UPDATED         --JUNE      1990.  CORRECT 205 COMPILE ERROR
C     UPDATED         --APRIL     1992.   COMMENT OUT NX
C     UPDATED         --MARCH     1995.  ADD MAD AND AAD STATISTICS
C     UPDATED         --NOVEMBER  1998.  ADD PERCENTILE STATISTICS
C     UPDATED         --NOVEMBER  1998.  ADD CPM AND CC STATISTIC
C     UPDATED         --MARCH     1999.  ADD CNPK STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD BIWEIGHT LOCATION STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD BIWEIGHT SCALE STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD IQ RANGE STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD HARMONIC MEAN STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD GEOMETRIC MEAN STATISTIC
C     UPDATED         --NOVEMBER  2001.  ADD GEOMETRIC SD STATISTIC
C     UPDATED         --JULY      2002.  ADD WINSORIZED VARIANCE STATISTIC
C     UPDATED         --JULY      2002.  ADD WINSORIZED SD STATISTIC
C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION PLOT
C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
C                                           PLOT
C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD ERROR
C                                       PLOT
C     UPDATED         --APRIL     2003. ADD SN AND QN (REQUIRES
C                                       ADDITIONAL SCRATCH ARRAYS)
C     UPDATED         --OCTOBER   2004. ADD KEDNELLS TAU
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IAND1
      CHARACTER*4 IAND2
      CHARACTER*4 ICONT
      CHARACTER*4 IDEXPA
      CHARACTER*4 IDEXYO
      CHARACTER*4 IDEXEF
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGG2
      CHARACTER*4 IBUGG3
      CHARACTER*4 IBUGQ
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
CCCCC CHARACTER*4 IHP
CCCCC CHARACTER*4 IHP2
      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 IHRIGH
      CHARACTER*4 IHRIG2
      CHARACTER*4 IHX
      CHARACTER*4 IHX2
      CHARACTER*4 IHXINT
      CHARACTER*4 IHXIN2
C
      CHARACTER*4 IVARN1
      CHARACTER*4 IVARN2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 ICASP3
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION TEMP3(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
C
      DIMENSION IVARN1(MAXCMF)
      DIMENSION IVARN2(MAXCMF)
      DIMENSION ICOLFA(MAXCMF)
      DIMENSION INFACT(MAXCMF)
C
CCCCC THE FOLLOWING 4 DIMENSIONS WERE FIXED JANUARY 1990
CCCCC DIMENSION Y1(MAXOBV)
CCCCC DIMENSION XINT1(MAXOBV)
CCCCC DIMENSION X1(MAXOBV)
CCCCC DIMENSION TAG1(MAXOBV)
      DIMENSION Y1(10*MAXOBV)
      DIMENSION XINT1(10*MAXOBV)
      DIMENSION X1(10*MAXOBV)
      DIMENSION TAG1(10*MAXOBV)
CCCCC FOLLOWING LINES ADDED JUNE, 1990
      INCLUDE 'DPCOZZ.INC'
      INCLUDE 'DPCOZ2.INC'
      DIMENSION STAT(MAXOBV)
      DIMENSION XTEMP3(MAXOBV)
      EQUIVALENCE (GARBAG(IGARB1),X1(1))
      EQUIVALENCE (G2RBAG(IGAR11),Y1(1))
      EQUIVALENCE (G2RBAG(IGAR21),XINT1(1))
      EQUIVALENCE (G2RBAG(IGAR31),TAG1(1))
      EQUIVALENCE (G2RBAG(IGAR41),STAT)
      EQUIVALENCE (G2RBAG(IGAR42),XTEMP3)
CCCCC END CHANGE
C
CCCCC JULY 2002. ADD INTEGER ARRAYS FOR HODGES-LEHMAN PLOT.
      INCLUDE 'DPCOZI.INC'
C
      INTEGER ITEMP1(MAXOBV)
      INTEGER ITEMP2(MAXOBV)
      INTEGER ITEMP3(MAXOBV)
      INTEGER ITEMP4(MAXOBV)
      INTEGER ITEMP5(MAXOBV)
      INTEGER ITEMP6(MAXOBV)
      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCODE.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'
      ICASPL='-999'
C
      ISUBN1='DPDE'
      ISUBN2='XP  '
C
CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1990
      MAX10=10*MAXOBV
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      MAXV2=2
      MINN2=2
C
      ICOLL=0
      ICOLX=0
      ICOLXI=0
C
      NUMVAR=0
      NUMCOM=0
      NUMFAC=0
C
      IDEXPA='NONP'
      IDEXYO='NONY'
      IDEXEF='STAT'
C
CCCCC IDEXHA='FACT'
CCCCC IDEXDE=1
CCCCC DEXWID=0.4
C
C               *********************************************
C               **  TREAT THE DEX ... STATISTIC PLOT CASE  **
C               *********************************************
C
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DEXP')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGG2,IBUGG3,IBUGQ
   52 FORMAT('ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
     1A4,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 ')
      WRITE(ICOUT,54)DEXWID,IDEXDE,IDEXHA
   54 FORMAT('DEXWID,IDEXDE,IDEXHA = ',E15.7,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)IDEXPA,IDEXYO,IDEXEF
   55 FORMAT('IDEXPA,IDEXYO,IDEXEF = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***************************
C               **  STEP 11--            **
C               **  EXTRACT THE COMMAND  **
C               ***************************
C
      ISTEPN='11'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *********************************
C               **  STEP 12--                  **
C               **  DETERMINE IF OF THIS TYPE  **
C               **  AND BRANCH ACCORDINGLY.    **
C               *********************************
C
      ISTEPN='12'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMARG.LE.1)GOTO9000
C
      IF(IHARG(1).EQ.'SCAT'.AND.IHARG2(1).EQ.'TER ')GOTO200
      IF(IHARG(1).EQ.'SCAT'.AND.IHARG2(1).EQ.'    ')GOTO200
C
      IF(IHARG(1).EQ.'SIGN'.AND.IHARG2(1).EQ.'    ')GOTO201
C
      IF(IHARG(1).EQ.'NUMB'.AND.IHARG2(1).EQ.'ER  ')GOTO202
      IF(IHARG(1).EQ.'COUN'.AND.IHARG2(1).EQ.'T   ')GOTO202
      IF(IHARG(1).EQ.'COUN'.AND.IHARG2(1).EQ.'TS  ')GOTO202
      IF(IHARG(1).EQ.'SIZE'.AND.IHARG2(1).EQ.'    ')GOTO202
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SAMP'.AND.IHARG(2).EQ.'SIZE')GOTO203
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SUBS'.AND.IHARG(2).EQ.'SIZE')GOTO203
C
      IF(IHARG(1).EQ.'SUM '.AND.IHARG2(1).EQ.'    ')GOTO211
      IF(IHARG(1).EQ.'PROD'.AND.IHARG2(1).EQ.'UCT ')GOTO212
      IF(IHARG(1).EQ.'INTE'.AND.IHARG2(1).EQ.'GRAL')GOTO213
C
      IF(IHARG(1).EQ.'MIDR'.AND.IHARG2(1).EQ.'ANGE')GOTO221
      IF(IHARG(1).EQ.'MEAN'.AND.IHARG2(1).EQ.'    ')GOTO222
CCCCC ADD FOLLIING SECTION MARCH 1995.
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'AVER'.AND.IHARG(2).EQ.'ABSO'.AND.
     1IHARG(3).EQ.'DEVI')GOTO416
      IF(IHARG(1).EQ.'AAD ')GOTO417
C
      IF(IHARG(1).EQ.'AVER'.AND.IHARG2(1).EQ.'AGE ')GOTO222
      IF(IHARG(1).EQ.'MIDM'.AND.IHARG2(1).EQ.'EAN ')GOTO223
CCCCC ADD FOLLIING SECTION MARCH 1995.
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'MEDI'.AND.IHARG(2).EQ.'ABSO'.AND.
     1IHARG(3).EQ.'DEVI')GOTO418
      IF(IHARG(1).EQ.'MAD ')GOTO419
C
      IF(IHARG(1).EQ.'MEDI'.AND.IHARG2(1).EQ.'AN  ')GOTO224
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'TRIM'.AND.IHARG(2).EQ.'MEAN'.AND.
     1(IHARG(3).NE.'STAN'.AND.IHARG(4).NE.'ERRO'))GOTO225
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'WIND'.AND.IHARG(2).EQ.'MEAN')GOTO226
C
      IF(IHARG(1).EQ.'R   '.AND.IHARG2(1).EQ.'    ')GOTO241
      IF(IHARG(1).EQ.'RANG'.AND.IHARG2(1).EQ.'E   ')GOTO241
      IF(IHARG(1).EQ.'MINI'.AND.IHARG2(1).EQ.'MUM ')GOTO242
      IF(IHARG(1).EQ.'MIN '.AND.IHARG2(1).EQ.'    ')GOTO242
      IF(IHARG(1).EQ.'MAXI'.AND.IHARG2(1).EQ.'MUM ')GOTO243
      IF(IHARG(1).EQ.'MAX '.AND.IHARG2(1).EQ.'    ')GOTO243
C
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'OF  '.AND.
     1IHARG(3).EQ.'THE '.AND.IHARG(4).EQ.'MEAN')GOTO251
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'OF  '.AND.
     1IHARG(3).EQ.'MEAN')GOTO252
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'VARI'.AND.IHARG(2).EQ.'MEAN')GOTO253
      IF(IHARG(1).EQ.'VARI'.AND.IHARG2(1).EQ.'ANCE')GOTO254
C
      IF(NUMARG.GE.4.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI'.AND.
     1IHARG(3).EQ.'OF  '.AND.IHARG(4).EQ.'THE '.AND.
     1IHARG(5).EQ.'MEAN')GOTO261
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI'.AND.
     1IHARG(3).EQ.'OF  '.AND.IHARG(4).EQ.'MEAN')GOTO262
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI'.AND.
     1IHARG(3).EQ.'MEAN')GOTO263
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'DEVI')GOTO264
      IF(IHARG(1).EQ.'SD  '.AND.IHARG2(1).EQ.'    ')GOTO265
      IF(IHARG(1).EQ.'S   '.AND.IHARG2(1).EQ.'    ')GOTO265
C
      IF(IHARG(1).EQ.'RS  '.AND.IHARG2(1).EQ.'    ')GOTO271
      IF(IHARG(1).EQ.'RSD '.AND.IHARG2(1).EQ.'    ')GOTO271
      IF(IHARG(1).EQ.'RELS'.AND.IHARG2(1).EQ.'    ')GOTO271
      IF(IHARG(1).EQ.'RELS'.AND.IHARG2(1).EQ.'D   ')GOTO271
      IF(IHARG(1).EQ.'RV  '.AND.IHARG2(1).EQ.'    ')GOTO272
      IF(IHARG(1).EQ.'RVAR'.AND.IHARG2(1).EQ.'    ')GOTO272
      IF(IHARG(1).EQ.'RELV'.AND.IHARG2(1).EQ.'    ')GOTO272
      IF(IHARG(1).EQ.'RELV'.AND.IHARG2(1).EQ.'AR  ')GOTO272
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'COEF'.AND.IHARG(2).EQ.'OF  '.AND.
     1IHARG(3).EQ.'VARI')GOTO273
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'COEF'.AND.IHARG(2).EQ.'VARI')GOTO274
C
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LOWE'.AND.IHARG(2).EQ.'QUAR')GOTO301
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIRS'.AND.IHARG(2).EQ.'QUAR')GOTO301
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SECO'.AND.IHARG(2).EQ.'QUAR')GOTO302
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'UPPE'.AND.IHARG(2).EQ.'QUAR')GOTO303
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'THIR'.AND.IHARG(2).EQ.'QUAR')GOTO303
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LOWE'.AND.IHARG(2).EQ.'HING')GOTO304
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'UPPE'.AND.IHARG(2).EQ.'HING')GOTO305
C
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'THIR'.AND.
     1IHARG(3).EQ.'CENT'.AND.IHARG(4).EQ.'MOME')GOTO311
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'3RD '.AND.
     1IHARG(3).EQ.'CENT'.AND.IHARG(4).EQ.'MOME')GOTO311
      IF(IHARG(1).EQ.'SKEW'.AND.IHARG2(1).EQ.'NESS')GOTO312
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'FOUR'.AND.
     1IHARG(3).EQ.'CENT'.AND.IHARG(4).EQ.'MOME')GOTO313
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'STAN'.AND.IHARG(2).EQ.'4TH '.AND.
     1IHARG(3).EQ.'CENT'.AND.IHARG(4).EQ.'MOME')GOTO313
      IF(IHARG(1).EQ.'KURT'.AND.IHARG2(1).EQ.'OSIS')GOTO314
C
CCCCC IF(IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'COVA')GOTO321
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'COVA'.AND.
     1IHARG(2).EQ.'STAT'.AND.IHARG(3).EQ.'PLOT')GOTO321
CCCCC IF(IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'CORR')GOTO322
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'AUTO'.AND.IHARG2(1).EQ.'CORR'.AND.
     1IHARG(2).EQ.'STAT'.AND.IHARG(3).EQ.'PLOT')GOTO322
C
      IF(IHARG(1).EQ.'COVA'.AND.IHARG2(1).EQ.'RIAN')GOTO331
      IF(IHARG(1).EQ.'CORR'.AND.IHARG2(1).EQ.'ELAT')GOTO332
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'RANK'.AND.IHARG(2).EQ.'COVA')GOTO333
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'RANK'.AND.IHARG(2).EQ.'CORR')GOTO334
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'KEND'.AND.IHARG(2).EQ.'TAU ')GOTO337
C
      IF(NUMARG.GE.1.AND.IHARG(2).EQ.'DECI')GOTO111
      GOTO119
  111 CONTINUE
      IF(IHARG(1).EQ.'FIRS')GOTO341
      IF(IHARG(1).EQ.'SECO')GOTO342
      IF(IHARG(1).EQ.'THIR')GOTO343
      IF(IHARG(1).EQ.'FOUR')GOTO344
      IF(IHARG(1).EQ.'FIFT')GOTO345
      IF(IHARG(1).EQ.'SIXT')GOTO346
      IF(IHARG(1).EQ.'SEVE')GOTO347
      IF(IHARG(1).EQ.'EIGH')GOTO348
      IF(IHARG(1).EQ.'NINT')GOTO349
  119 CONTINUE
C
      IF(IHARG(1).EQ.'PERC'.AND.IHARG(2).NE.'BEND'.AND.
     1   IHARG(2).NE.'DEFE')GOTO350
C
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SIN'.AND.IHARG(2).EQ.'FREQ')GOTO361
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SINE'.AND.IHARG(2).EQ.'FREQ')GOTO361
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SIN'.AND.IHARG(2).EQ.'AMP')GOTO362
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SINE'.AND.IHARG(2).EQ.'AMP')GOTO362
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SIN'.AND.IHARG(2).EQ.'AMPL')GOTO362
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'SINE'.AND.IHARG(2).EQ.'AMPL')GOTO362
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LINE'.AND.IHARG(2).EQ.'INTE')GOTO363
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LINE'.AND.IHARG(2).EQ.'SLOP')GOTO364
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LINE'.AND.IHARG(2).EQ.'RESS')GOTO365
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'LINE'.AND.IHARG(2).EQ.'CORR')GOTO366
C
      IF(IHARG(1).EQ.'SN'.AND.IHARG(2).EQ.'SCAL')GOTO446
      IF(IHARG(1).EQ.'QN'.AND.IHARG(2).EQ.'SCAL')GOTO447
CCCCC THE FOLLOWING SECTION WAS DRASTICALLY SIMPLIFIED MAY 1989
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TAGU')GOTO130
      GOTO139
  130 CONTINUE
      IF(IHARG(2).EQ.'SN')GOTO371
      IF(IHARG(2).EQ.'S/N')GOTO371
      IF(IHARG(2).EQ.'SN0')GOTO371
      IF(IHARG(2).EQ.'S/N0')GOTO371
      IF(IHARG(2).EQ.'SNT')GOTO371
      IF(IHARG(2).EQ.'S/NT')GOTO371
      IF(IHARG(2).EQ.'SN+')GOTO372
      IF(IHARG(2).EQ.'S/N+')GOTO372
      IF(IHARG(2).EQ.'SN-')GOTO373
      IF(IHARG(2).EQ.'S/N-')GOTO373
      IF(IHARG(2).EQ.'SN00')GOTO374
      IF(IHARG(2).EQ.'SNT2')GOTO374
      IF(IHARG(2).EQ.'S/N2')GOTO374
  139 CONTINUE
C
CCCCC THE FOLLOWING 12 LINES WERE ADDED MAY 1989
      IF(IHARG(1).EQ.'SN')GOTO381
      IF(IHARG(1).EQ.'S/N')GOTO381
      IF(IHARG(1).EQ.'SN0')GOTO381
      IF(IHARG(1).EQ.'S/N0')GOTO381
      IF(IHARG(1).EQ.'SNT')GOTO381
      IF(IHARG(1).EQ.'S/NT')GOTO381
      IF(IHARG(1).EQ.'SN+')GOTO382
      IF(IHARG(1).EQ.'S/N+')GOTO382
      IF(IHARG(1).EQ.'SN-')GOTO383
      IF(IHARG(1).EQ.'S/N-')GOTO383
      IF(IHARG(1).EQ.'SN00')GOTO384
      IF(IHARG(1).EQ.'SNT2')GOTO384
      IF(IHARG(1).EQ.'S/N2')GOTO384
C
      IF(IHARG(1).EQ.'PROP')GOTO411
      IF(IHARG(1).EQ.'ANOP')GOTO411
      IF(IHARG(1).EQ.'CP')GOTO421
      IF(IHARG(1).EQ.'CPK')GOTO422
      IF(IHARG(1).EQ.'CNPK')GOTO415
      IF(IHARG(1).EQ.'CPM')GOTO420
      IF(IHARG(1).EQ.'CC')GOTO11420
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'PERC'.AND.IHARG(2).EQ.'DEFE')GOTO423
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'EXPE'.AND.IHARG(2).EQ.'LOSS')GOTO424
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'BIWE'.AND.IHARG(2).EQ.'LOCA')GOTO425
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'BIWE'.AND.IHARG(2).EQ.'SCAL')GOTO426
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'INTE'.AND.IHARG(2).EQ.'RANG')GOTO427
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'IQ  '.AND.IHARG(2).EQ.'RANG')GOTO427
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'HARM'.AND.IHARG(2).EQ.'MEAN')GOTO428
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'GEOM'.AND.IHARG(2).EQ.'MEAN')GOTO429
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'GEOM'.AND.IHARG(2).EQ.'SD  ')GOTO430
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'GEOM'.AND.IHARG(2).EQ.'STAN'.AND.
     1IHARG(3).EQ.'DEVI')GOTO431
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'WINS'.AND.IHARG(2).EQ.'VARI')GOTO432
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'WINS'.AND.IHARG(2).EQ.'SD')GOTO433
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'WINS'.AND.IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'DEVI')
     1GOTO434
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'WINS'.AND.IHARG(2).EQ.'COVA')GOTO435
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'WINS'.AND.IHARG(2).EQ.'CORR')GOTO436
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'BIWE'.AND.IHARG(2).EQ.'MIDV')GOTO437
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'BIWE'.AND.
     1IHARG(2).EQ.'MIDC'.AND.IHARG2(2).EQ.'ORRE')GOTO444
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'BIWE'.AND.IHARG(2).EQ.'MIDC')GOTO438
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'PERC'.AND.IHARG(2).EQ.'BEND'.AND.IHARG(3).EQ.'MIDV')
     1GOTO439
      IF(NUMARG.GE.2.AND.
     1IHARG(1).EQ.'HODG'.AND.IHARG(2).EQ.'LEHM')GOTO440
      IF(NUMARG.GE.3.AND.
     1IHARG(1).EQ.'QUAN'.AND.IHARG(2).EQ.'STAN'.AND.IHARG(3).EQ.'ERRO')
     1GOTO441
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'QUAN')GOTO442
      IF(NUMARG.GE.4.AND.
     1IHARG(1).EQ.'TRIM'.AND.IHARG(2).EQ.'MEAN'.AND.
     1IHARG(3).EQ.'STAN'.AND.IHARG(4).EQ.'ERRO')
     1GOTO443
C
      IFOUND='NO'
      GOTO9000
C
C               **********************
C               **  STEP 13--       **
C               **  DEFINE ICASPL.  **
C               **********************
C
  200 CONTINUE
      ICASPL='SCAT'
      GOTO702
C
  201 CONTINUE
      ICASPL='SIGN'
      GOTO702
C
  202 CONTINUE
      ICASPL='NUMB'
      GOTO702
C
  203 CONTINUE
      ICASPL='NUMB'
      GOTO703
C
  211 CONTINUE
      ICASPL='SUM'
      GOTO702
C
  212 CONTINUE
      ICASPL='PROD'
      GOTO702
C
  213 CONTINUE
      ICASPL='INTE'
      GOTO702
C
  221 CONTINUE
      ICASPL='MIDR'
      GOTO702
C
  222 CONTINUE
      ICASPL='MEAN'
      GOTO702
C
  223 CONTINUE
      ICASPL='MIDM'
      GOTO702
C
  224 CONTINUE
      ICASPL='MEDI'
      GOTO702
C
  225 CONTINUE
      ICASPL='TRIM'
      GOTO703
C
  226 CONTINUE
      ICASPL='WINM'
      GOTO703
C
  241 CONTINUE
      ICASPL='RANG'
      GOTO702
C
  242 CONTINUE
      ICASPL='MINI'
      GOTO702
C
  243 CONTINUE
      ICASPL='MAXI'
      GOTO702
C
  251 CONTINUE
      ICASPL='VM'
      GOTO705
C
  252 CONTINUE
      ICASPL='VM'
      GOTO704
C
  253 CONTINUE
      ICASPL='VM'
      GOTO703
C
  254 CONTINUE
      ICASPL='VARI'
      GOTO702
C
  261 CONTINUE
      ICASPL='SDM'
      GOTO706
C
  262 CONTINUE
      ICASPL='SDM'
      GOTO705
C
  263 CONTINUE
      ICASPL='SDM'
      GOTO704
C
  264 CONTINUE
      ICASPL='SD'
      GOTO703
C
  265 CONTINUE
      ICASPL='SD'
      GOTO702
C
  271 CONTINUE
      ICASPL='RSD'
      GOTO702
C
  272 CONTINUE
      ICASPL='RVAR'
      GOTO702
C
  273 CONTINUE
      ICASPL='RVAR'
      GOTO704
C
  274 CONTINUE
      ICASPL='RVAR'
      GOTO703
C
  301 CONTINUE
      ICASPL='LOWQ'
      GOTO703
C
  302 CONTINUE
      ICASPL='MIDQ'
      GOTO703
C
  303 CONTINUE
      ICASPL='UPPQ'
      GOTO703
C
  304 CONTINUE
      ICASPL='LOWH'
      GOTO703
C
  305 CONTINUE
      ICASPL='UPPH'
      GOTO703
C
  311 CONTINUE
      ICASPL='SKEW'
      GOTO705
C
  312 CONTINUE
      ICASPL='SKEW'
      GOTO702
C
  313 CONTINUE
      ICASPL='KURT'
      GOTO705
C
  314 CONTINUE
      ICASPL='KURT'
      GOTO702
C
  321 CONTINUE
      ICASPL='AUCV'
      GOTO702
C
  322 CONTINUE
      ICASPL='AUCR'
      GOTO702
C
  331 CONTINUE
      ICASPL='COVA'
      GOTO702
C
  332 CONTINUE
      ICASPL='CORR'
      GOTO702
C
  333 CONTINUE
      ICASPL='RACV'
      GOTO703
C
  334 CONTINUE
      ICASPL='RACR'
      GOTO703
C
  337 CONTINUE
      ICASPL='KTAU'
      GOTO703
C
  341 CONTINUE
      ICASPL='1DEC'
      GOTO703
C
  342 CONTINUE
      ICASPL='2DEC'
      GOTO703
C
  343 CONTINUE
      ICASPL='3DEC'
      GOTO703
C
  344 CONTINUE
      ICASPL='4DEC'
      GOTO703
C
  345 CONTINUE
      ICASPL='5DEC'
      GOTO703
C
  346 CONTINUE
      ICASPL='6DEC'
      GOTO703
C
  347 CONTINUE
      ICASPL='7DEC'
      GOTO703
C
  348 CONTINUE
      ICASPL='8DEC'
      GOTO703
C
  349 CONTINUE
      ICASPL='9DEC'
      GOTO703
C
  350 CONTINUE
      ICASPL='PERC'
      GOTO702
C
  361 CONTINUE
      ICASPL='SIFR'
      GOTO703
C
  362 CONTINUE
      ICASPL='SIAM'
      GOTO703
C
  363 CONTINUE
      ICASPL='LIIN'
      GOTO703
C
  364 CONTINUE
      ICASPL='LISL'
      GOTO703
C
  365 CONTINUE
      ICASPL='LIRE'
      GOTO703
C
  366 CONTINUE
      ICASPL='LICO'
      GOTO703
C
  371 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989
      ICASPL='SN0'
      GOTO703
C
  372 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989
      ICASPL='SN+'
      GOTO703
C
  373 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989
      ICASPL='SN-'
      GOTO703
C
  374 CONTINUE
CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1989
      ICASPL='SN00'
      GOTO703
C
CCCCC THE FOLLOWING SECTIONS (381 TO 384) WERE INSERTED MAY 1989
  381 CONTINUE
      ICASPL='SN0'
      GOTO702
C
  382 CONTINUE
      ICASPL='SN+'
      GOTO702
C
  383 CONTINUE
      ICASPL='SN-'
      GOTO702
C
  384 CONTINUE
      ICASPL='SN00'
      GOTO702
C
  411 CONTINUE
      ICASPL='PROP'
      GOTO702
CCCCC FOLLOWING 4 SECTIONS ADDED MARCH 1995
C
  415 CONTINUE
      ICASPL='CNPK'
      GOTO702
C
  416 CONTINUE
      ICASPL='AAD '
      GOTO704
C
  417 CONTINUE
      ICASPL='AAD '
      GOTO702
C
  418 CONTINUE
      ICASPL='MAD '
      GOTO704
C
  419 CONTINUE
      ICASPL='MAD '
      GOTO702
C
11420 CONTINUE
      ICASPL='CC'
      GOTO702
C
  420 CONTINUE
      ICASPL='CPM'
      GOTO702
C
  421 CONTINUE
      ICASPL='CP'
      GOTO702
C
  422 CONTINUE
      ICASPL='CPK'
      GOTO702
C
  423 CONTINUE
      ICASPL='PEDE'
      GOTO703
C
  424 CONTINUE
      ICASPL='EXLO'
      GOTO703
C
  425 CONTINUE
      ICASPL='BILO'
      GOTO703
C
  426 CONTINUE
      ICASPL='BISC'
      GOTO703
C
  427 CONTINUE
      ICASPL='IQRA'
      GOTO703
C
  428 CONTINUE
      ICASPL='HAME'
      GOTO703
C
  429 CONTINUE
      ICASPL='GEME'
      GOTO703
C
  430 CONTINUE
      ICASPL='GESD'
      GOTO703
C
  431 CONTINUE
      ICASPL='GESD'
      GOTO704
C
  432 CONTINUE
      ICASPL='WIVA'
      GOTO703
C
  433 CONTINUE
      ICASPL='WISD'
      GOTO703
C
  434 CONTINUE
      ICASPL='WISD'
      GOTO704
C
  435 CONTINUE
      ICASPL='WICV'
      GOTO703
C
  436 CONTINUE
      ICASPL='WICR'
      GOTO703
C
  437 CONTINUE
      ICASPL='BIMV'
      GOTO703
C
  438 CONTINUE
      ICASPL='BIMC'
      GOTO703
C
  439 CONTINUE
      ICASPL='PBMV'
      GOTO704
C
  440 CONTINUE
      ICASPL='HLEH'
      GOTO703
C
  441 CONTINUE
      ICASPL='QUSE'
      GOTO704
C
  442 CONTINUE
      ICASPL='QUAN'
      GOTO702
C
  443 CONTINUE
      ICASPL='TMSE'
      GOTO705
C
  444 CONTINUE
      ICASPL='BICR'
      GOTO703
C
  446 CONTINUE
      ICASPL='SNSC'
      GOTO703
C
  447 CONTINUE
      ICASPL='QNSC'
      GOTO703
C
C               *****************************************************
C               **  STEP 14--                                      **
C               **  DETERMINE THE LOCATION     (IN IHARG(.))       **
C               **  OF THE WORD      PLOT                          **
C               **  PLACE IT IN    ILASTC   .                      **
C               **  THEN SHIFT LEFT THE ENTIRE COMMAND LINE        **
C               **  SO THAT THE FIRST VARIABLE ARGUMENT            **
C               **  IS MOVED TO  IHARG(1)                          **
C               **  ALSO--                                         **
C               **        DETERMINE IF AN EFFECTS PLOT AND/OR      **
C               **        A PARETO PLOT                            **
C               **        IS BEING CALLED FOR                      **
C               *****************************************************
C
  702 CONTINUE
      IF(NUMARG.LT.2)GOTO780
      IF(IHARG(2).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(2).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(2).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(2).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(2).EQ.'PLOT')GOTO802
C
  703 CONTINUE
      IF(NUMARG.LT.3)GOTO780
      IF(IHARG(3).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(3).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(3).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(3).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(3).EQ.'PLOT')GOTO803
C
  704 CONTINUE
      IF(NUMARG.LT.4)GOTO780
      IF(IHARG(4).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(4).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(4).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(4).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(4).EQ.'PLOT')GOTO804
C
  705 CONTINUE
      IF(NUMARG.LT.5)GOTO780
      IF(IHARG(5).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(5).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(5).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(5).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(5).EQ.'PLOT')GOTO805
C
  706 CONTINUE
      IF(NUMARG.LT.6)GOTO780
      IF(IHARG(6).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(6).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(6).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(6).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(6).EQ.'PLOT')GOTO806
C
  707 CONTINUE
      IF(NUMARG.LT.7)GOTO780
      IF(IHARG(7).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(7).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(7).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(7).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(7).EQ.'PLOT')GOTO807
C
  708 CONTINUE
      IF(NUMARG.LT.8)GOTO780
      IF(IHARG(8).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(8).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(8).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(8).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(8).EQ.'PLOT')GOTO808
C
  709 CONTINUE
      IF(NUMARG.LT.9)GOTO780
      IF(IHARG(9).EQ.'EFFE'.AND.IDEXEF.NE.'ABSO')IDEXEF='EFFE'
      IF(IHARG(9).EQ.'ABSO')IDEXEF='ABSO'
      IF(IHARG(9).EQ.'PARE')IDEXPA='PARE'
      IF(IHARG(9).EQ.'YOUD')IDEXYO='YOUD'
      IF(IHARG(9).EQ.'PLOT')GOTO809
C
  780 CONTINUE
      IFOUND='NO'
      ICASPL='UNKN'
      GOTO9000
C
  801 CONTINUE
      ILASTC=1
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  802 CONTINUE
      ILASTC=2
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  803 CONTINUE
      ILASTC=3
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  804 CONTINUE
      ILASTC=4
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  805 CONTINUE
      ILASTC=5
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  806 CONTINUE
      ILASTC=6
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  807 CONTINUE
      ILASTC=7
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  808 CONTINUE
      ILASTC=8
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  809 CONTINUE
      ILASTC=9
      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
      GOTO890
C
  890 CONTINUE
      IFOUND='YES'
C
C               ***********************************************************
C               **  STEP 21--                                            **
C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.      **
C               ***********************************************************
C
      ISTEPN='21'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      MINNA=2
      MAXNA=100
      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               *****************************************
C               **  STEP 22--                          **
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='22'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      ICASEQ='FULL'
      ILOCQ=NUMARG+1
      IF(NUMARG.LT.1)GOTO2280
      DO2200J=1,NUMARG
      J1=J
      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO2210
      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO2210
      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO2220
 2200 CONTINUE
      GOTO2290
 2210 CONTINUE
      ICASEQ='SUBS'
      ILOCQ=J1
      GOTO2290
 2220 CONTINUE
      ICASEQ='FOR'
      ILOCQ=J1
      GOTO2290
C
 2280 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2281)
 2281 FORMAT('***** INTERNAL ERROR IN DPDEXP')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2282)
 2282 FORMAT('      AT BRANCH POINT 2281--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2283)
 2283 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2284)
 2284 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2285)NUMARG
 2285 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2286)
 2286 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2287)(IANS(I),I=1,IWIDTH)
 2287 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2290 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DEXP')GOTO2295
      WRITE(ICOUT,2291)NUMARG,ILOCQ,ICASEQ
 2291 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
 2295 CONTINUE
C
C               ***********************************************************
C               **  STEP 23--                                            **
C               **  IF THE   TO   FEATURE IS USED IN THE ARGUMENT LIST,  **
C               **  TRANSLATE THE   TO   TO EXPLICIT VARIABLE NAMES      **
C               ***********************************************************
C
      ISTEPN='23'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      JMIN=1
      JMAX=ILOCQ-1
      MAXFAC=MAXCMF-1
      CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXFAC,
     1IHNAME,IHNAM2,IUSE,NUMNAM,
     1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C     NOTE--
C     NUMVAR IS TOTAL NUMBER OF VARIABLES ON COMMAND LINE
C     NUMCOM IS NUMBER OF COMPONENTS--
C        = 2 (RESPONSE + FACTORS) FOR MOST PLOTS
C        = 3 (RESPONSE + INTERMEDIATE VARIABLE + FACTORS) FOR REGRESSION PLOTS
C     NUMFAC IS NUMBER OF INDEPENDENT FACTORS
C     IFAC1 IS START POSITION IN ARG LIST FOR FIRST FACTOR
C     IFAC2 IS START POSITION IN ARG LIST FOR LAST  FACTOR
C
      NUMCOM=2
      IF(ICASPL.EQ.'LIIN')NUMCOM=3
      IF(ICASPL.EQ.'LISP')NUMCOM=3
      IF(ICASPL.EQ.'LIRE')NUMCOM=3
      IF(ICASPL.EQ.'LICO')NUMCOM=3
      IF(ICASPL.EQ.'BIMC')NUMCOM=3
      IF(ICASPL.EQ.'BICR')NUMCOM=3
      IF(ICASPL.EQ.'WICV')NUMCOM=3
      IF(ICASPL.EQ.'WICR')NUMCOM=3
C
      NUMFAC=NUMVAR-1
      IF(NUMCOM.EQ.3)NUMFAC=NUMVAR-2
C
      IFAC1=2
      IF(NUMCOM.EQ.3)IFAC1=3
      IFAC2=NUMVAR
C
      IF(NUMFAC.GE.1)GOTO2390
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2311)
 2311 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2312)
 2312 FORMAT('      FOR A DEX ... STATISTIC PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2318)
 2318 FORMAT('      THE NUMBER OF FACTORS ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2319)
 2319 FORMAT('      MUST BE AT LEAST 1;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2320)
 2320 FORMAT('      SUCH WAS NOT THE CASE HERE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2321)
 2321 FORMAT('      THE SPECIFIED NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2322)NUMFAC
 2322 FORMAT('      OF FACTORS WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2323)
 2323 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2324)(IANS(I),I=1,IWIDTH)
 2324 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2390 CONTINUE
C
C               ***************************************
C               **  STEP 24--                        **
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='24'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PROF')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2400I=1,NUMVAR
C
      IHRIGH=IVARN1(I)
      IHRIG2=IVARN2(I)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      NRIGHT=IN(ILOCV)
      IF(NRIGHT.GE.MINN2)GOTO2490
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2411)
 2411 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2412)
 2412 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2421)
 2421 FORMAT('      (FOR WHICH A DEX ... STAT PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2425)
 2425 FORMAT('      WAS TO HAVE BEEN FORMED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2426)MINN2
 2426 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2427)
 2427 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2428)
 2428 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,2429)(IANS(J),J=1,IWIDTH)
 2429 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2490 CONTINUE
C
 2400 CONTINUE
C
C               ********************************************
C               **  STEP 31--                             **
C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
C               ********************************************
C
      ISTEPN='31'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IHLEFT=IVARN1(1)
      IHLEF2=IVARN2(1)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLL=IVALUE(ILOCV)
      NLEFT=IN(ILOCV)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1WRITE(ICOUT,3111)IHLEFT,ICOLL,NLEFT
 3111 FORMAT('IHLEFT,ICOLL,NLEFT = ',A4,I8,I8)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL DPWRST('XXX','BUG ')
C
C               ***************************************************************
C               **  STEP 32--                                                **
C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)      **
C               **  FOR THE RESPONSE VARIABLE IS 2 OR LARGER.                **
C               ***************************************************************
C
      ISTEPN='32'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NLEFT.GE.MINN2)GOTO3290
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3211)
 3211 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3212)
 3212 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3213)
 3213 FORMAT('      (FOR WHICH A ... STATISTIC PLOT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3214)
 3214 FORMAT('      WAS TO HAVE BEEN FORMED)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3215)MINN2
 3215 FORMAT('      MUST BE ',I8,' OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3216)
 3216 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3217)
 3217 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3218)(IANS(I),I=1,IWIDTH)
 3218 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3290 CONTINUE
      NUMV2=ILOCQ-1
C
C               ************************************************************
C               **  STEP 33--                                             **
C               **  FOR ALMOST ALL CASES,
C               **  THE DATA VARIABLES (FACTORS) START WITH VARIABLE 2.
C               **  FOR THE LINEAR INTERCEPT/SLOPE/RESSD/CORRELATION CASES,  *
C               **  THE DATA VARIABLES (FACTORS) START WITH VARIABLE 3.
C               **  THE SECOND ARGUMENT IS INTERMEDIATE.                  **
C               **  IF WE HAVE THE 2-VARIABLE CASE,                       **
C               **  CHECK THE VALIDITY OF THE SECOND (X) VARIABLE.        **
C               ************************************************************
C
      ISTEPN='33'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(NUMCOM.EQ.2)GOTO3330
      IF(NUMCOM.EQ.3)GOTO3340
      GOTO3310
C
 3310 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3311)
 3311 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3312)
 3312 FORMAT('      FOR A DEX ... STATISTIC PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3318)
 3318 FORMAT('      THE ARGUMENT POSITION FOR THE FIRST FACTOR ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3319)
 3319 FORMAT('      MUST BE 2 OR 3;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3320)
 3320 FORMAT('      SUCH WAS NOT THE CASE HERE;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3321)IFAC1
 3321 FORMAT('      THE POSITION WAS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3323)
 3323 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3324)(IANS(I),I=1,IWIDTH)
 3324 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3330 CONTINUE
      L=0
      DO3331K=IFAC1,IFAC2
      L=L+1
      IHX=IVARN1(K)
      IHX2=IVARN2(K)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHX,IHX2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLFA(L)=IVALUE(ILOCV)
      INFACT(L)=IN(ILOCV)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1WRITE(ICOUT,3332)K,L,IHX,ICOLFA(L),INFACT(L)
 3332 FORMAT('K,L,IHX,ICOLFA(L),INFACT(L) = ',2I8,2X,A4,2X,A4,2X,A4)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL DPWRST('XXX','BUG ')
 3331 CONTINUE
      GOTO3370
C
 3340 CONTINUE
      IHXINT=IVARN1(2)
      IHXIN2=IVARN2(2)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHXINT,IHXIN2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLXI=IVALUE(ILOCV)
      NXINTE=IN(ILOCV)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1WRITE(ICOUT,3341)IHXINT,ICOLXI,NXINTE
 3341 FORMAT('IHXINT,ICOLXI,NXINTE   = ',A4,I8,I8)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL DPWRST('XXX','BUG ')
C
 3350 CONTINUE
      L=0
      DO3351K=IFAC1,IFAC2
      L=L+1
      IHX=IVARN1(K)
      IHX2=IVARN2(K)
      IHWUSE='V'
      MESSAG='YES'
      CALL CHECKN(IHX,IHX2,IHWUSE,
     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      ICOLFA(L)=IVALUE(ILOCV)
      INFACT(L)=IN(ILOCV)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1WRITE(ICOUT,3352)K,L,IHX,ICOLFA(L),INFACT(L)
 3352 FORMAT('K,L,IHX,ICOLFA(L),INFACT(L) = ',2I8,2X,A4,2X,A4,2X,A4)
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL DPWRST('XXX','BUG ')
 3351 CONTINUE
      GOTO3370
C
 3370 CONTINUE
      DO3371L=1,NUMFAC
      L2=L
      L3=IFAC1+L-1
      IF(NUMCOM.EQ.2.AND.INFACT(L).EQ.NLEFT)GOTO3371
      IF(NUMCOM.EQ.3.AND.INFACT(L).EQ.NLEFT.AND.
CCCCC THE FOLLOWING LINE WAS FIXED? JANUARY 1990
CCCCC1INITE.EQ.NLEFT)GOTO3371
     1NXINTE.EQ.NLEFT)GOTO3371
      GOTO3375
 3371 CONTINUE
      GOTO3390
C
 3375 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3376)
 3376 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3377)
 3377 FORMAT('      FOR A DEX ... STATISTIC PLOT, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3378)NUMVAR
 3378 FORMAT('      WHEN HAVE ',I8,' VARIABLES SPECIFIED, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3379)
 3379 FORMAT('      THE NUMBER OF ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3380)NUMVAR
 3380 FORMAT('      IN THE ',I8,' VARIABLES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3381)
 3381 FORMAT('      MUST BE THE SAME AS THE RESPONSE VARIABLE; ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3382)
 3382 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3383)IHLEFT,NLEFT
 3383 FORMAT('      VARIABLE  1 ',A4,' HAS ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      IF(NUMCOM.EQ.2)WRITE(ICOUT,3384)IVARN1(2),INFACT(2)
 3384 FORMAT('      VARIABLE  2 ',A4,' HAS ',I8,' ELEMENTS')
      IF(NUMCOM.EQ.2)CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING LINE WAS FIXED? JANUARY 1990
CCCCC IF(NUMCOM.EQ.3)WRITE(ICOUT,3385)IVARN1(2),ININTE
CCCCC IF(NUMCOM.EQ.3)CALL DPWRST('XXX','BUG ')
      IF(NUMCOM.EQ.3)WRITE(ICOUT,3385)IVARN1(2),NXINTE
 3385 FORMAT('      VARIABLE  2 ',A4,' HAS ',I8,' ELEMENTS')
      IF(NUMCOM.EQ.3)CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3386)L3,IVARN1(L3),INFACT(L2)
 3386 FORMAT('      VARIABLE ',I2,' ',A4,' HAS ',I8,' ELEMENTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3387)
 3387 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
      CALL DPWRST('XXX','BUG ')
      IF(IWIDTH.GE.1)WRITE(ICOUT,3388)(IANS(I),I=1,IWIDTH)
 3388 FORMAT('      ',80A1)
      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3390 CONTINUE
C
C               **************************************************************
C               **  STEP 41--                                               **
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               **  NOTE--Y1    AND ICOLL  IS FOR RESPONSE VAR.             **
C               **        XINT1 AND ICOLXI IS FOR INTERMEDIATE HORIZ. VAR.  **
C               **        X1    AND ICOLX  IS FOR FINAL HORIZ. VAR.         **
C               **************************************************************
C
      ISTEPN='41'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL 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,NLEFT
      ISUB(I)=1
 4115 CONTINUE
      NQ=NLEFT
      GOTO4150
C
 4120 CONTINUE
      NIOLD=NLEFT
      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
      NQ=NIOLD
      GOTO4150
C
 4130 CONTINUE
      NIOLD=NLEFT
      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
      NQ=NFOR
      GOTO4150
C
 4150 CONTINUE
      J=0
      L=0
      IMAX=NLEFT
      IF(NQ.LT.NLEFT)IMAX=NQ
      DO4160K=IFAC1,IFAC2
      L=L+1
      ICOLX=ICOLFA(L)
      DO4170I=1,IMAX
      IF(ISUB(I).EQ.0)GOTO4170
      J=J+1
CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1990
      IF(J.GT.MAX10)GOTO4180
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)
C
      IJ=MAXN*(ICOLX-1)+I
      IF(ICOLX.LE.MAXCOL)X1(J)=V(IJ)
      IF(ICOLX.EQ.MAXCP1)X1(J)=PRED(I)
      IF(ICOLX.EQ.MAXCP2)X1(J)=RES(I)
      IF(ICOLX.EQ.MAXCP3)X1(J)=YPLOT(I)
      IF(ICOLX.EQ.MAXCP4)X1(J)=XPLOT(I)
      IF(ICOLX.EQ.MAXCP5)X1(J)=X2PLOT(I)
      IF(ICOLX.EQ.MAXCP6)X1(J)=TAGPLO(I)
C
      TAG1(J)=L
C
      IF(NUMCOM.LE.2)GOTO4170
C
      IJ=MAXN*(ICOLXI-1)+I
      IF(ICOLXI.LE.MAXCOL)XINT1(J)=V(IJ)
      IF(ICOLXI.EQ.MAXCP1)XINT1(J)=PRED(I)
      IF(ICOLXI.EQ.MAXCP2)XINT1(J)=RES(I)
      IF(ICOLXI.EQ.MAXCP3)XINT1(J)=YPLOT(I)
      IF(ICOLXI.EQ.MAXCP4)XINT1(J)=XPLOT(I)
      IF(ICOLXI.EQ.MAXCP5)XINT1(J)=X2PLOT(I)
      IF(ICOLXI.EQ.MAXCP6)XINT1(J)=TAGPLO(I)
      GOTO4170
C
 4170 CONTINUE
 4160 CONTINUE
      NLOCAL=J
CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1990
      GOTO4190
C
CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1990
 4180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4181)
 4181 FORMAT('***** ERROR IN DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4182)
 4182 FORMAT('      THE INTERMEDIATE VECTORS BEING BUILT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4183)
 4183 FORMAT('      FOR ENTRY INTO DPDEX2 HAVE GROWN TOO BIG.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4184)
 4184 FORMAT('      IN PARTICULAR, THE NUMBER OF FACTORS TIMES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4185)
 4185 FORMAT('      THE LENGTH OF EACH FACTOR HAS JUST EXCEEDED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4186)MAX10
 4186 FORMAT('      THE ALLOWABLE LIMIT OF 10*MAXOBV = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1990
 4190 CONTINUE
C
C               *************************************************************
C               **  STEP 43--                                              **
C               **  COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC--     **
C               **  (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM).           **
C               **  COMPUTE CONFIDENCE LINES.                              **
C               **  FORM THE VERTICAL AND HORIZONTAL AXIS                  **
C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                     **
C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S            **
C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,      **
C               **  AND THE UPPER CONFIDENCE LINE.                         **
C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).          **
C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).          **
C               *************************************************************
C
      ISTEPN='43'
      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DEXP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
CCCCC JUNE, 1990.  DIMENSION STAT IN DPDEXP RATHER THAN DPDEX2
      CALL DPDEX2(Y1,XINT1,X1,TAG1,NLOCAL,NUMCOM,NUMFAC,ICASPL,
     1IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID,
     1TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IQUAME,IQUASE,
     1Y,X,D,NPLOTP,NPLOTV,
     1STAT,
     1ISUBRO,IBUGG3,IERROR)
C
      ICASP3=ICASPL
      ICASPL='DEXP'
      IF(ICASP3.EQ.'SIGN')ICASPL='DEXS'
      IF(IDEXEF.EQ.'EFFE'.OR.IDEXEF.EQ.'ABSO')ICASPL='DEXE'
      IF(IDEXYO.EQ.'YOUD')ICASPL='DEXY'
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG2.EQ.'OFF'.AND.ISUBRO.NE.'DEXP')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEXP--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG2,IBUGG3,IBUGQ,ISUBRO
 9012 FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO  = ',
     1A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IFOUND,IERROR
 9013 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
 9014 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID
 9015 FORMAT('IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID = ',
     1A4,I8,2X,A4,2X,A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)NUMV2
 9016 FORMAT('NUMV2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IHLEFT,IHLEF2,ICOLL,NLEFT
 9017 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8)
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING 2 LINES WERE FIXED   APRIL 1992 (ALAN)
CCCCC IF(NUMV2.GE.2)WRITE(ICOUT,9018)IHX,IHX2,ICOLX,NX
C9018 FORMAT('IHX,IHX2,ICOLX,NX = ',A4,2X,A4,I8,I8)
CCCCC IF(NUMV2.GE.2)CALL DPWRST('XXX','BUG ')
      IF(NUMV2.GE.2)WRITE(ICOUT,9018)IHX,IHX2,ICOLX
 9018 FORMAT('IHX,IHX2,ICOLX = ',A4,2X,A4,I8)
      IF(NUMV2.GE.2)CALL DPWRST('XXX','BUG ')
      IF(NUMV2.GE.3)WRITE(ICOUT,9019)IHXINT,IHXIN2,ICOLXI,NXINTE
 9019 FORMAT('IHXINT,IHXIN2,ICOLXI,NXINTE = ',A4,2X,A4,I8,I8)
      IF(NUMV2.GE.3)CALL DPWRST('XXX','BUG ')
      IF(NPLOTP.LE.0)GOTO9090
      DO9025I=1,NPLOTP
      WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
 9026 FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
      WRITE(ICOUT,9031)DEXWID,IDEXDE,IDEXHA
 9031 FORMAT('DEXWID,IDEXDE,IDEXHA = ',E15.7,I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9032)IDEXPA,IDEXYO,IDEXEF
 9032 FORMAT('IDEXPA,IDEXYO,IDEXEF = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9033)ICASP3,ICASPL
 9033 FORMAT('ICASP3,ICASPL = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEX2(Y,XINT,X,TAG,N,NUMCOM,NUMFAC,ICASPL,
     1IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID,
     1TEMP,TEMPXI,XIDTEM,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IQUAME,IQUASE,
     1Y2,X2,D2,N2,NPLOTV,
     1STAT,
     1ISUBRO,IBUGG3,IERROR)
C
C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
C              THAT WILL DEFINE A DESIGN OF EXPERIMENT PLOT
C              OF THE FOLLOWING TYPES--
C                 DEX SCATTER PLOT (NOT A STATISTIC)
C                 DEX SIGN PLOT (NOT A STATISTIC)
C                 DEX MEAN XXX YYY  PLOT
C                 DEX MIDM XXX YYY  PLOT
C                 DEX MEDI XXX YYY  PLOT
C                 DEX SD XXX YYY  PLOT
C                 DEX MAD XXX YYY  PLOT
C                 DEX AAD XXX YYY  PLOT
C                 DEX VARI XXX YYY  PLOT
C                 DEX RSD XXX YYY  PLOT
C                 DEX RANG XXX YYY  PLOT
C                 DEX MINI XXX YYY  PLOT
C                 DEX MAXI XXX YYY  PLOT
C                 DEX SKEW XXX YYY  PLOT
C                 DEX KURT XXX YYY  PLOT
C                 DEX AUC R XXX YYY PLOT
C                 DEX SDM XXX YYY  PLOT
C                 DEX AUC V XXX YYY PLOT
C                 DEX RAC V XXX YYY PLOT
C                 DEX LOWH XXX YYY  PLOT
C                 DEX UPPH XXX YYY  PLOT
C                 DEX LOWQ XXX YYY  PLOT
C                 DEX UPPQ XXX YYY  PLOT
C                 DEX TRIM XXX YYY  PLOT
C                 DEX WINM XXX YYY  PLOT
C                 DEX MIDQ XXX YYY  PLOT
C                 DEX 1DEC  XXX YYY PLOT
C                 DEX 2DEC  XXX YYY PLOT
C                 DEX 3DEC  XXX YYY PLOT
C                 DEX 4DEC  XXX YYY PLOT
C                 DEX 5DEC XXX YYY PLOT
C                 DEX 6DEC XXX YYY PLOT
C                 DEX 7DEC XXX YYY PLOT
C                 DEX 8DEC XXX YYY PLOT
C                 DEX 9DEC XXX YYY PLOT
C                 DEX PERCENTILE XXX YYY PLOT
C                 DEX SINE FREQUENCY XXX YYY PLOT
C                 DEX SINE AMPLITUDE XXX YYY PLOT
C                 DEX LINEAR INTERCEPT XXX YYY PLOT
C                 DEX LINEAR SLOPE XXX YYY PLOT
C                 DEX LINEAR RESSD XXX YYY PLOT
C                 DEX LINEAR CORRELATION XXX YYY PLOT
C                 DEX TAGUCHI SIGNAL-TO-NOISE XXX YYY PLOTS
C                 DEX 2-LEVEL ... PLOT
C                 DEX 3-LEVEL ... PLOT
C                 DEX PROPORTION XXX YYY PLOT
C                 DEX PROPORTION XXX YYY PLOT
C                 DEX CP XXX YYY PLOT
C                 DEX CPK XXX YYY PLOT
C                 DEX CNPK XXX YYY PLOT
C                 DEX CPM XXX YYY PLOT
C                 DEX CC XXX YYY PLOT
C                 DEX PERCENT DEFECTIVE XXX YYY PLOT
C                 DEX EXPECTED LOSS XXX YYY PLOT
C                 DEX WINSORIZED COVARIANCE XXX YYY  PLOT
C                 DEX WINSORIZED CORRELATION XXX YYY  PLOT
C                 DEX BIWEIGHT MIDVARIANCE XXX YYY  PLOT
C                 DEX BIWEIGHT MIDCOVARIANCE XXX YYY  PLOT
C                 DEX PERCENTAGE BEND MIDVARIANCE XXX YYY  PLOT
C                 DEX HODGES LEHMAN XXX YYY  PLOT
C         WHERE XXX MAY BE
C                   (OMITTED)
C                   EFFECTS
C                   ABSOLUTE EFFECTS
C         AND WHERE YYY MAY BE
C                   (OMITTED)
C                   PARETO
C                   YOUDEN
C
C     NOTE--IDEXHA = FACT/TERM "HORIZONTAL" SWITCH.
C                    IF IDEXHA = FACT (THE DEFAULT),
C                    THEN THE HORIZONTAL AXIS WILL CONSIST
C                    OF FACTORS
C                    IF IDEXHA = TERM
C                    THEN THE HORIZONTAL AXIS WILL
C                    CONSIST OF TERMS
C                       1 = FOR MAIN EFFECTS
C                       2 = (FOR 2-TERM INTERACTIONS)
C                       3 = (FOR 3-TERM INTERACTIONS)
C                       ETC.
C     NOTE--IDEXDE = DEPTH INTO THE INTERACTION TERMS
C                  = NUMBER OF TERMS IN INTERACTIONS
C                    IF IDEXDE = 1, GET ONLY MAIN FACTORS,;
C                    IF IDEXDE = 2, GET MAIN FACTORS &
C                    2-TERM INTERACTION FACTORS;
C                    IF NTEXTE = 3, GET MAIN FACTORS &
C                    2-TERM & 3-TERM INTERACTION FACTORS;
C                    ETC.
C     NOTE--IDEXPA = PARE/NONP PARETO SWITCH.
C                    IF IDEXPA = PARE,
C                    THEN A PARETO PLOT OF THE STATS OR EFFECTS
C                    WILL BE FORMED.
C                    IF IDEXPA = NONP (THE DEFAULT),
C                    THEN NO PARETO PLOT WILL BE FORMED AND
C                    SO THE STAT RESULTS WILL BE PRESENTED
C                    IN "NATURAL" ORDER.
C     NOTE--IDEXYO = YOUD/NONY YOUDEN SWITCH.
C                    IF IDEXYO = YOUD,
C                    THEN A YOUDEN PLOT OF THE STATS OR EFFECTS
C                    WILL BE FORMED.
C                    IF IDEXYO = NONY (THE DEFAULT),
C                    THEN NO YOUDEN PLOT WILL BE FORMED.
C     NOTE--IDEXEF = STAT/EFFE/ABS "EFFECTS" PLOT.
C                    IF IDEXEF = STAT
C                    THEN NO DIFFERENCING WILL BE DONE
C                    AND THE INDIVIDUAL STAT VALUES WILL
C                    BE PRESENTED FOR EACH LEVEL OF EACH FACTOR.
C                    IF IDEXEF = EFFE
C                    AND THE NUMBER OF LEVELS WITHIN A FACTOR IS 2,
C                    THEN THE STAT AT THE LOW SIDE
C                    WILL BE SUBTRACTED FROM THE STAT
C                    AT THE HIGH SIDE
C                    AND PRESENTED AS THE SINGLE RESULT FOR A FACTOR
C                    THIS RESULT MAY BE + OR -)
C                    IF IDEXEF = EFFE
C                    AND THE NUMBER OF LEVELS WITHIN A FACTOR IS 3 OR MORE,
C                    THEN THE MIN VALUE OF THE STATISTIC
C                    WILL BE SUBTRACTED FROM THE
C                    MAX VALUE OF THE STATISTIC
C                    AND PRESENTED AS THE SINGLE RESULT FOR A FACTOR
C                    (THIS RESULT WILL BE + OR 0)
C                    IF IDEXEF = ABS,
C                    THEN THE ABSOLUTE VALUE OF THE EFFECT (AS DEFINED ABOVE)
C                    WILL BE COMPUTED AND PRESENTED AS THE SINGLE RESULT.
C     NOTE--DEXWID = WIDTH (ON THE PLOT) THAT WILL SPAN
C                    THE LEVELS (SETTINS) WITHIN A FACTOR;
C                    DEXWID SHOULD BE BETWEEN 0 AND 1;
C                    THE DEFAULT VALUE IS .4
C                    (THEREFORE DATA WILL TAKE .4 AND
C                    THERE WILL BE A .6 SPACING BETWEEN
C                    LARGEST LEVEL OF ONE FACTOR
C                    AND SMALLEST LEVEL OF NEXT FACTOR).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/6
C     ORIGINAL VERSION--MAY       1988.
C     UPDATED         --JANUARY   1990.  CHECK FOR OVERFLOW GRAPHICS VECTOR
C     UPDATED         --JUNE      1990.  MOVE DIMENSION OF STAT TO DPDEXP
C     UPDATED         --APRIL     1992.  MAX10 TO MAXPOP
C     UPDATED         --MAY       1995.  ADD MAD AND AAD STATISTICS
C     UPDATED         --NOVEMBER  1998.  ADD PERCENTILE STATISTICS
C     UPDATED         --NOVEMBER  1998.  ADD CM AND CC STATISTICS
C     UPDATED         --MARCH     1999.  ADD CNPK STATISTIC
C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
C                                           PLOT
C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
C     UPDATED         --APRIL     2003. ADD SN AND QN (REQUIRED
C                                       ADDITIONAL SCRATCH ARRAYS)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IQUAME
      CHARACTER*4 IQUASE
      CHARACTER*4 IDEXHA
      CHARACTER*4 IDEXPA
      CHARACTER*4 IDEXYO
      CHARACTER*4 IDEXEF
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      CHARACTER*4 ICASP2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION XINT(*)
      DIMENSION X(*)
      DIMENSION TAG(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION D2(*)
C
      DIMENSION TEMP(*)
      DIMENSION TEMPXI(*)
      DIMENSION XIDTEM(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION XTEMP3(*)
C
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
C
CCCCC JUNE, 1990.  STAT DIMENSIONED IN DPDEXP
CCCCC DIMENSION STAT(MAXOBV)
      DIMENSION STAT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOHK.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPDE'
      ISUBN2='X2  '
C
      IERROR='NO'
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 DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,32)
   32 FORMAT('      THE NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,33)
   33 FORMAT('      MUST BE AT LEAST 1;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,34)N
   34 FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
   39 CONTINUE
C
CCCCC IF(N.GE.2)GOTO49
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,46)
CCC46 FORMAT('***** ERROR IN DPDEX2--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,47)
CCC47 FORMAT('      THE NUMBER OF OBSERVATIONS')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,48)
CCC48 FORMAT('      WAS EXACTLY EQUAL TO 1.')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC IERROR='YES'
CCCCC GOTO9000
CCC49 CONTINUE
C
CCCCC HOLD=Y(1)
CCCCC DO60I=1,N
CCCCC IF(Y(I).NE.HOLD)GOTO69
CCC60 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,61)
CCC61 FORMAT('***** ERROR IN DPDEX2--')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,62)
CCC62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,63)HOLD
CCC63 FORMAT('      ARE IDENTICALLY EQUAL TO ',E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC IERROR='YES'
CCCCC GOTO9000
CCC69 CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DEX2')GOTO90
      WRITE(ICOUT,70)
   70 FORMAT('AT THE BEGINNING OF DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,71)IBUGG3,ISUBRO,IERROR
   71 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,72)N,ICASPL
   72 FORMAT('N,ICASPL = ',I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,73)NUMCOM,NUMFAC
   73 FORMAT('NUMCOM,NUMFAC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,74)IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID
   74 FORMAT('IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID = ',
     1A4,I8,2X,A4,2X,A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      DO75I=1,N
      IF(NUMCOM.EQ.2)WRITE(ICOUT,76)I,Y(I),X(I),TAG(I)
   76 FORMAT('I, Y(I),X(I),TAG(I) = ',I8,3F15.7)
      IF(NUMCOM.EQ.2)CALL DPWRST('XXX','BUG ')
      IF(NUMCOM.EQ.3)WRITE(ICOUT,77)I,Y(I),XINT(I),X(I)
   77 FORMAT('I, Y(I),XINT(I),X(I) = ',I8,3F15.7)
      IF(NUMCOM.EQ.3)CALL DPWRST('XXX','BUG ')
   75 CONTINUE
   90 CONTINUE
C
C               ********************************************************
C               **  STEP 11--                                         **
C               **  SET UP A GLOBAL LOOP TO STEP THROUGH              **
C               **  THE NUMFAC FACTOR ID'S IN TAG(.)                  **
C               ********************************************************
C
      ANUMFA=NUMFAC
C
      ITAG=0
C
      J=0
      DO1100IFAC=1,NUMFAC
      AFAC=IFAC
C
C               ********************************************************
C               **  STEP 12--                                         **
C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
C               **  FOR THE GROUP VARIABLE (USUALLY VAR. 2)           **
C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.           **
C               ********************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMSET=0
      DO1210I=1,N
      ITAGI=TAG(I)+0.5
      IF(ITAGI.NE.IFAC)GOTO1210
      IF(NUMSET.EQ.0)GOTO1220
      DO1215I2=1,NUMSET
      IF(X(I).EQ.XIDTEM(I2))GOTO1210
 1215 CONTINUE
 1220 CONTINUE
      NUMSET=NUMSET+1
      XIDTEM(NUMSET)=X(I)
 1210 CONTINUE
C
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      AN=N
      ANUMSE=NUMSET
C
      IF(NUMSET.EQ.1)A0=0.0
      IF(NUMSET.NE.1)A0=(-DEXWID/2.0)
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'EFFE')A0=0.0
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'ABSO')A0=0.0
C
      IF(NUMSET.EQ.1)A1=0.0
      IF(NUMSET.NE.1)A1=DEXWID
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'EFFE')A1=0.0
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'ABSO')A1=0.0
C
      IF(NUMSET.EQ.1)DENOM=1.0
      IF(NUMSET.NE.1)DENOM=ANUMSE-1.0
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'EFFE')DENOM=1.0
      IF(NUMSET.NE.1.AND.IDEXEF.EQ.'ABSO')DENOM=1.0
C
      IF(NUMSET.GE.1)GOTO1259
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1251)
 1251 FORMAT('***** ERROR IN DPDEX2 SUBROUTINE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1252)
 1252 FORMAT('      NUMBER OF SETS    NUMSET = 0 ')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1259 CONTINUE
C
      IF(NUMSET.NE.N)GOTO1269
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1261)
 1261 FORMAT('***** ERROR IN DPDEX2 SUBROUTINE--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1262)
 1262 FORMAT('      NUMBER OF SETS    NUMSET   IDENTICAL TO ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1263)
 1263 FORMAT('      NUMBER OF OBSERVATIONS   N   .')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1264)NUMSET
 1264 FORMAT('      NUMSET = N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 1269 CONTINUE
C
C               ******************************************
C               **  STEP 21--                           **
C               **  FOR ALL CASES,                      **
C               **  COMPUTE THE SPECIFIED STATISTIC     **
C               **  FOR EACH LEVEL OF EACH FACTOR,      **
C               ******************************************
C
      ISTEPN='21'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2100ISET=1,NUMSET
C
      K=0
      DO2110I=1,N
      ITAGI=TAG(I)+0.5
      IF(ITAGI.NE.IFAC)GOTO2110
      IF(X(I).NE.XIDTEM(ISET))GOTO2110
      K=K+1
      TEMP(K)=Y(I)
      TEMPXI(K)=XINT(I)
CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
CCCCC1WRITE(ICOUT,2111)NUMSET,ISET,J,XIDTEM(ISET)
 2111 FORMAT('NUMSET,ISET,J,XIDTEM(ISET)            = ',3I6,E12.4)
CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
CCCCC1CALL DPWRST('XXX','BUG ')
CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
CCCCC1WRITE(ICOUT,2112)N,I,K,X(I),Y(I),XINT(I),TEMP(K),TEMPXI(K)
C2112 FORMAT('N,I,K,X(I),Y(I),XINT(I),TEMP(K),TEMPXI(K) = ',
CCCCC13I6,5E12.4)
CCCCC IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DEX2')
CCCCC CALL DPWRST('XXX','BUG ')
 2110 CONTINUE
      NI=K
      NS2=NI
C
      IF(NS2.GE.1)GOTO2129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2121)
 2121 FORMAT('***** INTERNAL ERROR IN DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2122)
 2122 FORMAT('NI FOR SOME CLASS = 0')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2123)ISET,XIDTEM(ISET),NI
 2123 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 2129 CONTINUE
C
      IF(ICASPL.EQ.'SCAT')GOTO2130
      IF(IDEXEF.EQ.'EFFE'.OR.IDEXEF.EQ.'ABSO')GOTO2140
      IF(ICASPL.EQ.'SIGN')GOTO2160
      IF(IDEXYO.EQ.'YOUD')GOTO2140
      GOTO2150
C
CCCCC JUNE 2002: FOR DEX SCATTER PLOT, POINTS ASSOCIATED WITH
CCCCC A GIVEN LEVEL HAVE COMMON TAG (TO ALLOW EASY DRAWING OF
CCCCC CONNECTING LINE).
C
 2130 CONTINUE
      ITAG=ITAG+1
      DO2131L=1,NS2
      J=J+1
CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1990
      IF(J.GT.MAXPOP)GOTO2180
      Y2(J)=TEMP(L)
      ASET=ISET
      IF(NUMSET.EQ.1)X2(J)=AFAC
      IF(NUMSET.NE.1)X2(J)=AFAC+A0+A1*(ASET-1.0)/DENOM
CCCCC D2(J)=AFAC
      D2(J)=ITAG
 2131 CONTINUE
      GOTO2100
C
 2140 CONTINUE
      CALL DPDEX3(TEMP,TEMPXI,XTEMP1,XTEMP2,XTEMP3,
     1NS2,MAXNXT,ICASPL,
     1RIGHT,
     1IQUAME,IQUASE,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IBUGG3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      STAT(ISET)=RIGHT
      GOTO2100
C
 2150 CONTINUE
      CALL DPDEX3(TEMP,TEMPXI,XTEMP1,XTEMP2,XTEMP3,
     1NS2,MAXNXT,ICASPL,
     1RIGHT,
     1IQUAME,IQUASE,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IBUGG3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      J=J+1
      Y2(J)=RIGHT
      ASET=ISET
      IF(NUMSET.EQ.1)X2(J)=AFAC
      IF(NUMSET.NE.1)X2(J)=AFAC+A0+A1*(ASET-1.0)/DENOM
      D2(J)=AFAC
      GOTO2100
C
 2160 CONTINUE
      DO2161L=1,NS2
      J=J+1
      Y2(J)=TEMP(L)
      ASET=ISET
      X2(J)=AFAC
      ASET=ISET
      D2(J)=ASET
 2161 CONTINUE
      GOTO2100
C
CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 1990
 2180 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2181)
 2181 FORMAT('***** ERROR IN DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2182)
 2182 FORMAT('      THE OUTPUT GRAPHICS VECTORS BEING BUILT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2183)
 2183 FORMAT('      HAVE GROWN TOO BIG.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2184)
 2184 FORMAT('      IN PARTICULAR, THE NUMBER OF FACTORS TIMES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2185)
 2185 FORMAT('      THE LENGTH OF EACH FACTOR HAS JUST EXCEEDED')
      CALL DPWRST('XXX','BUG ')
CCCCC THE FOLLOWING LINE WAS FIXED   APRIL 1992
CCCCC WRITE(ICOUT,2186)MAX10
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2186)MAXPOP
 2186 FORMAT('      THE ALLOWABLE LIMIT OF MAXPOP = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2187)
 2187 FORMAT('      NOTE--MAXPOP = MAX NUMBER OF PLOT POINTS.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2188)
 2188 FORMAT('      SUGGESTION--GENERATE MULTIPLE DEX SCATTER ',
     1'PLOTS.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2100 CONTINUE
C
C               ************************************************
C               **  STEP 22--                                 **
C               **  FOR THE EFFECTS & ABSOLUTE EFFECTS CASE,  **
C               **  COMPUTE THE EFFECT AND/OR                 **
C               **  ABSOLUTE EFFECT FOR EACH FACTOR           **
C               ************************************************
C
      IF(IDEXEF.EQ.'EFFE'.OR.IDEXEF.EQ.'ABSO')GOTO2200
      GOTO2290
C
 2200 CONTINUE
      IF(NUMSET.LE.1)GOTO2210
      IF(NUMSET.EQ.2)GOTO2220
      GOTO2230
C
 2210 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2211)
 2211 FORMAT('***** ERROR IN DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      IF(IDEXEF.EQ.'EFFE')WRITE(ICOUT,2212)
 2212 FORMAT('      AN EFFECTS PLOT WAS CALLED FOR')
      IF(IDEXEF.EQ.'EFFE')CALL DPWRST('XXX','BUG ')
      IF(IDEXEF.EQ.'ABSO')WRITE(ICOUT,2213)
 2213 FORMAT('      AN ABSOLUTE EFFECTS PLOT WAS CALLED FOR')
      IF(IDEXEF.EQ.'ABSO')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2214)
 2214 FORMAT('      BUT A FACTOR ONLY HAD ONE LEVEL')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2215)
 2215 FORMAT('      (THEREFORE, CANNOT COMPUTE AN "EFFECT".)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2216)IFAC
 2216 FORMAT('      IT WAS FACTOR # ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2217)XIDTEM(ISET)
 2217 FORMAT('      IT WAS LEVEL  # ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2220 CONTINUE
      R1=STAT(1)
      IF(XIDTEM(2).LE.XIDTEM(1))R1=STAT(2)
      R2=STAT(2)
      IF(XIDTEM(2).LE.XIDTEM(1))R2=STAT(1)
      GOTO2250
C
 2230 CONTINUE
      R1=STAT(1)
      R2=STAT(1)
      DO2231ISET=1,NUMSET
      IF(STAT(I).LT.R1)R1=STAT(I)
      IF(STAT(I).GT.R2)R2=STAT(I)
 2231 CONTINUE
      GOTO2250
C
 2250 CONTINUE
      EFFECT=R2-R1
      ABSEFF=ABS(EFFECT)
      J=J+1
      Y2(J)=EFFECT
      IF(IDEXEF.EQ.'ABSO')Y2(J)=ABSEFF
      X2(J)=AFAC
CCCCC D2(J)=AFAC
      D2(J)=1.0
      GOTO2290
C
 2290 CONTINUE
      N2=J
C
C               *********************************************
C               **  STEP 23--                              **
C               **  FOR THE YOUDEN PLOT,                   **
C               **  FORM PLOT COORDINATES                  **
C               *********************************************
C
      IF(IDEXYO.EQ.'YOUD')GOTO2310
      GOTO2390
C
 2310 CONTINUE
      IF(NUMSET.EQ.2)GOTO2330
C
 2320 CONTINUE
      WRITE(ICOUT,999)
 2321 FORMAT('***** ERROR IN DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2322)
 2322 FORMAT('      A YOUDEN PLOT WAS CALLED FOR')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2324)
 2324 FORMAT('      BUT A FACTOR DID NOT HAVE EXACTLY TWO LEVELS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2325)
 2325 FORMAT('      (THEREFORE, CANNOT FORM THE 2 AXES')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2326)
 2326 FORMAT('      OF A YOUDEN PLOT.)')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2327)AFAC
 2327 FORMAT('      THE FACTOR           = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2328)NUMSET
 2328 FORMAT('      THE NUMBER OF LEVELS = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 2330 CONTINUE
      IF(IFAC.EQ.1)YMIN=STAT(1)
      IF(IFAC.EQ.1)YMAX=STAT(1)
      IF(STAT(1).LT.YMIN)YMIN=STAT(1)
      IF(STAT(2).LT.YMIN)YMIN=STAT(2)
      IF(STAT(1).GT.YMAX)YMAX=STAT(1)
      IF(STAT(2).GT.YMAX)YMAX=STAT(2)
C
      J=J+1
      Y2(J)=STAT(1)
      X2(J)=STAT(2)
      D2(J)=AFAC
      GOTO2390
C
 2390 CONTINUE
C
C               *********************************************
C               **  STEP 24--                              **
C               **  FOR ALL CASES EXCEPT YOUDEN PLOT,      **
C               **  IF A PARETO PLOT HAS BEEN CALLED FOR,  **
C               **  SORT (DECENDING) ALL THE COORDINATES   **
C               *********************************************
C
      IF(IDEXYO.EQ.'YOUD')GOTO2490
      IF(IDEXPA.EQ.'PARE')GOTO2410
      GOTO2490
C
 2410 CONTINUE
      DO2420I=1,N2
      Y2(I)=(-Y2(I))
 2420 CONTINUE
C
CCCCC CALL SORTC(Y2,X2,N2,TEMP,X2)
CCCCC CALL SORTC(Y2,D2,N2,TEMP,D2)
      CALL SORT(Y2,N2,TEMP)
C
      DO2430I=1,N2
      Y2(I)=TEMP(I)
      X2(I)=I
      D2(I)=1.0
 2430 CONTINUE
C
      DO2440I=1,N2
      Y2(I)=(-Y2(I))
 2440 CONTINUE
C
 2490 CONTINUE
C
 1100 CONTINUE
C
C               ******************************************
C               **  STEP 28--                           **
C               **  OPERATE ON THE FULL DATA SET.       **
C               **  FOR MOST CASES,                     **
C               **  COMPUTE THE SPECIFIED STATISTIC     **
C               **  FOR THE FULL DATA SET               **
C               **  FOR THE SCATTER PLOT AND            **
C               **  FOR THE SIGN PLOT,                  **
C               **  AUGMENT THE PLOT WITH A COMPUTED    **
C               **  MEAN LINE.                           **
C               **  FOR THE ... YOUDEN PLOT,             **
C               **  AUGMENT THE PLOT WITH A DIAGONAL LINE**
C               ******************************************
C
      IF(IDEXEF.EQ.'EFFE'.OR.IDEXEF.EQ.'ABSO')GOTO2890
      IF(IDEXYO.EQ.'YOUD')GOTO2820
C
      K=0
      DO2810I=1,N
      K=K+1
      TEMP(K)=Y(I)
      TEMPXI(K)=XINT(I)
 2810 CONTINUE
      NI=K
      NS2=NI
C
      ICASP2=ICASPL
      IF(ICASPL.EQ.'SCAT')ICASP2='MEAN'
      IF(ICASPL.EQ.'SIGN')ICASP2='MEAN'
      CALL DPDEX3(TEMP,TEMPXI,XTEMP1,XTEMP2,XTEMP3,
     1NS2,MAXNXT,ICASP2,
     1RIGHT,
     1IQUAME,IQUASE,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IBUGG3,ISUBRO,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      J=J+1
      Y2(J)=RIGHT
      X2(J)=1.0-(DEXWID/2.0)
      IF(IDEXPA.EQ.'PARE')X2(J)=1
      IF(ICASPL.EQ.'SCAT')THEN
        D2(J)=ITAG+1
      ELSE
        D2(J)=NUMFAC+1
      ENDIF
      J=J+1
      Y2(J)=RIGHT
      X2(J)=ANUMFA+(DEXWID/2.0)
      IF(IDEXPA.EQ.'PARE')X2(J)=J-2
      IF(ICASPL.EQ.'SCAT')THEN
        D2(J)=ITAG+1
      ELSE
        D2(J)=NUMFAC+1
      ENDIF
      GOTO2890
C
 2820 CONTINUE
      J=J+1
      Y2(J)=YMIN
      X2(J)=YMIN
      D2(J)=NUMFAC+1
      J=J+1
      Y2(J)=YMAX
      X2(J)=YMAX
      D2(J)=NUMFAC+1
      GOTO2890
C
 2890 CONTINUE
      N2=J
      NPLOTV=3
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DEX2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEX2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG3,ISUBRO
 9012 FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR
 9013 FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)NUMCOM,NUMFAC
 9014 FORMAT('NUMCOM,NUMFAC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID
 9015 FORMAT('IDEXHA,IDEXDE,IDEXPA,IDEXYO,IDEXEF,DEXWID = ',
     1A4,I8,2X,A4,2X,A4,2X,A4,E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)ANUMSE,A0,A1
 9017 FORMAT('ANUMSE,A0,A1 = ',3E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)YMIN,YMAX
 9018 FORMAT('YMIN,YMAX = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      DO9020I=1,N2
      WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
 9021 FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
      IF(IDEXEF.EQ.'STAT')GOTO9032
      DO9030I=1,NUMSET
      WRITE(ICOUT,9031)I,XIDTEM(I),STAT(I)
 9031 FORMAT('I,XIDTEM(I),STAT(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9030 CONTINUE
 9032 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPDEX3(TEMP,TEMPXI,XTEMP1,XTEMP2,XTEMP3,
     1NS2,MAXNXT,ICASPL,
     1RIGHT,
     1IQUAME,IQUASE,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--CALCULATE A STATISTIC IN CONNECTION WITH
C              THE ... STATISTIC PLOT COMMANDS,
C              THE DEX ... PLOT COMMANDS, ETC.
C              THE STATISTICS INCLUDE--
C                 MEAN
C                 MIDM
C                 MEDI
C                 SD
C                 MAD
C                 AAD
C                 VARI
C                 RSD
C                 RANG
C                 MINI
C                 MAXI
C                 SKEW
C                 KURT
C                 AUCR
C                 SDM
C                 AUCV
C                 RACV
C                 LOWH
C                 UPPH
C                 LOWQ
C                 UPPQ
C                 TRIM
C                 WINM
C                 MIDQ
C                 1DEC
C                 2DEC
C                 3DEC
C                 4DEC
C                 5DEC
C                 6DEC
C                 7DEC
C                 8DEC
C                 9DEC
C                 PERCENTILE
C                 SIN FREQUENCY
C                 SIN AMPLITUDE
C                 LINEAR INTERCEPT
C                 LINEAR SLOPE
C                 LINEAR RESSD
C                 LINEAR CORRELATION
C                 TAGUCHI SIGNAL-TO-NOISE
C                 PROPORTION
C                 CP
C                 CPK
C                 CNPK
C                 CPM
C                 CC
C                 EXPECTED LOSS
C                 PERCENT DEFECTIVE
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-921-3651
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/6
C     ORIGINAL VERSION--MAY       1988.
C     UPDATED         --DECEMBER  1993. LINFIT ARGS
C     UPDATED         --MARCH     1995. ADD MAD AND AAD STATISTICS
C     UPDATED         --NOVEMBER  1998. ADD PERCENTILE STATISTICS
C     UPDATED         --NOVEMBER  1998. ADD CPM, CC STATISTICS
C     UPDATED         --MARCH     1999. ADD CNPK STATISTICS
C     UPDATED         --APRIL     2001. ARGUMENT LIST FOR CP, CPK, CPM
C     UPDATED         --JULY      2002. WINSORIZED VARIANCE
C     UPDATED         --JULY      2002. WINSORIZED SD
C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
C                                           PLOT
C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD
C                                       ERROR PLOT
C     UPDATED         --APRIL     2003. ADD SN AND QN (REQUIRED
C                                       ADDITIONAL SUPPORT ARRAYS)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      EXTERNAL SUM
      EXTERNAL RANGE
C
      CHARACTER*4 ICASPL
      CHARACTER*4 IQUAME
      CHARACTER*4 IQUASE
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
CCCCC CHARACTER*4 IHP
CCCCC CHARACTER*4 IHP2
CCCCC CHARACTER*4 IHWUSE
CCCCC CHARACTER*4 MESSAG
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
CCCCC CHARACTER*4 IFLAG
C
C---------------------------------------------------------------------
C
      DIMENSION TEMP(*)
      DIMENSION TEMPXI(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION XTEMP3(*)
      DIMENSION TEMPZ(1)
C
      INTEGER ITEMP1(*)
      INTEGER ITEMP2(*)
      INTEGER ITEMP3(*)
      INTEGER ITEMP4(*)
      INTEGER ITEMP5(*)
      INTEGER ITEMP6(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='DPDE'
      ISUBN2='X3  '
C
      IWRITE='OFF'
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DEX3')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF DPDEX3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR
   52 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)ICASPL,NS2,MAXNXT
   53 FORMAT('ICASPL,NS2,MAXNXT = ',A4,2I8)
      CALL DPWRST('XXX','BUG ')
      DO60I=1,NS2
      WRITE(ICOUT,61)I,TEMP(I),TEMPXI(I),XTEMP1(I),XTEMP2(I)
   61 FORMAT('I,TEMP(I),TEMPXI(I),XTEMP1(I),XTEMP2(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
   60 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  STEP 13--                                   **
C               **  BRANCH, DEPENDING ON THE DESIRED STATISTIC  **
C               **************************************************
C
      CALL CMPSTA(
     1TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3,MAXNXT,NS2,NS2,NUMV2,ICASPL,
     1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
     1IQUAME,IQUASE,
     1RIGHT,
     1ISUBRO,IBUGG3,IERROR)
      GOTO9000
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'DEX3')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF DPDEX3--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGG3,ISUBRO,IERROR
 9012 FORMAT('IBUGG3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)ICASPL,NS2,MAXNXT
 9013 FORMAT('ICASPL,NS2,MAXNXT = ',A4,2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)RIGHT
 9015 FORMAT('RIGHT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      DO9020I=1,NS2
      WRITE(ICOUT,9021)I,TEMP(I),TEMPXI(I),XTEMP1(I),XTEMP2(I)
 9021 FORMAT('I,TEMP(I),TEMPXI(I),XTEMP1(I),XTEMP2(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9020 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
