xref: /dports/graphics/dataplot/dataplot-2c1b27601a3b7523449de612613eadeead9a8f70/src/dp40.F

      SUBROUTINE H15(X,N,C,NCUT,AH15,XSC,WS,WS2,MAXNXT,ISUBRO,IBUGA3)
C
C     THIS SUBROUTINE IS ADAPTED FROM:
C
C         ANALYTICAL METHODS COMMITTEE, "ROBUST STATISTICS--HOW
C         NOT TO REJECT OUTLIERS: PART 1. BASIC CONCEPTS",
C         ANALYST, DECEMBER 1989, VOL. 1.
C
C         THE BASIC CODE IS FROM THIS ARTICLE AND WAS WRITTEN
C         BY B. D. RIPLEY.  IT WAS MODIFED SOMEWHAT FOR ADAPTION
C         INTO DATAPLOT BY ALAN HECKERT JULY 2009.
C
C     IT COMPUTES THE H15 ROBUST ESTIMATES OF LOCATION AND SCALE.
C     NOTE THAT BY PASSING VALUES OF C OTHER THAN 1.5, IT CAN
C     ALSO BE USED TO COMPUTE H10 (C = 1), H12 (C = 1.2),
C     H17 (C = 1.7), AND H20 (C = 2.0).
C
      REAL    X(*)
      REAL    WS(*)
      REAL    WS2(*)
      REAL    XSC
      REAL    A
      REAL    BETA
      REAL    C
      REAL    C1
      REAL    XS
      REAL    XS0
      REAL    XC
      REAL    AN
      DOUBLE PRECISION    SUM
      DOUBLE PRECISION    SUM2
C
      INTEGER N
      INTEGER MAXNXT
      INTEGER I
C
      CHARACTER*4 IERROR
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IWRITE
C
      INCLUDE 'DPCOP2.INC'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'H15 ')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF H15--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,C,N
   52   FORMAT('IBUGA3,C = ',A4,2X,G15.7,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
      IF(C.EQ.1.0)THEN
        BETA=0.516
      ELSEIF(C.EQ.1.1)THEN
        BETA=0.578
      ELSEIF(C.EQ.1.2)THEN
        BETA=0.635
      ELSEIF(C.EQ.1.3)THEN
        BETA=0.688
      ELSEIF(C.EQ.1.4)THEN
        BETA=0.736
      ELSEIF(C.EQ.1.5)THEN
        BETA=0.778
      ELSEIF(C.EQ.1.6)THEN
        BETA=0.816
      ELSEIF(C.EQ.1.7)THEN
        BETA=0.849
      ELSEIF(C.EQ.1.8)THEN
        BETA=0.877
      ELSEIF(C.EQ.1.9)THEN
        BETA=0.900
      ELSEIF(C.EQ.2.0)THEN
        BETA=0.921
      ELSE
        BETA=0.778
      ENDIF
C
      C1 = C
      AN=REAL(N)
      IF(NCUT.GT.0 .AND. N.LE.NCUT)THEN
        C1 = C * SQRT(1.0 - 1.0/AN)
      ENDIF
C
      IWRITE='OFF'
      IERROR='NO'
      CALL MEDIAN(X,N,IWRITE,WS,MAXNXT,XM,IBUGA3,IERROR)
      CALL MAD(X,N,IWRITE,WS,WS2,MAXNXT,XS,IBUGA3,IERROR)
      XS=XS/0.6745
C
      ITER = 0
   10 CONTINUE
      ITER = ITER + 1
C
      IF(ITER.GT.100)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** WARNING FROM H15--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,13)
   13   FORMAT('      100 ITERATIONS WITHOUT CONVERGENCE.')
        CALL DPWRST('XXX','BUG ')
        GOTO900
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'H15 ')THEN
        WRITE(ICOUT,112)ITER,XM,XS
  112   FORMAT('FROM H15: ITER,XM,XS = ',I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      XM0 = XM
      XS0 = XS
      SUM = 0.0D0
      SUM2 = 0.0D0
      XC = C1*XS
C
      DO 200  I = 1, N
        A = MIN(XM+XC, MAX(XM-XC, X(I)))
        SUM = SUM + DBLE(A)
        SUM2 = SUM2 + DBLE((A-XM)*(A-XM))
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'H15 ')THEN
          WRITE(ICOUT,205)I,X(I),A,SUM,SUM2
  205     FORMAT('I,X(I),A,SUM,SUM2 = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
  200 CONTINUE
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'H15 ')THEN
        WRITE(ICOUT,212)SUM,SUM2
  212   FORMAT('FROM H15: SUM,SUM2 = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      XM = REAL(SUM/DBLE(N))
      XS = REAL(SQRT(SUM2/DBLE(BETA*(AN-1.0))))
      IF ((ABS(XM-XM0) .GT. 1.0E-4*XS0)  .OR.
     &    ABS(XS/XS0 - 1.0) .GT. 1.0E-4)  GOTO 10
C
  900 CONTINUE
      AH15 = XM
      XSC = XS
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'H15 ')THEN
        WRITE(ICOUT,9010)
 9010   FORMAT('AT THE END OF H15')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)XM,XM0,XS,XS0,AH15,XSC
 9012   FORMAT('XM,XM0,XS,XS0,AH15,XSC=',6G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HAMDIS(X,Y,N,IWRITE,STATVA,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAMMING DISTANCE BETWEEN THE
C              TWO SETS OF DATA IN THE INPUT VECTORS X AND Y.  THE
C              SAMPLE HAMMING DISTANCE IS THE NUMBER OF ELEMENTS THAT
C              ARE NOT THE SAME IN X AND Y.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS WHICH
C                                CONSTITUTE THE FIRST SET OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS WHICH
C                                CONSTITUTE THE SECOND SET OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTORS X AND Y.
C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE HAMMING DISTANCE
C                                BETWEEN THE TWO SETS OF DATA IN THE
C                                INPUT VECTORS X AND Y.  THIS SINGLE
C                                PRECISION VALUE WILL BE BETWEEN 0.0
C                                AND 1.0 (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE HANNING DISTANCE BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--ABS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XXX
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS
C                 GAITHERSBURG, MD 20899
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2018/08
C     ORIGINAL VERSION--AUGUST    2018.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HAMD'
      ISUBN2='IS  '
      IERROR='NO'
      STATVA=CPUMIN
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SDIS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF MANDIS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN HAMMING DISTANCE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      VARIABLES IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE MANHATTAN DISTANCE.           **
C               ************************************************
C
      STATVA=0.0
      DO200I=1,N
        IF(X(I).NE.Y(I))STATVA=STATVA+1
  200 CONTINUE
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,INT(STATVA+0.1)
  811   FORMAT('THE HAMMING DISTANCE OF THE ',I8,
     1           ' OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'MDIS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HAMDIS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,STATVA
 9012   FORMAT('IERROR,STATVA = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HARMEA(X,N,IWRITE,XHARM,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE HARMONIC MEAN, XHARM,
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE XHARM = SUM(N/(1/X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XHARM  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE HARMONIC MEAN.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE HARMONIC MEAN
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--99.3
C     ORIGINAL VERSION--MARCH     1999.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='GEOM'
      ISUBN2='EA  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N
   53 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I)
   56 FORMAT('I,X(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               ******************************
C               **  COMPUTE HARMONIC MEAN  **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE HARMEA IS TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
      XHARM=X(1)
      GOTO9000
  129 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE HARMONIC MEAN.   **
C               ***********************************
C
      DN=N
      DSUM=0.0D0
      DO200I=1,N
        DX=DBLE(X(I))
        IF(DX.NE.0.0D0)DSUM=DSUM+1.0D0/DX
  200 CONTINUE
      DSUM=DN/DSUM
      XHARM=REAL(DSUM)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XHARM
  811 FORMAT('THE HARMONIC MEAN OF THE ',I8,' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HARMEA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XHARM
 9015 FORMAT('XHARM = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HAZARD(X,TAG,NX,IWRITE,Y,XTEMP,MAXNXT,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE HAZARD OF AN ARRAY
C              THE TAG VARIABLE IDENTIFIES CENSORED DATA
C              (1 = FAILURE TIME, 0 = CENSORED)
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--ALAN HECKERT
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--98/5
C     ORIGINAL VERSION--MAY       1998.
C     UPDATED         --JANUARY   2007.  CALL LIST TO RANK
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION TAG(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HAZA'
      ISUBN2='RD  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HAZARD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,NX
   52   FORMAT('IBUGA3,NX = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,X(I),TAG(I)
   56     FORMAT('I,X(I), TAG(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  COMPUTE CUMULATIVE HAZARD       **
C               **************************************
C
      CALL SORTC(X,TAG,NX,Y,TAG)
      CALL RANK(Y,NX,IWRITE,Y,XTEMP,MAXNXT,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      AFACT=REAL(NX+1)
      DO100I=1,NX
        IF(ABS(TAG(I)).GE.0.5)THEN
          Y(I)=100.0/(AFACT - Y(I))
        ELSE
          Y(I)=0.0
        ENDIF
  100 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HAZARD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR
 9012   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NX
          WRITE(ICOUT,9016)I,X(I),Y(I)
 9016     FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HBOCDF(X,ALPHA,XI,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HYPERBOLIC
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              NUMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE CUMULATIVE DISTRIBUTION
C                                 FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C                     --XI      = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF     = THE DOUBLE PRECISION CUMULATIVE
C                                 DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE FOR THE HYPERBOLIC
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=100)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION XI
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION CDF
      DOUBLE PRECISION X
      DOUBLE PRECISION DX
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION HBOFUN
      EXTERNAL HBOFUN
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      COMMON/HBOCOM/DALPHA,DXI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' IN HBOCDF ROUTINE IS NON-POSITIVE.')
      IF(XI.LE.0.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)XI
        CALL DPWRST('XXX','WRIT')
        CDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)',
     1       ' IN HBOCDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DX=X
      INF=-1
      EPSABS=0.0D0
      EPSREL=1.0D-7
      IER=0
      DCDF=0.0D0
      IFLAG=0
      IF(DX.LT.0.0D0)THEN
        IFLAG=1
        INF=1
      ENDIF
C
      DATEMP=0.0D0
      DXI=XI
C
      CALL DQAGI(HBOFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
      IF(IFLAG.EQ.1)THEN
        CDF=1.0D0 - DCDF
      ELSE
        CDF=DCDF
      ENDIF
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM HBOCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION HBOFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C
C                 f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})*
C                     EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]}
C                     XI > 0
C              WHERE
C                 K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND AND ORDER N.
C
C              THE HBOPDF ROUTINE IS CALLED TO COMPUTE THE
C              PROBABILITY DENSITY.  DEFINE AS FUNCTION TO BE USED FOR
C              INTEGRATION CODE CALLED BY HBOCDF.  THIS ROUTINE USES
C              DOUBLE PRECISION ARITHMETIC.
C     INPUT  ARGUMENTS--DX      = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HBOFUN  = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HYPERBOLIC
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--HBOPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTERM
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      COMMON/HBOCOM/DALPHA,DXI
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL HBOPDF(DX,DALPHA,DXI,DTERM)
      HBOFUN=DTERM
C
      RETURN
      END
      SUBROUTINE HBOPDF(X,ALPHA,XI,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC DISTRIBUTION WITH
C              SHAPE PARAMETERS ALPHA AND XI.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL REAL X AND HAS THE PROBABILITY DENSITY
C              FUNCTION
C
C                 f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})*
C                     EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]}
C                     XI > 0
C              WHERE
C                 K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE
C                        SECOND KIND AND ORDER N.
C
C     NOTE--ARGUMENTS TO THIS ROUTINE ARE IN DOUBLE PRECISION.
C     INPUT  ARGUMENTS--X       = THE DOUBLE PRECISION VALUE AT
C                                 WHICH THE PROBABILITY DENSITY
C                                 FUNCTION IS TO BE EVALUATED.
C                     --ALPHA   = THE FIRST SHAPE PARAMETER
C                     --XI      = THE SECOND SHAPE PARAMETER,
C                                 XI SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF     = THE DOUBLE PRECISION PROBABILITY
C                                 DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE HYPERBOLIC DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND XI.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DBESK.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 WILEY, 1994, PP. 60.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.9
C     ORIGINAL VERSION--SEPTEMBER 2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION XI
      DOUBLE PRECISION PDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DBESK1
      EXTERNAL DBESK1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)ALPHA
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)',
     1       ' IN HBOPDF ROUTINE IS NON-POSITIVE.')
      IF(XI.LE.0.0D0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,48)XI
        CALL DPWRST('XXX','WRIT')
        PDF=0.0D0
        GOTO9000
      ENDIF
    8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)',
     1       ' IN HBOPDF ROUTINE IS NON-POSITIVE.')
   48 FORMAT('      VALUE OF ARGUMENT IS: ',G15.7)
C
C               *****************************************
C               **  STEP 2--                           **
C               **  COMPUTE THE DENSITY FUNCTION.  FOR **
C               **  BETTER NUMERICAL STABILITY,        **
C               **  COMPUTE LOGARIGHMS.                **
C               *****************************************
C
C
      DTERM1=DLOG(2.0D0) + 0.5D0*DLOG(1.0D0+ALPHA**2) +
     1       DLOG(DBESK1(XI))
      DTERM2=-XI*(DSQRT((1.0D0+ALPHA**2)*(1.0D0+X**2)) - ALPHA*X)
      DTERM3=-DTERM1 + DTERM2
      PDF=DEXP(DTERM3)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HCONS(Y,X,XIDTEM,TEMP,TEMP2,N,IWRITE,YOUT,NUMSET,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE H CONSISTENCY STATISTIC IS DEFINED AS:
C
C                 H(i) = D(i)/s(xbar(i))
C
C              WITH
C
C                 xbar(i)     = MEAN OF GROUP I
C                 s(xbar(i))  = STANDARD DEVIATION OF THE GROUP
C                               MEANS
C                 D(i)        = xbar(i) - xbar
C                 xbar        = OVERALL MEAN
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE H CONSISTENCY
C                                STATISTIC.
C                     --NUMSET = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF GROUPS.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE H CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--ALAN HECKERT
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--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION YOUT(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HCON'
      ISUBN2='S   '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE H CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE H CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
      CALL MEAN(Y,N,IWRITE,XBAR,IBUGA3,IERROR)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      AN=N
      ANUMSE=NUMSET
C
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K
        CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR)
        TEMP2(ISET1)=XBARI
        YOUT(ISET1)=XBARI - XBAR
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
          WRITE(ICOUT,1131)ISET1,XBARI
 1131     FORMAT('ISET1,XBARI = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      CALL SD(TEMP2,NUMSET,IWRITE,SDBARI,IBUGA3,IERROR)
      DO1150I=1,NUMSET
        YOUT(I)=YOUT(I)/SDBARI
 1150 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET,XBAR
 9013   FORMAT('N,NUMSET,XBAR = ',I8,1X,I8,1X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)SDBARI
 9015   FORMAT('SDBARI = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NUMSET
          WRITE(ICOUT,9019)I,TEMP2(I),YOUT(I)
 9019     FORMAT('I,TEMP2(I),YOUT(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,TEMP2,N,IWRITE,
     1YOUT,TAG,TAG2,NOUT,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE H CONSISTENCY STATISTIC IS DEFINED AS:
C
C                 H(i) = D(i)/s(xbar(i))
C
C              WITH
C
C                 xbar(i)     = MEAN OF GROUP I
C                 s(xbar(i))  = STANDARD DEVIATION OF THE GROUP
C                               MEANS
C                 D(i)        = xbar(i) - xbar
C                 xbar        = OVERALL MEAN
C
C              THE DISTINCTION BETWEEN HCONS AND HCONS2 IS THAT
C              HCONS IS USED TO COMPUTE THE H CONSISTENCY STATISTIC
C              FOR A SINGLE MATERIAL WHILE HCONS2 COMPUTES THE
C              H CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X1     = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --X2     = THE SINGLE PRECISION VECTOR OF
C                                MATERIAL ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE H CONSISTENCY
C                                STATISTIC.
C                     --TAG    = THE SINGLE PRECISION VECTOR OF THE
C                                MATERIAL ID's.
C                     --TAG2   = THE SINGLE PRECISION VECTOR OF THE
C                                LAB ID's.
C                     --NOUT   = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF VALUES IN YOUT
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE H CONSISTENCY STATISTIC WITH THE CORRESPONDING
C             MATERIAL ID.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
C     WRITTEN BY--ALAN HECKERT
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--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION YOUT(*)
      DIMENSION TAG(*)
      DIMENSION TAG2(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HCON'
      ISUBN2='S2  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HCONS2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X1(I),X2(I)
   56     FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE H CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE H CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
      CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
C
      IF(NUMSE1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSE1 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(NUMSE2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,194)
  194   FORMAT('      NUMBER OF MATERIALS    NUMSE2 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      J=0
      NOUT=0
      DO1110ISET2=1,NUMSE2
C
C  STEP 1: COMPUTE OVERALL MEAN FOR CURRENT MATERIAL
C
        K=0
        DO1120I=1,N
          IF(XIDTE2(ISET2).EQ.X2(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1120   CONTINUE
        NTEMP=K
        CALL MEAN(TEMP,NTEMP,IWRITE,XBAR,IBUGA3,IERROR)
C
        DO1130ISET1=1,NUMSE1
C
          K=0
          DO1140I=1,N
            IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN
              K=K+1
              TEMP(K)=Y(I)
            ENDIF
 1140     CONTINUE
          NTEMP=K
C
          CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR)
          TEMP2(ISET1)=XBARI
          NOUT=(ISET2-1)*NUMSE1 + ISET1
          YOUT(NOUT)=XBARI - XBAR
          TAG(NOUT)=XIDTE2(ISET2)
          TAG2(NOUT)=XIDTEM(ISET1)
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
            WRITE(ICOUT,1141)ISET1,ISET2,NOUT,XBAR,XBARI,YOUT(NOUT)
 1141       FORMAT('ISET1,ISET2,NOUT,XBAR,XBARI,YOUT(NOUT) = ',
     1             3I8,3G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
 1130   CONTINUE
C
        CALL SD(TEMP2,NUMSE1,IWRITE,SDBARI,IBUGA3,IERROR)
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
          WRITE(ICOUT,1147)ISET1,SDBARI
 1147     FORMAT('ISET1,SDBARI = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1
          YOUT(I)=YOUT(I)/SDBARI
 1150   CONTINUE
C
 1110 CONTINUE
      NOUT=NUMSE1*NUMSE2
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HCONS2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XBAR
 9013   FORMAT('N,NUMSE1,NUMSE2,XBAR = ',I8,1X,I8,1X,I8,1X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)SDBARI
 9015   FORMAT('SDBARI = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NOUT
          WRITE(ICOUT,9019)I,TAG(I),TAG2(I),YOUT(I)
 9019     FORMAT('I,TAG(I),TAG2(I),YOUT(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HEADS(Y,X,TAG,N,DIST,DTAG,TAGMAX,TAGMIN,DEL,
     1                 HEADS2,NTRIAL,AVEDEL,SDAVED,
     1                 IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--DETERMINE NUMBER OF "HEADS" IN BLOCK PLOT
C     WRITTEN BY--JAMES J. FILLIBEN
C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
C                 GAITHERSBURG, MARYLAND 20899
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     ORIGINAL VERSION--MAY     1992.
C     UPDATED         --AUGUST  2010. PASS IN TEMPORARY ARRAYS
C                                     INSTEAD OF CREATING THEM HERE
C                                     TO AVOID CONFLICTS WITH ARRAY
C                                     CREATION IN DPBLOC
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION TAG(*)
      DIMENSION DIST(*)
      DIMENSION DTAG(*)
      DIMENSION TAGMAX(*)
      DIMENSION TAGMIN(*)
      DIMENSION DEL(*)
C
CCCCC DIMENSION TAGMAX(1000)
CCCCC DIMENSION TAGMIN(1000)
CCCCC DIMENSION DEL(1000)
C
CCCCC INCLUDE 'DPCOPA.INC'
CCCCC INCLUDE 'DPCOZZ.INC'
CCCCC EQUIVALENCE (GARBAG(IGARB7),TAGMAX(1))
CCCCC EQUIVALENCE (GARBAG(IGARB8),TAGMIN(1))
CCCCC EQUIVALENCE (GARBAG(IGARB9),DEL(1))
C
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
C
      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'EADS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,70)
   70   FORMAT('AT THE BEGINNING OF HEADS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,71)N
   71   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO75I=1,N
          WRITE(ICOUT,76)I,Y(I),X(I),TAG(I)
   76     FORMAT('I,Y(I),X(I),TAG(I) = ',I8,3F15.7)
          CALL DPWRST('XXX','BUG ')
   75   CONTINUE
      ENDIF
C
C               **************************************************
C               **  STEP 1--                                    **
C               **  FORM A VECTOR (TAXMAX(.))                   **
C               **  WHICH WILL CONTAIN THE TAGS                 **
C               **  OF THE LARGEST ITEM IN EACH BLOCK.          **
C               **  THE NUMBER OF ITEMS IN TAGMAX(.)            **
C               **  WILL EQUAL THE NUMBER OF DISTINCT X VALUES. **
C               **************************************************
C
      CALL DISTIN(X,N,'OFF ',DIST,NTRIAL,IBUGG3,IERROR)
C
      DO1100ID=1,NTRIAL
C
         YIMAX=CPUMIN
         DO1200I=1,N
            IF(X(I).EQ.DIST(ID))THEN
               IF(Y(I).GT.YIMAX)THEN
                  YIMAX=Y(I)
                  TAGMAX(ID)=TAG(I)
               ENDIF
            ENDIF
 1200    CONTINUE
C
         YIMIN=CPUMAX
         DO1300I=1,N
            IF(X(I).EQ.DIST(ID))THEN
               IF(Y(I).LT.YIMIN)THEN
                  YIMIN=Y(I)
                  TAGMIN(ID)=TAG(I)
               ENDIF
            ENDIF
 1300    CONTINUE
C
      IF(TAGMAX(ID).EQ.TAGMAX(1))DEL(ID)=YIMAX-YIMIN
      IF(TAGMAX(ID).NE.TAGMAX(1))DEL(ID)=(-(YIMAX-YIMIN))
C
 1100 CONTINUE
C
C               **************************************************
C               **  STEP 2--                                    **
C               **  SCAN THE TAGMAX(.) VECTOR.                  **
C               **  DETERMINE THE MOST FREQUENT TAG IN TAXMAX(.). **
C               **  OUTPUT THAT MAX FREQUENCY (IN HEADS2).      **
C               **************************************************
C
      CALL DISTIN(TAGMAX,NTRIAL,'OFF ',DTAG,NDTAG,IBUGG3,IERROR)
C
      JMAX=(-999)
      DO2100IDTAG=1,NDTAG
         J=0
         DO2200I=1,NTRIAL
            IF(TAGMAX(I).EQ.DTAG(IDTAG))J=J+1
 2200    CONTINUE
         IF(J.GT.JMAX)JMAX=J
 2100 CONTINUE
      HEADS2=JMAX
C
C               *****************************************************
C               **  STEP 3--                                       **
C               **  COMPUTE THE AVERAGE DIFFERENCE (= EST. EFFECT) **
C               **  IN THE RESPONSE                                **
C               **  BETWEEN THE MAX AND THE MIN                    **
C               *****************************************************
C
      IWRITE='OFF'
      CALL MEAN(DEL,NTRIAL,IWRITE,AVEDEL,IBUGG3,IERROR)
      CALL SDMEAN(DEL,NTRIAL,IWRITE,SDAVED,IBUGG3,IERROR)
C
C               ******************
C               **   STEP 90--  **
C               **   EXIT       **
C               ******************
C
      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'EADS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('AT THE END       OF HEADS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9031)HEADS2,AVEDEL,SDAVED,NTRIAL
 9031   FORMAT('HEADS2,AVEDEL,SDAVED,NTRIAL= ',3F15.5,I8)
        CALL DPWRST('XXX','BUG ')
        DO9033I=1,NTRIAL
          WRITE(ICOUT,9034)I,DIST(I),TAGMAX(I)
 9034     FORMAT('I,DIST(I),TAGMAX(I) = ',I8,2F15.7)
          CALL DPWRST('XXX','BUG ')
 9033   CONTINUE
        WRITE(ICOUT,9041)NDTAG
 9041   FORMAT('NDTAG = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9042I=1,NDTAG
          WRITE(ICOUT,9043)I,DTAG(I)
 9043     FORMAT('I,DTAG(I) = ',I8,F15.7)
          CALL DPWRST('XXX','BUG ')
 9042   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE HEDGEG(Y1,Y2,N1,N2,IWRITE,STATVA,STATBC,STATSE,
     1                  ALPHA,ALCL,AUCL,
     1                  YMEAN1,YSD1,YMEAN2,YSD2,SPOOL,
     1                  ICASE,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HEDGE'S G STATISTIC.
C
C              GIVEN TWO SAMPLES, THE HEDGE'S G STATISTIC IS
C
C                 g = (YBAR1 - YBAR2)/S(POOLED)
C
C              WHERE
C
C                 YBAR1  = MEAN OF SAMPLE 1
C                 YBAR2  = MEAN OF SAMPEL 2
C                 S(POOLED) = THE POOLED STANDARD DEVIATION OF THE
C                             TWO SAMPLES:
C
C                             SQRT{((N1-1)*s1**2 + (N2-1)*s2**2)/
C                                  ((N1-1) + (N2-1))}
C
C                             S1 = STANDARD DEVIAITON SAMPLE ONE
C                             N1 = NUMBER OF OBSERVATIONS FOR SAMPLE ONE
C                             S2 = STANDARD DEVIAITON SAMPLE TWO
C                             N2 = NUMBER OF OBSERVATIONS FOR SAMPLE TWO
C
C              THERE IS A SMALL SAMPLE BIAS CORRECTION TERM (N=N1+N2):
C
C                 ((N-3)/(N-2.25))*SQRT((N-2)/N)
C
C              2018/08: HEDGE'S ORIGINAL APPROXIMATION WAS
C
C                           1 - 3/(4*N - 9)
C
C                        NOTE THAT THESE ARE ACTUALLY APPROXIMATING
C
C                           J(N1+N2-2)
C
C                        WHERE
C
C                           J(X) = GAMMA(X/2)/{SQRT(X/2)*GAMMA((X-1)/2)}
C
C                        RUNNING A COMPARISON FOR VALUES OF N1 AND N2
C                        FROM 2 TO 20 INDICATES THAT HEDGE'S ORIGINAL
C                        APPROXIMATION IS MORE ACCURATE.  WE WILL USE
C                        THE GAMMA FUNCTIONS FOR N1 AND N2 < 20.
C
C              THIS STATISTIC IS A MEASURE OF EFFECT SIZE IN STANDARD
C              DEVIATION UNITS.  A RULE OF THUMB IS
C
C                  0.2  => SMALL EFFECT
C                  0.5  => MODERATE EFFECT
C                  0.8  => LARGE EFFECT
C
C              THIS ROUTINE COMPUTES TWO VARIANTS OF THIS STATISTIC.
C
C                  1) COHEN'S D USES THE FOLLOWING ESTIMATE FOR
C                     THE POOLED STANDARD DEVAITION
C
C                       S(pooled) = SQRT((s1**2 + s2**2)/2)
C
C                     THAT IS, THE POOLED STANDARD DEVIATION IS NOT
C                     WEIGHTED BY SAMPLE SIZE.
C
C                     GENERALLY SPEAKING, HEDGE'S G IS PREFERRED TO
C                     COHEN'S D.
C
C                  2) GLASS'S ESTIMATE USES THE CONTROL GROUP STANDARD
C                     DEVIATION RATHER THAN THE POOLED STANDARD
C                     DEVIATION.  THIS VERSION IS SOMETIMES PREFERRED
C                     WHEN THE DIFFERENCE IN THE SAMPLE STANDARD
C                     DEVIATIONS IS LARGE.
C
C                     DATAPLOT ASSUMES THE CONTROL DATA IS IN SAMPLE
C                     TWO.
C
C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR FOR SAMPLE ONE
C                     --Y2     = THE SINGLE PRECISION VECTOR FOR SAMPLE TWO
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS FOR Y1
C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS FOR Y2
C                     --ICASE  = 'BIAS' => NO BIAS CORRECTION
C                              = 'BC  ' => BIAS CORRECTED
C                              = 'COHE' => COHEN'S D
C                              = 'GLAS' => GLASS STATISTIC
C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED HEDGE'S G
C                     --STATBC = THE SINGLE PRECISION VALUE OF THE
C                                BIAS CORRECTED HEDGE'S G
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE HEDGE'S G.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
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--2017/07
C     ORIGINAL VERSION--JULY      2017.
C     UPDATED         --AUGUST    2018. UPDATED BIAS CORRECTION TERM
C                                       FOR HEDGE'S G
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ICASE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DN1
      DOUBLE PRECISION DN2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DY
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DPOOL
      DOUBLE PRECISION DX
      DOUBLE PRECISION DX2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DCORR
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HEDG'
      ISUBN2='EG  '
      IERROR='NO'
      STATVA=CPUMIN
      STATBC=CPUMIN
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DGEG')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF HEDGEG--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,N1,N2,ALPHA
   52   FORMAT('IBUGA3,ISUBRO,ICASE,N1,N2,ALPHA = ',3(A4,2X),2I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,Y1(I)
   56     FORMAT('I,Y1(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,Y2(I)
   66     FORMAT('I,Y2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
C
      IF(N1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN HEDGES G--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE ONE IS ',
     1         'LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N1
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(N2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,122)
  122   FORMAT('      THE NUMBER OF OBSERVATIONS FOR VARIABLE TWO IS ',
     1         'LESS THAN ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N2
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  COMPUTE THE HEDGE'S G STATISTIC.          **
C               ************************************************
C
C     COMPUTE THE MEANS AND STANDARD DEVIATIONS
C
      DN1=DBLE(N1)
      DSUM1=0.0D0
      DO210I=1,N1
        DSUM1=DSUM1+DBLE(Y1(I))
  210 CONTINUE
      DMEAN1=DSUM1/DN1
      DSUM1=0.0D0
      DO220I=1,N1
        DY=DBLE(Y1(I))
        DSUM1=DSUM1+(DY-DMEAN1)**2
  220 CONTINUE
      DSD1=0.0D0
      IF(DN1.GT.1.5D0)DSD1=DSQRT(DSUM1/(DN1-1.0D0))
C
      DN2=DBLE(N2)
      DSUM1=0.0D0
      DO230I=1,N2
        DSUM1=DSUM1+DBLE(Y2(I))
  230 CONTINUE
      DMEAN2=DSUM1/DN2
      DSUM1=0.0D0
      DO240I=1,N2
        DY=DBLE(Y2(I))
        DSUM1=DSUM1+(DY-DMEAN2)**2
  240 CONTINUE
      DSD2=0.0D0
      IF(DN2.GT.1.5D0)DSD2=DSQRT(DSUM1/(DN2-1.0D0))
      YMEAN1=REAL(DMEAN1)
      YMEAN2=REAL(DMEAN2)
      YSD1=REAL(DSD1)
      YSD2=REAL(DSD2)
C
      DNUM=DMEAN1-DMEAN2
      IF(ICASE.EQ.'COHD')THEN
        DPOOL=(DSD1**2 + DSD2**2)/2.0D0
        DPOOL=DSQRT(DPOOL)
      ELSEIF(ICASE.EQ.'GLAS')THEN
        DPOOL=DSD2
        IF(DSD2.LE.0.0D0)DSD1=0.0D0
      ELSE
        DPOOL=((DN1-1.0D0)*DSD1**2 + (DN2-1.0D0)*DSD2**2)/
     1        (DN1+DN2-2.0D0)
        DPOOL=DSQRT(DPOOL)
      ENDIF
      SPOOL=REAL(DPOOL)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DGEG')THEN
        WRITE(ICOUT,241)DMEAN1,DSD1,DMEAN2,DSD2
  241   FORMAT('DMEAN1,DSD1,DMEAN2,DSD2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,243)DNUM,DPOOL
  243   FORMAT('DNUM,DPOOL = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF(DSD1.LE.0.0D0 .AND. DSD2.LE.0.0D0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,251)
  251   FORMAT('      THE STANDARD DEVIATIONS FOR BOTH SAMPLES ARE ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      STATVA=REAL(DNUM/DPOOL)
C
C     COMPUTE BIAS CORRECTION FACTOR
C
      N=N1+N2
      AN=REAL(N)
CCCCC CORR=((AN-3.0)/(AN-2.25))*SQRT((AN-2.0)/AN)
      IF(N.LE.40)THEN
        DN=DBLE(AN)
        DX=DN/2.0D0
        DTERM1=DGAMMA(DX)
        DTERM2=DSQRT(DX)
        DX2=(DN-1.0D0)/2.0D0
        DTERM3=DGAMMA(DX2)
        DCORR=DTERM1/(DTERM2*DTERM3)
        CORR=REAL(DCORR)
      ELSE
        CORR=1.0 - 3.0/(4.0*AN - 9.0)
      ENDIF
      STATBC=STATVA*CORR
C
C     COMPUTE STANDARD ERROR AND LOWER AND UPPER CONFIDENCE LIMITS
C
      TERM1=AN/(REAL(N1)*REAL(N2))
      TERM2=STATVA**2/(2.0*AN)
      STATSE=SQRT(TERM1 + TERM2)
      ALPHA2=ALPHA
      IF(ALPHA2.GE.1.0 .AND. ALPHA2.LE.100.0)ALPHA2=ALPHA2/100.0
      IF(ALPHA2.LE.0.0 .OR. ALPHA2.GE.1.0)THEN
        ALPHA2=0.975
      ELSEIF(ALPHA2.LT.0.5)THEN
        ALPHA2= 1.0 - (ALPHA2/2.0)
      ELSE
        ALPHA2=1.0 - ALPHA2
        ALPHA2=1.0 - (ALPHA2/2.0)
      ENDIF
      CALL NORPPF(ALPHA2,PPF)
      ALCL=STATVA - PPF*STATSE
      AUCL=STATVA + PPF*STATSE
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IF(ICASE.EQ.'HEDG')THEN
           WRITE(ICOUT,301)STATVA
  301      FORMAT('THE HEDGES G STATISTIC (NO BIAS CORRECTION) IS ',
     1            G15.7)
          CALL DPWRST('XXX','BUG ')
        ELSEIF(ICASE.EQ.'BCHG')THEN
           WRITE(ICOUT,303)STATBC
  303      FORMAT('THE BIAS CORRECTED HEDGES G STATISTIC  IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'DGEG')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF HEDGEG--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)IERROR,STATVA,STATBC,CORR
 9014   FORMAT('IERROR,STATVA,STATBC,CORR = ',A4,2X,3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9016)STATSE,ALPHA2,ALCL,AUCL
 9016   FORMAT('STATSE,ALPHA2,ALCL,AUCL = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HERMIT(X,AN,HN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HERMITE POLYNOMIAL OF
C              ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--HN     = THE SINGLE PRECISION VALUE OF THE
C                                HERMITE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DHN, DHN1, DHN2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE HERMIT SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        HN=1.0
      ELSEIF(N.EQ.1)THEN
        HN=2.0*X
      ELSEIF(N.EQ.2)THEN
        HN=4.0*X**2 - 2.0
      ELSEIF(N.EQ.3)THEN
        DHN=8.0D0*DX**3 - 12.0D0*DX
        HN=REAL(DHN)
      ELSEIF(N.EQ.4)THEN
        DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        HN=REAL(DHN)
      ELSEIF(N.EQ.5)THEN
        DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        HN=REAL(DHN)
      ELSE
        DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        DO1000I=6,N
          DN2=DBLE(I)-1.0D0
          DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2
          DHN2=DHN1
          DHN1=DHN
 1000   CONTINUE
        HN=REAL(DHN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGERS.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C                 F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0)
C              WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL:
C                 H(BETA) = SUM[j=0 to INT(N/2)]
C                           [N!*X**(N-2*j)/((N-2(j)!j!2**j)]
C              THE FIRST FEW TERMS ARE:
C                 PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2]
C                 PR(X=1) = ALPHA*BETA*PR(X=0)
C                 PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0)
C                 PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0)
C                 PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0)
C                 PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!)
C                           *PR(X=0)
C
C                 PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) +
C                             ALPHA**2*PR(X=x-1)
C
C              FOR X <= 20, THE ABOVE RECURRENCE RELATION WILL
C              BE USED.  FOR X > 20, AN AYMPTOTIC FORMULA DUE
C              TO Y. C. PATEL WILL BE USED.  NOTE THAT THE
C              PATEL ARTICLE USES:
C
C                 A = ALPHA*BETA
C                 B = ALPHA**2/2
C
C              IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF
C              ALPHA AND BETA GIVEN A AND B, THEN
C
C                 ALPHA = SQRT(2*B)
C                 BETA  = A/SQRT(2*B)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HERMITE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE
C                 --ALPHA AND BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM, DGAMMA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH,
C                                         DSINH, DLOG10.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF0
      DOUBLE PRECISION DS
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DMUS
      DOUBLE PRECISION S0
      DOUBLE PRECISION K
      DOUBLE PRECISION ZS
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DDENOM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      INTX=INT(X+0.0001)
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO HERCDF IS NEGATIVE.')
    5 FORMAT('***** WARNING--THE FIRST ARGUMENT TO HERCDF IS ',
     1       'NON-INTEGRAL.')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO HERCDF IS ',
     1       'NON-POSITIVE.')
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO HERCDF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DB=DALPHA**2/2.0D0
      DA=DALPHA*DBETA
C
C  USE EXACT FORMULAS
C
      IF(INTX.LE.25)THEN
        DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
        DCDF=DCDF0
        IF(INTX.EQ.0)GOTO9010
C
        DCDF=DCDF + DALPHA*DBETA*DCDF0
        IF(INTX.EQ.1)GOTO9010
C
        DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
        DCDF=DCDF + (DTERM1/2.0D0)*DCDF0
        IF(INTX.EQ.2)GOTO9010
C
        DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
        DCDF=DCDF + (DTERM1/6.0D0)*DCDF0
        IF(INTX.EQ.3)GOTO9010
C
        DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
        DCDF=DCDF + (DTERM1/24.0D0)*DCDF0
        IF(INTX.EQ.4)GOTO9010
C
        DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
        DCDF=DCDF + (DTERM1/120.0D0)*DCDF0
        IF(INTX.EQ.5)GOTO9010
C
        DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
        DTERM1=(DTERM1/24.0D0)*DCDF0
        DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
        DTERM2=(DTERM2/120.0D0)*DCDF0
C
        DO110I=6,INTX
          DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
          DCDF=DCDF + DPDF
          DTERM1=DTERM2
          DTERM2=DPDF
  110   CONTINUE
        GOTO9010
      ELSE
C
C  USE ASYMPTOTIC APPROXIMATION
C
        DS=DBLE(INTX)
        DMU=DA + 2.0D0*DB
        CALL HERPDF(0.0,ALPHA,BETA,PDF)
        S0=1.0D0 + 1.0D0/(12.0D0*DS) + 1.0D0/(288.0D0*DS*DS)
        DMUS=(DMU-DS)/DSQRT(DS+2.0D0*DB)
        C=DSQRT(2.0D0*DB/DS)
        K=DSQRT(1.0D0 + 2.0D0*DB/DS)
        CALL NODPDF(DMUS,ZS)
        CALL NODCDF(DMUS,DTERM1)
C
        DTERM1=1.0D0-DTERM1
        DTERM1=DTERM1*(1.0D0 + 1.0D0/(12.0D0*DS))
C
        DNUM=(DMUS**2 + (6.0D0*DB/DS) + 2.0D0)*DS
        DDENOM=3.0D0*(DS+2.0D0*DB)**(3.0D0/2.0D0)
        DTERM2=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS*(DS**2 + 6.0D0*DB*DS + 48.0D0*DB*DB)
        DDENOM=12.0D0*(DS+2.0D0*DB)**3
        DTERM3=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS**3*(DS + 42.0D0*DB)*DS
        DDENOM=36.0D0*(DS+2.0D0*DB)**3
        DTERM4=(DNUM/DDENOM)*ZS
C
        DNUM=DMUS**5*DS*DS
        DDENOM=18.0D0*(DS+2.0D0*DB)**3
        DTERM5=(DNUM/DDENOM)*ZS
C
        DCDF=DTERM5 + DTERM4 + DTERM3 + DTERM2 + DTERM1
        DCDF=(1.0D0/S0)*DCDF
        GOTO9010
      ENDIF
C
 9010 CONTINUE
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERPDF(X,ALPHA,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGERS.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C                 F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0)
C              WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL:
C                 H(BETA) = SUM[j=0 to INT(N/2)]
C                           [N!*X**(N-2*j)/((N-2(j)!j!2**j)]
C              THE FIRST FEW TERMS ARE:
C                 PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2]
C                 PR(X=1) = ALPHA*BETA*PR(X=0)
C                 PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0)
C                 PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0)
C                 PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0)
C                 PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!)
C                           *PR(X=0)
C
C                 PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) +
C                             ALPHA**2*PR(X=x-1)
C
C              FOR X <= 10, THE ABOVE RECURRENCE RELATION WILL
C              BE USED.  FOR X > 10, AN AYMPTOTIC FORMULA DUE
C              TO Y. C. PATEL WILL BE USED.  NOTE THAT THE
C              PATEL ARTICLE USES:
C
C                 A = ALPHA*BETA
C                 B = ALPHA**2/2
C
C              IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF
C              ALPHA AND BETA GIVEN A AND B, THEN
C
C                 ALPHA = SQRT(2*B)
C                 BETA  = A/SQRT(2*B)
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND N (INCLUSIVELY).
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HERMITE DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE
C                 --ALPHA AND BETA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM, DGAMMA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH,
C                                         DSINH, DLOG10.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDF0
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DIS
      DOUBLE PRECISION DAA
      DOUBLE PRECISION BS
      DOUBLE PRECISION CS
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      DPDF=0.0D0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      INTX=INT(X+0.0001)
      FINTX=INTX
      DEL=X-FINTX
      IF(DEL.LT.0.0)DEL=-DEL
      IF(DEL.GT.0.001)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)INT(FINTX)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF(FINTX.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    4 FORMAT('***** FATAL ERROR--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERPDF SUBROUTINE IS NEGATIVE.')
    5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ',
     1'ARGUMENT TO THE HERPDF SUBROUTINE IS NON-INTEGRAL *****')
    6 FORMAT('      IT HAS BEEN SET TO ',I8)
   11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' HERPDF SUBROUTINE IS NON-POSITIVE')
   12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' HERPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      DB=DALPHA**2/2.0D0
      DA=DALPHA*DBETA
C
C  USE EXACT FORMULAS
C
CCCCC IF(INTX.LE.20)THEN
      IF(INTX.LE.10)THEN
        DPDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
        IF(INTX.EQ.0)THEN
          DPDF=DPDF0
        ELSEIF(INTX.EQ.1)THEN
          DPDF=DALPHA*DBETA*DPDF0
        ELSEIF(INTX.EQ.2)THEN
          DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
          DPDF=(DTERM1/2.0D0)*DPDF0
        ELSEIF(INTX.EQ.3)THEN
          DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
          DPDF=(DTERM1/6.0D0)*DPDF0
        ELSEIF(INTX.EQ.4)THEN
          DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
          DPDF=(DTERM1/24.0D0)*DPDF0
        ELSEIF(INTX.EQ.5)THEN
          DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
          DPDF=(DTERM1/120.0D0)*DPDF0
        ELSEIF(INTX.GE.6)THEN
          DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
          DTERM1=(DTERM1/24.0D0)*DPDF0
          DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
          DTERM2=(DTERM2/120.0D0)*DPDF0
          DO110I=6,INTX
            DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
            DTERM1=DTERM2
            DTERM2=DPDF
  110     CONTINUE
        ENDIF
        PDF=REAL(DPDF)
      ELSE
        IF(MOD(INTX,2).EQ.0)THEN
          IS=INTX/2
          DIS=DBLE(IS)
          DAA=DA*DA/(8.0D0*DB)
          BS=(4.0D0*DIS+1.0D0)
          DTERM1=DSQRT(DAA)*DSQRT(DAA+BS)
          DTERM2=BS*DLOG10(DSQRT(1.0D0+DAA/BS)+DSQRT(DAA/BS))
          DTHETA=DCOSH(DTERM1 + DTERM2)
          DTERM1=-(DA+DB+DAA)
          DTERM2=DIS*DLOG(DB) - DLNGAM(DBLE(IS+1))
          DTERM3=-0.25D0*DLOG(1.0D0 + DAA/BS)
          DTERM4=DLOG(DTHETA)
          DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4
          DPDF=DEXP(DPDF)
          PDF=REAL(DPDF)
        ELSE
          IS=(INTX-1)/2
          DIS=DBLE(IS)
          DAA=DA*DA/(8.0D0*DB)
          CS=(4.0D0*DIS+3.0D0)/2.0D0
          DTERM1=DSQRT(DAA)*DSQRT(DAA+CS)
          DTERM2=CS*DLOG(DSQRT(1.0D0+DAA/CS)+DSQRT(DAA/CS))
          DTHETA=DSINH(DTERM1 + DTERM2)
          DTERM1=-(DA+DB+DAA)
          DTERM2=DIS*DLOG(DB) + 0.5D0*DLOG(2.0D0*DB) -
     1           0.5D0*DLOG(CS) - DLNGAM(DBLE(IS+1))
          DTERM3=0.25D0*DLOG(1.0D0 + DAA/CS)
          DTERM4=DLOG(DTHETA)
          DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4
          DPDF=DEXP(DPDF)
          PDF=REAL(DPDF)
        ENDIF
C
C  USE ASYMPTOTIC APPROXIMATION
C
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE HERMITE DISTRIBUTION
C              WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA.
C              THE FIRST 25 TERMS OF THE HERMITE CUMULATIVE
C              DISTRIBUTION WILL BE COMPUTED.  IF THE PERCENT
C              POINT IS NOT FOUND WITHIN THESE FIRST 25 TERMS,
C              A BISECTION METHOD WILL BE ATTEMPTED.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (INCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                                N SHOULD BE A POSITIVE INTEGER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE HERMITE DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--ALPHA AND BETA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--HERCDF
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF0
      DOUBLE PRECISION DP
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1' HERPPF IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1' HERPPF IS NON-POSITIVE')
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO ',
     1' HERPPF IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
      PPF=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
C     COMPUTE THE HERCDF, TERMINATE WHEN CDF IS GREATER THAN OR
C     EQUAL TO P.
C
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
      DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0)
      DCDF=DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      DCDF=DCDF + DALPHA*DBETA*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=1.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0)
      DCDF=DCDF + (DTERM1/2.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=2.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA)
      DCDF=DCDF + (DTERM1/6.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=3.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
      DCDF=DCDF + (DTERM1/24.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=4.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
      DCDF=DCDF + (DTERM1/120.0D0)*DCDF0
      IF(DCDF.GE.DP)THEN
        PPF=5.0
        GOTO9999
      ENDIF
C
      DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0)
      DTERM1=(DTERM1/24.0D0)*DCDF0
      DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA)
      DTERM2=(DTERM2/120.0D0)*DCDF0
C
      DO110I=6,25
        DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I)
        DCDF=DCDF + DPDF
        IF(DCDF.GE.DP)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
        DTERM1=DTERM2
        DTERM2=DPDF
  110 CONTINUE
      P0=REAL(DCDF)
C
C     IF PPF NOT FOUND IN FIRST 25 TERMS, SWITCH TO BISECTION METHOD.
C
      X0=25.0
      AMEAN=ALPHA*(ALPHA+BETA)
      ASD=SQRT(ALPHA*(2*ALPHA+BETA))
      ISD=INT(ASD)+1
C
C     DETERMINE AN UPPER BOUND BY ITERATING IN STEPS OF ONE SD.
C
      MAXIT=1000
      ICOUNT=0
  200 CONTINUE
        ICOUNT=ICOUNT+1
        IF(ICOUNT.GT.MAXIT)THEN
          WRITE(ICOUT,210)
  210     FORMAT('***** ERROR: UNABLE TO FIND UPPER BOUND IN ',
     1           'HERPPF.')
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9999
        ENDIF
        X1=X0 + REAL(ISD)
        CALL HERCDF(X1,ALPHA,BETA,P1)
        IF(P1.LT.P)THEN
          X0=X1
          GOTO200
        ENDIF
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
      IX0=INT(X0+ 0.01)
      IX1=INT(X1+ 0.01)
C
  300 CONTINUE
      IXOP1=IX0+1
      IF(IX1.EQ.IXOP1)THEN
        PPF=REAL(IX1)
        IF(P0.EQ.P)PPF=REAL(IX0)
        GOTO9999
      ENDIF
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0 .OR. IX2.EQ.IX0)THEN
        WRITE(ICOUT,311)
  311   FORMAT('***** INTERNAL ERROR IN HERPPF  SUBROUTINE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,313)
  313   FORMAT('      BISECTION VALUE (X2) = LOWER BOUND (X0) OR ',
     1         'UPPER BOUND (X1)')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,315)X0,P0
  315   FORMAT('      X0  = ',F14.7,10X,'P0 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,317)X1,P1
  317   FORMAT('      X1  = ',F14.7,10X,'P1 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,319)X2,P2
  319   FORMAT('      X2  = ',F14.7,10X,'P2 = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,321)P
  321   FORMAT('      P    = ',F14.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,323)ALPHA,BETA
  323   FORMAT('      ALPHA, BETA = ',F14.7,F14.7)
        CALL DPWRST('XXX','BUG ')
      ELSE
        X2=REAL(IX2)
        CALL HERCDF(X2,ALPHA,BETA,P2)
        IF(P0.LT.P2 .AND. P2.LT.P1)THEN
          IF(P2.LE.P)THEN
            IX0=IX2
            X0=REAL(IX0)
            P0=P2
          ELSE
            IX1=IX2
            X1=REAL(IX1)
            P1=P2
          ENDIF
          GOTO300
        ELSEIF(P2.LE.P0 .OR. P2.GE.P1)THEN
          WRITE(ICOUT,311)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,313)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,315)X0,P0
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,317)X1,P1
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,319)X2,P2
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,321)P
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,323)ALPHA,BETA
          CALL DPWRST('XXX','BUG ')
        ELSE
          WRITE(ICOUT,311)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,313)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,315)X0,P0
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,317)X1,P1
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,319)X2,P2
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,321)P
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,323)ALPHA,BETA
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HERRAN(ALPHA,BETA,N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HERMITE DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER OF THE
C                                HERMITE DISTRIBUTION.
C                                ALPHA > 0.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER OF THE
C                                HERMITE DISTRIBUTION.
C                                BETA > 0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HERMITE DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA, BETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GEORAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE
C                 DISTRIBUTIONS", SECOND EDITION, WILEY, 1992,
C                 PP. 357-364.
C               --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR
C                 CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE
C                 DISTRIBUTION", COMMUNICATIOS IN STATISTICS-
C                 THEORY AND METHODS, 14, PP. 2233-2241.
C               --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE
C                 DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4,
C                 P. 381
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2004/4
C     ORIGINAL VERSION--APRIL     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION G(2)
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--NUMBER OF HERMITE RANDOM ',
     1'NUMBERS REQUESTED < 1')
   11 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT',
     1' TO THE HERRAN SUBROUTINE IS <= 0')
   12 FORMAT('***** FATAL ERROR--THE BETA SHAPE PARAMETER ARGUMENT',
     1' TO THE HERRAN SUBROUTINE IS <= 0')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     ALGORITHM BASED ON FACT THAT HERMITE DISTRIBUTION IS
C
C          X1 + 2*X2
C
C     WHERE X1 AND X2 ARE INDPENDENT POISSON RANDOM VARIABLES
C     WITH SHAPE PARAMETERS ALPHA*BETA AND ALPHA**2/2, RESPECTIVELY.
C
      A1=ALPHA*BETA
      A2=ALPHA*ALPHA/2.0
      NTEMP=1
C
      DO100I=1,N
        CALL POIRAN(NTEMP,A1,ISEED,G(1))
        CALL POIRAN(NTEMP,A2,ISEED,G(2))
        X(I)=G(1) + 2.0*G(2)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE HESS(PNRFUN,X,N,SCL,STPSZ,FNBR,H,TIMEL,TIMEU,RLENGT)
C
C *   AUTHORS: Necip Doganaksoy and Wayne Nelson
C *   PURPOSE: Maximum likelihood fitting of the power-normal and
C *            -lognormal models to censored life or strength data
C *            from specimens of various sizes
C *   DOCUMENTATION: Wayne Nelson and Necip Doganaksoy, "A Computer
C *                  Program POWNOR for Fitting the Power-Normal and
C *                  -Lognormal Models to Life or Strength Data from
C *                  Specimens of Various Sizes", NISTIR 4760, 3/1992.
C *   PROJECT: 1990-91 ASA/NIST/NSF Fellowship
C
C     Declarations
C

      IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
      DOUBLE PRECISION X(N),SCL(N),STPSZ(N),FNBR(N),H(N,N)
      DOUBLE PRECISION MACHEP
C
      DOUBLE PRECISION TIMEL(*)
      DOUBLE PRECISION TIMEU(*)
      DOUBLE PRECISION RLENGT(*)
C
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
C
      EXTERNAL PNRFUN
C
C     End declarations
C
      MACHEP = D1MACH(4)
      FC = PNRFUN(X,N,TIMEL,TIMEU,RLENGT)
      C = MACHEP**(1.0D0/3.0D0)
C
C     Calculate stepsize and updated function value
C
      DO 10 i = 1,n
          stpsz(i) = dmax1(dabs(x(i)),1.0d0/scl(i))
          stpsz(i) = stpsz(i)*c*dsign(1.0d0,x(i))
          tempi = x(i)
          x(i) = x(i) + stpsz(i)
          stpsz(i) = x(i) - tempi
          FNBR(I) = PNRFUN(X,N,TIMEL,TIMEU,RLENGT)
          x(i) = tempi
   10 CONTINUE
      DO 30 i = 1,n
C
C     Calculate Hessian
C
C
C     Calculate Diagonal Elements
C
          tempi = x(i)
          x(i) = x(i) + 2.0d0*stpsz(i)
          fii=pnrfun(x,n,timel,timeu,rlengt)
          h(i,i) = ((fc-fnbr(i))+ (fii-fnbr(i)))/ (stpsz(i)*stpsz(i))
          x(i) = tempi + stpsz(i)
          DO 20 j = i + 1,n
C
C     Calculate Off-Diagonal Elements
C
              tempj = x(j)
              x(j) = x(j) + stpsz(j)
              fij=pnrfun(x,n,timel,timeu,rlengt)
              h(i,j) = ((fc-fnbr(i))+ (fij-fnbr(j)))/
     +                 (stpsz(i)*stpsz(j))
              h(j,i) = h(i,j)
              x(j) = tempj
   20     CONTINUE
          x(i) = tempi
   30 CONTINUE
C
      RETURN
      END
      SUBROUTINE HFCCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+x**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HALF-CAUCHY DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFCCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL CAUCDF(X,CDF)
      CDF=2.0*CDF-1.0
C
      RETURN
      END
      SUBROUTINE HFCPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+x**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALF-CAUCHY
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFCPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL CAUPDF(X,PDF)
      PDF=2.0*PDF
C
      RETURN
      END
      SUBROUTINE HFCPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)/(1+X**2)
C              THE HALF-CAUCHY DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS CAUCHY DISTRIBUTED
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALF-CAUCHY DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1994, PAGE 328
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFCPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      ARG=(1.0+P)/2.0
      CALL CAUPPF(ARG,PPF)
      IF(PPF.LE.0.0)PPF=0.0
C
      RETURN
      END
      SUBROUTINE HFCRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALF-CAUCHY DISTRIBUTION
C              WITH MEDIAN = 0 AND 75% POINT = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/PI)*(1/(1+X*X)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION
C             WITH MEDIAN = 0 AND 75% POINT = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGE 15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 154-165.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFCRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8   ,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N CAUCHY RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      ARG=PI*X(I)
      X(I)=-COS(ARG)/SIN(ARG)
  100 CONTINUE
C
C
C     GENERATE N HALF-CAUCHY RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A HALF-CAUCHY VARIATE
C     EQUALS THE ABSOLUTE VALUE OF A CAUCHY VARIATE.
C
      DO400I=1,N
      IF(X(I).LT.0.0)X(I)=-X(I)
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE HFLCDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTICALLY DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2
C                                                     0<=X<=1/K
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF FOR THE HALF-LOGISTIC
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG, DCDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.GT.10.0)THEN
          WRITE(ICOUT,24)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
        ENDIF
      ELSE
        ARG1=1./GAMMA
        IF(X.LT.0.0.OR.X.GT.ARG1)THEN
          WRITE(ICOUT,14)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          CDF=0.0
          GOTO9999
        ENDIF
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO HFLCDF ',
     1       'IS NEGATIVE.')
   14 FORMAT('***** WARNING--THE FIRST  ARGUMENT TO HFLCDF IS ',
     1       'OUTSIDE THE (0,1/GAMMA) INTERVAL.')
   24 FORMAT('***** ERROR--THE SECOND ARGUMENT TO HFLCDF ',
     1       'IS GREATER THAN 10.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C-----START POINT-----------------------------------------------------
C
      IF(X.EQ.0.)THEN
        CDF=0.0
        GOTO9999
      ELSEIF(GAMMA.GT.0.0.AND.X.GE.1.0/GAMMA)THEN
        CDF=1.0
        GOTO9999
      ENDIF
C
      DX=DBLE(X)
      DG=DBLE(GAMMA)
      IF(GAMMA.LE.0.0)THEN
        DTERM1=DLOG(1.D0-DEXP(-DX))
        DTERM2=DLOG(1.D0+DEXP(-DX))
        DTERM3=DTERM1-DTERM2
        IF(DTERM3.LE.-500.D0)THEN
          CDF=0.0
        ELSEIF(DTERM3.GE.500.D0)THEN
          CDF=1.0
        ELSE
          DCDF=DEXP(DTERM3)
          CDF=SNGL(DCDF)
        ENDIF
      ELSE
        DTERM1=DLOG(1.D0-(1.D0-DG*DX)**(1.D0/DG))
        DTERM2=DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG))
        DTERM3=DTERM1-DTERM2
        IF(DTERM3.LE.-500.D0)THEN
          CDF=0.0
        ELSEIF(DTERM3.GE.500.D0)THEN
          CDF=1.0
        ELSE
          DCDF=DEXP(DTERM3)
          CDF=SNGL(DCDF)
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION HFLFUN(SIGHAT,X,N)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE SCALE PARAMETER OF THE HALF-LOGISTIC
C              DISTRIBUTION.  THIS FUNCTION FINDS THE ROOT OF THE
C              EQUATION:
C
C                N*LOG(2) - N*LOG(SIGMA) + (N*YBAR/SIGMA) -
C                2*SUM[LOG(1 + EXP(Y(I)/SIGMA)]
C
C              CALLED BY FMIND2 ROUTINE FOR FINDING THE MINIMUM
C              OF A FUNCTION.  RETURN "NEGATIVE" OF THE FUNCTION
C              SINCE WE WANT THE MAXIMUM.
C     EXAMPLE--HALF LOGISTIC MAXIMUM LIKELIHOOD Y
C     REFERENCE--XXX
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2020/04
C     ORIGINAL VERSION--APRIL      2020.
C
C---------------------------------------------------------------------
C
      REAL SIGHAT
      DOUBLE PRECISION X(*)
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      COMMON/HFLCOM/DTERM1,DTERM2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION SG
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      SG=DBLE(SIGHAT)
      DN=DBLE(N)
      DSUM1=0.0D0
      DO100I=1,N
        DX=X(I)
        DTERM3=1.0D0 + DEXP(DX/SG)
        DSUM1=DSUM1 + DLOG(DTERM3)
  100 CONTINUE
C
CCCCC HFLFUN=-REAL(DTERM1 + DN*DLOG(SG) + (DTERM2/SG) - 2.0*DSUM1)
      HFLFUN=REAL(DTERM1 + DN*DLOG(SG) + (DTERM2/SG) - 2.0*DSUM1)
CCCCC write(18,*) 'sighat,hflfun = ',sighat,hflfun
C
      RETURN
      END
      SUBROUTINE HFLLI1(Y,N,ICASPL,
     1                  ALOC,SCALE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE HALF-LOGISTIC DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     REFERENCE--XXXX
C     WRITTEN BY--ALAN HECKERT
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--2020/04
C     ORIGINAL VERSION--APRIL     2020.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HFLL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF HFLLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
      NP=2
      IF(ICASPL.EQ.'1')THEN
        ALOC=0.0
        NP=1
      ENDIF
C
      ALIK=0.0
      GAMMA=CPUMIN
      DO1000I=1,N
        ARG1=(Y(I) - ALOC)/SCALE
        CALL HFLPDF(ARG1,GAMMA,RESULT)
        APDF=RESULT/SCALE
        IF(APDF.GT.0.0)THEN
          ALIK=ALIK + LOG(APDF)
        ENDIF
 1000 CONTINUE
C
      DN=DBLE(N)
      DLIK=DBLE(ALIK)
      DNP=DBLE(NP)
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF HFLLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HFLML1(Y,N,ICASPL,
     1                  TEMP1,DTEMP1,
     1                  XMEAN,XSD,XMIN,XMAX,
     1                  ALOCML,SCALML,SCALBC,SCALSE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE HALF-LOGISTIC DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLHL WILL GENERATE THE OUTPUT
C              FOR THE HALF LOGISTIC MLE COMMAND).
C
C              THE CODE IS SET-UP TO HANDLE EITHER 1-PARAMETER OR
C              2-PARAMETER CASE.
C
C     REFERENCE--XXXX
C     WRITTEN BY--ALAN HECKERT
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--2020/04
C     ORIGINAL VERSION--APRIL     2020.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION DN
C
      REAL HFLFUN
      EXTERNAL HFLFUN
      REAL FMIND2
      EXTERNAL FMIND2
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      COMMON/HFLCOM/DTERM1,DTERM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAXM'
      ISUBN2='L1  '
      IWRITE='OFF'
      IERROR='NO'
C
      ALOCML=CPUMIN
      SCALML=CPUMIN
      SCALSE=CPUMIN
      SCALBC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF HFLML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),DTEMP1(I)
   57     FORMAT('I,Y(I),DTEMP1(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CARRY OUT CALCULATIONS                **
C               **  FOR HALF-LOGISTIC MLE ESTIMATE        **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='HALF-LOGISTIC'
      IFLAG=0
      IF(ICASPL.EQ.'1')IFLAG=1
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C     ESTIMATE FOR LOCATION PARAMETER FIRST
C
      IF(ICASPL.EQ.'1')THEN
        ALOCML=0.0
      ELSE
        ALOCML=XMIN
      ENDIF
C
      DO120I=1,N
        TEMP1(I)=Y(I) - ALOCML
        DTEMP1(I)=DBLE(TEMP1(I))
  120 CONTINUE
      CALL MEAN(TEMP1,N,IWRITE,XMEAN2,IBUGA3,IERROR)
C
C     ESTIMATE SCALE PARAMETER BY SOLVING THE EQUATION
C
C         N*LOG(2) - N*LOG(SIGMA) + (N*YBAR/SIGMA) -
C         2*SUM[LOG(1 + EXP(Y(I)/SIGMA)]
C
      DN=DBLE(N)
      DTERM1=DN*DLOG(2.0D0)
      DTERM2=DN*DBLE(XMEAN2)
C
      XLOW=XSD/2.0
      XUPP=XSD*2.0
      TOL=0.001
CCCCC SCALML=FMIND2(XLOW,XUPP,HFLFUN,DTEMP1,N,TOL)
      C=(REAL(N) + 0.05256765)/REAL(N)
      SCALBC=SCALML*C
C
C     NOTE: NOT GETTING REASONABLE RESULTS WITH FMIND2 ROUTINE.
C           FOR NOW, BRUTE FORCE EVALUATE THE FUNCTION
C
CCCCC SCALML=FMIND2(XLOW,XUPP,HFLFUN,DTEMP1,N,TOL)
      AINC=0.01
      SIGVAL=XLOW
      AMXVAL=CPUMIN
C
 2000 CONTINUE
      AVAL=HFLFUN(SIGVAL,DTEMP1,N)
      IF(AVAL.GT.AMXVAL)THEN
        SCALML=SIGVAL
        AMXVAL=AVAL
      ENDIF
      write(18,*)'sigval,aval = ',sigval,aval
      SIGVAL=SIGVAL+AINC
      IF(SIGVAL.LT.XUPP)GOTO2000
C
      C=(REAL(N) + 0.05256765)/REAL(N)
      SCALBC=SCALML*C
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF HFLML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)XMEAN,XMEAN2,XSD,XMIN,XMAX
 9055   FORMAT('XMEAN,XMEAN2,XSD,XMIN,XMAX = ',5G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9058)ALOCML,SCALML,C,SCALBC
 9058   FORMAT('ALOCML,SCALML,C,SCALBC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HFLPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTIC DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2
C                                                     0<=X<=1/K
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALF-LOGISTIC
C             DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--CAUPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DG, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
      IF(GAMMA.GT.10.0)THEN
          WRITE(ICOUT,24)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        IF(X.LT.0.0)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ELSE
        ARG1=1./GAMMA
        IF(X.LT.0.0.OR.X.GT.ARG1)THEN
          WRITE(ICOUT,14)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)X
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO HFLPDF IS NEGATIVE.')
   14 FORMAT('***** WARNING--THE FIRST ARGUMENT TO HFLPDF ',
     1       'IS OUTSIDE THE (0,1/GAMMA) INTERVAL.')
   24 FORMAT('***** ERROR--THE SECOND ARGUMENT TO HFLPDF ',
     1       'IS GREATER THAN 10.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C-----START POINT-----------------------------------------------------
C
      IF(GAMMA.LE.0.0)THEN
        CALL LOGPDF(X,PDF)
        PDF=2.0*PDF
      ELSE
        DX=DBLE(X)
        IF(X.GE.1.0/GAMMA)THEN
          IF(GAMMA.LT.1.0)THEN
            PDF=0.0
            GOTO9999
          ELSEIF(GAMMA.EQ.1.0)THEN
            PDF=2.0
            GOTO9999
          ELSE
            DX=DX-0.000000001D0
          ENDIF
        ENDIF
        DG=DBLE(GAMMA)
        DTERM1=DLOG(2.0D0)
        DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0-DG*DX)
        DTERM3=2.D0*DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG))
        DTERM4=DTERM1+DTERM2-DTERM3
        IF(DABS(DTERM4).GE.40.D0)THEN
          PDF=0.0
        ELSE
          DPDF=DEXP(DTERM4)
          PDF=SNGL(DPDF)
        ENDIF
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HFLPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = 2*EXP(-X)/(1+EXP(-X))**2    X>=0
C              THE HALF-LOGISTIC DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS LOGISTIC DISTRIBUTED
C              IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC
C              DISTRIBUTION IS COMPUTED.  THIS HAS THE PDF:
C              F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2
C                                                     0<=X<=1/K
C
C              FOR THE HALF-LOGISTIC, THE PPF FUNCTION IS:
C
C                 G(P) = -LOG((P-1)/(P+1))
C
C              FOR THE GENERALIZED HALF-LOGISTIC, THE PPF
C              FUNCTION IS:
C
C                 G(P,GAMMA) = (1 - ((1-P)/(1+P))**GAMMA)/GAMMA
C
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALF-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGES 150-151
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JANUARY   2005. REPLACE NUMERICAL INVERSION
C                                       WITH EXPLICIT FORMULAS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DG
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(GAMMA.GT.10.0)THEN
          WRITE(ICOUT,24)
   24     FORMAT('***** ERROR--THE SECOND ARGUMENT TO HFLPPF ',
     1           'IS GREATER THAN 10.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)GAMMA
          CALL DPWRST('XXX','BUG ')
          GOTO9999
      ELSEIF(GAMMA.LE.0.0)THEN
        IF(P.LT.0.0.OR.P.GE.1.0)THEN
          WRITE(ICOUT,1)
    1     FORMAT('***** ERROR--THE FIRST ARGUMENT TO HFLPPF ',
     1           'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)P
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ELSE
        IF(P.LT.0.0.OR.P.GT.1.0)THEN
          WRITE(ICOUT,1)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)P
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9999
        ENDIF
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C  STANDARD HALF-LOGISTIC CASE.  HAVE TO BOUND TO THE RIGHT.
C
      IF(P.EQ.0.0)THEN
        PPF=0.
        GOTO9999
      ENDIF
C
      DP=DBLE(P)
      DG=DBLE(GAMMA)
C
      IF(GAMMA.LE.0.0)THEN
        DPPF=-DLOG((1.0D0-DP)/(1.0D0+DP))
      ELSE
        IF(P.EQ.1.0)THEN
          DPPF=1.0D0/DG
        ELSE
          DPPF=(1.0D0 - ((1.0D0-DP)/(1.0D0+DP))**DG)/DG
        ENDIF
      ENDIF
      PPF=REAL(DPPF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HFLRAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALF-LOGISTIC DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HALF-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO HFLRAN ',
     1         'IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N HALF-LOGISTIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD
C     AND THE FACT THAT THE HALF-LOGISTIC RANDOM NUMBER IS DEFINED
C     TO BE THE ABSOLUTE VALUE OF LOGISTIC RANDOM NUMBER.
C
      DO100I=1,N
      CALL HFLPPF(X(I),GAMMA,XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HFNCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HALFNORMAL
C              DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE HALFNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      CDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFNCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL NORCDF(X,CDF)
      CDF=2.0*CDF-1.0
C
      RETURN
      END
      SUBROUTINE HFNLI1(Y,N,ICASPL,
     1                  ALOC,SCALE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE HALF-NORMAL DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     REFERENCE--XXXX
C     WRITTEN BY--ALAN HECKERT
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--2020/04
C     ORIGINAL VERSION--APRIL     2020.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HFNL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF HFNLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
      NP=2
      IF(ICASPL.EQ.'1')THEN
        ALOC=0.0
        NP=1
      ENDIF
C
      ALIK=0.0
      DO1000I=1,N
        ARG1=(Y(I) - ALOC)/SCALE
        CALL HFNPDF(ARG1,RESULT)
        APDF=RESULT/SCALE
        IF(APDF.GT.0.0)THEN
          ALIK=ALIK + LOG(APDF)
        ENDIF
 1000 CONTINUE
C
      DN=DBLE(N)
      DLIK=DBLE(ALIK)
      DNP=DBLE(NP)
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF HFNLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HFNML1(Y,N,ICASPL,
     1                  XMEAN,XSD,XMIN,XMAX,
     1                  ALOCML,SCALML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE MAXWELL DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLHN WILL GENERATE THE OUTPUT
C              FOR THE MAXWELL MLE COMMAND).
C
C              THE CODE IS SET-UP TO HANDLE EITHER 1-PARAMETER OR
C              2-PARAMETER CASE.
C
C              THE ESTIMATE OF THE LOCATION PARAMETER IS THE
C              SAMPLE MINIMUM.  THE ESTIMATE OF THE SCALE PARAMETER IS
C
C                 SCALEHAT = SQRT(SUM[i=1 to N][(X(i) - YMIN)**2/N])
C
C     REFERENCE--XXXX
C     WRITTEN BY--ALAN HECKERT
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--2020/04
C     ORIGINAL VERSION--APRIL     2020.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
C
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HFNM'
      ISUBN2='L1  '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF HFNML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                              **
C               **  CARRY OUT CALCULATIONS                **
C               **  FOR HALF-NORMAL MLE ESTIMATE          **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='HALF-NORMAL'
      IFLAG=0
      IF(ICASPL.EQ.'1')IFLAG=1
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IF(ICASPL.EQ.'1')THEN
        ALOCML=0.0
      ELSE
        ALOCML=XMIN
      ENDIF
      SCALML=CPUMIN
C
      DSUM1=0.0D0
      DLOC=DBLE(ALOCML)
      DN=DBLE(N)
C
      DO1010I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + (DX - DLOC)**2
 1010 CONTINUE
      SCALML=REAL(DSQRT(DSUM1/DN))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF HFNML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,6G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9056)DSUM1,ALOCML,SCALML
 9056   FORMAT('DSUM1,ALOCML,SCALML = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HFNPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HALFNORMAL DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE HALFNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      PDF=0.0
      RETURN
   90 CONTINUE
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST  INPUT ARGUMENT')
    5 FORMAT('      TO THE HFNPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CALL NORPDF(X,PDF)
      PDF=2.0*PDF
C
      RETURN
      END
      SUBROUTINE HFNPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HALFNORMAL
C              DISTRIBUTION.
C              THE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE HALFNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(2/PI) = 0.79788456
C             AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
C               --DANIEL, 'USE OF HALF-NORMAL PLOTS IN
C                 INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS',
C                 TECHNOMETRICS, 1959, PAGES 311-341.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      ARG=(1.0+P)/2.0
      CALL NORPPF(ARG,PPF)
      IF(PPF.LE.0.0)PPF=0.0
C
      RETURN
      END
      SUBROUTINE HFNRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HALFNORMAL DISTRIBUTION.
C              THE PROTOTYPE HALFNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2).
C              THE PROTOTYPE HALFNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HALFNORMAL DISTRIBUTION
C              WITH MEAN = SQRT(2/PI) = 0.79788456
C              AND STANDARD DEVIATION = 1.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, SQRT, SIN, COS.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 53, 59, 81, 83.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HFNRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
      IP1=I+1
      U1=X(I)
      IF(I.EQ.N)GOTO210
      U2=X(IP1)
      GOTO220
  210 U2=Y(2)
  220 ARG1=-2.0*LOG(U1)
      ARG2=2.0*PI*U2
      SQRT1=SQRT(ARG1)
      Z1=SQRT1*COS(ARG2)
      Z2=SQRT1*SIN(ARG2)
      X(I)=Z1
      IF(I.EQ.N)GOTO200
      X(IP1)=Z2
  200 CONTINUE
C
C     GENERATE N HALFNORMAL RANDOM NUMBERS
C     USING THE DEFINITION THAT
C     A HALFNORMAL VARIATE
C     EQUALS THE ABSOLUTE VALUE OF A NORMAL VARIATE.
C
      DO400I=1,N
      IF(X(I).LT.0.0)X(I)=-X(I)
  400 CONTINUE
C
      RETURN
      END
      SUBROUTINE HLQEST(X, N, XTEMP, LB, RB, Q, ISEED, RESULT)
C
C    SUBROUTINE HLQEST
C
C    PURPOSE       COMPUTES THE HODGES-LEHMANN LOCATION ESTIMATOR:
C                  MEDIAN OF ( X(I) + X(J) ) / 2   FOR 1 LE I LE J LE N
C
C    USAGE         CALL HLQEST(X,N,LB,RB,Q,RESULT)
C
C    ARGUMENTS  X   REAL ARRAY OF OBSERVATIONS  (INPUT)
C                 * VALUES OF X MUST BE IN NONDECREASING ORDER *
C
C               N   INTEGER NUMBER OF OBSERVATIONS  (INPUT)
C                 * N MUST NOT BE LESS THAN 1 *
C
C               LB  INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C               RB  INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C               Q   INTEGER ARRAY OF LENGTH N FOR WORKSPACE
C
C           ISEED   SEED FOR UNIFORM RANDOM NUMBER GENERATOR
C
C         NOTE ---  ONLY LB,RB, AND Q ARE CHANGED IN COMPUTATION
C
C   EXTERNAL ROUTINE
C              RAN  FUNCTION PROVIDING UNIFORM RANDOM VARIABLES
C                   IN THE INTERVAL (0,1)
C                   RAN REQUIRES A DUMMY INTEGER ARGUMENT
C
C   NOTES           HLQEST HAS AN EXPECTED TIME COMPLEXITY ON
C                   THE ORDER OF N * LG( N )
C
C
C                   FOR N <= 25, COMPUTE DIRECTLY
C
C  J F MONAHAN, APRIL 1982, DEPT OF STAT, N C S U, RALEIGH, N C 27650
C  FINAL VERSION  JUNE 1983
C
      REAL X(*), AMN, AMX, XRAN(1)
      REAL XTEMP(*)
      INTEGER LB(*), RB(*), Q(*), SM, SQ, I, J, K, K1, K2, L, N, NN,
     * MDLL, MDLU, LBI, RBI, MDLROW, IQ
C
C  TAKE CARE OF SPECIAL CASES: N=1 AND N=2
C
      IF (N.LE.0) THEN
         RESULT=0.0
         RETURN
      ENDIF
C
      CALL SORT(X,N,X)
      IF (N.EQ.1) THEN
          RESULT = X(1)
          RETURN
      ELSEIF (N.EQ.2) THEN
          RESULT = (X(1)+X(2))/2.
          RETURN
      ELSEIF (N.LE.25) THEN
          NN = 0
          DO 1 I=1,N
            DO 2 J = I,N
              NN = NN + 1
              XTEMP(NN) = X(I) + X(J)
 2          CONTINUE
 1        CONTINUE
          CALL SORT(XTEMP,NN,XTEMP)
          K=(NN+1)/2
          IF(2*K.EQ.NN) XTEMP(K) = (XTEMP(K) + XTEMP(K+1))/2.
          RESULT=XTEMP(K)/2.
          RETURN
      ENDIF
C
C  FIND THE TOTAL NUMBER OF PAIRS (NN) AND THE MEDIAN(S) (K1,K2) NEEDED
C
      NN = (N*(N+1))/2
      K1 = (NN+1)/2
      K2 = (NN+2)/2
C
C  INITIALIZE LEFT AND RIGHT BOUNDS
C
      DO 20 I=1,N
        LB(I) = I
        RB(I) = N
   20 CONTINUE
C  SM = NUMBER IN SET S AT STEP M
      SM = NN
C  L = NUMBER OF PAIRS LESS THAN THOSE IN SET S AT STEP M
      L = 0
C
C
C  USE THE MEDIAN OF X(I)'S TO PARTITION ON THE FIRST STEP
C
      MDLL = (N+1)/2
      MDLU = (N+2)/2
      AM = X(MDLL) + X(MDLU)
      GO TO 80
C
C  USE THE MIDRANGE OF SET S AS PARTITION ELEMENT WHEN TIES ARE LIKELY
C   -- OR GET THE AVERAGE OF THE LAST 2 ELEMENTS
C
   30 CONTINUE
      AMX = X(1) + X(1)
      AMN = X(N) + X(N)
      DO 40 I=1,N
C   SKIP THIS ROW IF NO ELEMENT IN IT IS IN SET S ON THIS STEP
        IF (LB(I).GT.RB(I)) GO TO 40
        LBI = LB(I)
C                             GET THE SMALLEST IN THIS ROW
        AMN = AMIN1(AMN,X(LBI)+X(I))
        RBI = RB(I)
C                             GET THE LARGEST IN THIS ROW
        AMX = AMAX1(AMX,X(RBI)+X(I))
   40 CONTINUE
      AM = (AMX+AMN)/2.
C  BE CAREFUL TO CUT OFF SOMETHING -- ROUNDOFF CAN DO WIERD THINGS
      IF (AM.LE.AMN .OR. AM.GT.AMX) AM = AMX
C  UNLESS FINISHED, JUMP TO PARTITION STEP
      IF (AMN.NE.AMX .AND. SM.NE.2) GO TO 80
C  ALL DONE IF ALL OF S IS THE SAME -OR- IF ONLY 2 ELEMENTS ARE LEFT
      RESULT = AM/2.
      RETURN
C
C   *****   RESTART HERE UNLESS WORRIED ABOUT TIES   *****
C
   50 CONTINUE
C                        USE RANDOM ROW MEDIAN AS PARTITION ELEMENT
CCCCC FOR DATAPLOT: CALL UNIRAN
CCCCC K = IFIX(FLOAT(SM)*RAN(SM))
      NTEMP=1
      CALL UNIRAN(NTEMP, ISEED, XRAN)
      K = IFIX(FLOAT(SM)*XRAN(1))
C                        K IS A RANDOM INTEGER FROM O TO SM-1
      DO 60 I=1,N
        J = I
        IF (K.LE.RB(I)-LB(I)) GO TO 70
        K = K - RB(I) + LB(I) - 1
   60 CONTINUE
C                        J IS A RANDOM ROW --- NOW GET ITS MEDIAN
   70 MDLROW = (LB(J)+RB(J))/2
      AM = X(J) + X(MDLROW)
C
C       *****   PARTITION STEP   *****
C
C  USE AM TO PARTITION S0 INTO 2 GROUPS: THOSE .LT. AM, THOSE .GE. AM
C  Q(I)= HOW MANY PAIRS (X(I)+X(J)) IN ROW I LESS THAN AM
   80 CONTINUE
      J = N
C                              START IN UPPER RIGHT CORNER
      SQ = 0
C                              I COUNTS ROWS
      DO 110 I=1,N
        Q(I) = 0
C                              HAVE WE HIT THE DIAGONAL ?
   90   IF (J.LT.I) GO TO 110
C                              SHALL WE MOVE LEFT ?
        IF (X(I)+X(J).LT.AM) GO TO 100
        J = J - 1
        GO TO 90
C                              WE'RE DONE IN THIS ROW
  100   Q(I) = J - I + 1
C  SQ = TOTAL NUMBER OF PAIRS LESS THAN AM
        SQ = SQ + Q(I)
  110 CONTINUE
C
C  ***  FINISHED PARTITION --- START BRANCHING  ***
C
C  IF CONSECUTIVE PARTITIONS ARE THE SAME WE PROBABLY HAVE TIES
      IF (SQ.EQ.L) GO TO 30
C
C  ARE WE NEARLY DONE, WITH THE VALUES WE WANT ON THE BORDER?
C  IF(WE NEED  MAX OF THOSE .LT. AM -OR- MIN OF THOSE .GE. AM) GO TO 90
C
      IF (SQ.EQ.K2-1) GO TO 180
C
C  THE SET S IS SPLIT, WHICH PIECE DO WE KEEP?
C  70  =  CUT OFF BOTTOM,   90  =  NEARLY DONE,   60  =  CUT OFF TOP
C
CCCCC IF (SQ-K1) 140, 180, 120
      IF (SQ-K1.LT.0) THEN
         GOTO140
      ELSEIF (SQ-K1.EQ.0) THEN
        GOTO180
      ELSE
        GOTO120
      ENDIF
C
C  NEW S = (OLD S) .INTERSECT. (THOSE .LT. AM)
  120 CONTINUE
      DO 130 I=1,N
C                            RESET RIGHT BOUNDS FOR EACH ROW
        RB(I) = I + Q(I) - 1
  130 CONTINUE
      GO TO 160
C  NEW S = (OLD S) .INTERSECT. (THOSE .GE. AM)
  140 CONTINUE
      DO 150 I=1,N
C                            RESET LEFT BOUNDS FOR EACH ROW
        LB(I) = I + Q(I)
  150 CONTINUE
C
C  COUNT   SM = NUMBER OF PAIRS STILL IN NEW SET S
C           L = NUMBER OF PAIRS LESS THAN THOSE IN NEW SET S
  160 L = 0
      SM = 0
      DO 170 I=1,N
        L = L + LB(I) - I
        SM = SM + RB(I) - LB(I) + 1
  170 CONTINUE
C
C        *****   NORMAL RESTART JUMP   *****
C
      IF (SM.GT.2) GO TO 50
C  CAN ONLY GET TO 2 LEFT IF K1.NE.K2  -- GO GET THEIR AVERAGE
      GO TO 30
C
C  FIND:   MAX OF THOSE .LT. AM
C          MIN OF THOSE .GE. AM
  180 CONTINUE
      AMN = X(N) + X(N)
      AMX = X(1) + X(1)
      DO 190 I=1,N
        IQ = Q(I)
        IPIQ = I + IQ
        IF (IQ.GT.0) AMX = AMAX1(AMX,X(I)+X(IPIQ-1))
        IPIQ = I + IQ
        IF (IQ.LT.N-I+1) AMN = AMIN1(AMN,X(I)+X(IPIQ))
  190 CONTINUE
      RESULT = (AMN+AMX)/4.
C  WE ARE DONE, BUT WHICH SITUATION ARE WE IN?
      IF (K1.LT.K2) RETURN
      IF (SQ.EQ.K1) RESULT = AMX/2.
      IF (SQ.EQ.K1-1) RESULT = AMN/2.
      RETURN
      END
      SUBROUTINE HN(NX,DHN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HARMONIC NUMBER
C              FUNCTION FOR REAL ARGUMENTS GREATER THAN 1.
C
C              THE HARMONIC NUMBER IS:
C
C                 H(N)=SUM[K=1 to N][1/K]
C
C              THE HARMONIC NUMBER CAN BE COMPUTED IN EITHER
C              OF THE FOLLOWING TWO WAYS:
C
C              1) H(N) = PSI(N+1) + gamma
C                 WHERE gamma IS EULER'S CONSTANT
C
C              2) H(N) = gamma + LOG(N) + (1/2)*N**(-2) +
C                        (1/120)*N**(-4) + O(n**(-6))
C
C              IN THIS SUBROUTINE, WE WILL USE DIRECT SUMMATION
C              FOR N <= 30.  FOR N > 30, WE WILL USE THE PSI
C              FUNCTION.
C
C     INPUT  ARGUMENTS--NX     = THE INTEGR VALUE OF THE ORDER OF
C                                THE HARMONIC NUMBER
C     OUTPUT ARGUMENTS--DHN    = THE DOUBLE PRECISION HARMONIC
C                                NUMBER
C     OUTPUT--THE DOUBLE PRECISION HARMONIC NUMBER DHN.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DPSI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBRUG, MD 20899-8980
C                 PHONE--301-975-2855
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.9
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-----------------
C
C-------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      EXTERNAL DPSI
      DOUBLE PRECISION DPSI
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-----------------------------------------------
C
CCCCC DATA DEPS/1.0D-20/
C
C-----START POINT---------------------------------------------------
C
      IF(NX.LT.1)THEN
        WRITE(ICOUT,51)
   51   FORMAT('***** ERROR FROM HARMNUMB FUNCTION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)
   53   FORMAT('      THE FIRST ARGUMENT (N) MUST BE A POSITIVE ',
     1         'INTEGER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,55)NX
   55   FORMAT('      VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        DHN=0.0D0
        GOTO9000
      ENDIF
C
C     FOR N <= 30, JUST DO A DIRECT SUM.
C
      IF(NX.LE.30)THEN
        DSUM=0.0D0
        DO100I=NX,1,-1
          DSUM=DSUM + 1.0D0/DBLE(I)
  100   CONTINUE
        DHN=DSUM
C
C     OTHERWISE, USE DPSI FUNCTION
C
      ELSE
        DHN=DPSI(DBLE(NX+1)) + 0.5772156649
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HNM(NX,DM,DHNM)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED HARMONIC
C              NUMBER FUNCTION FOR REAL ARGUMENTS GREATER THAN 1.
C
C              THE GENERALIZED HARMONIC NUMBER IS:
C
C                 H(N,M)=SUM[K=1 to N][1/K**M]
C
C              THIS IS RELATED TO THE RIEMAN-ZETA SUM:
C
C                 ZETA(M)=SUM[K=1 to INFINITY][1/K**M]
C
C              THAT IS, THE ZETA SUM IS THE LIMIT OF THE
C              GENERALIZED HARMONIC NUMBER AS N GOES TO INFINITY.
C
C              WE ADAPT THE CODE FOR COMPUTING THE RIEMAN-ZETA SUM.
C              THIS CODE IS BASED ON EULER-MACMACLAURIN SUMMATION.
C
C              FOR BETTER COMPUTATIONAL ACCURACY, ACTUALLY
C              COMPUTE ZETA(X) - 1.
C     INPUT  ARGUMENTS--DNX    = THE DOUBLE PRECISION VALUE OF
C                                THE N ARGUMENT
C                     --DM     = THE DOUBLE PRECISION VALUE OF
C                                THE M ARGUMENT
C     OUTPUT ARGUMENTS--DHNM   = THE DOUBLE PRECISION GENERALIZED
C                                HARMONIC NUMBER
C     OUTPUT--THE DOUBLE PRECISION GENERALIZED HARMONIC NUMBER DHNM.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964.
C               --THOMPSON, "ATLAS FOR COMPUTING MATHEMATICAL
C                 FUNCTIONS", WILEY, 1997.  THIS ROUTINE IS A
C                 FORTRAN TRANSLATION OF THE C FUNCTION ON PAGE 146
C                 OF THIS BOOK.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBRUG, MD 20899-8980
C                 PHONE--301-975-2855
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.9
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-----------------
C
C-------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-----------------------------------------------
C
CCCCC DATA DEPS/1.0D-30/
C
C-----START POINT---------------------------------------------------
C
      IF(NX.LT.1)THEN
        WRITE(ICOUT,51)
   51   FORMAT('***** ERROR FROM GENEHARM FUNCTION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)
   53   FORMAT('      THE FIRST ARGUMENT (N) MUST BE A POSITIVE ',
     1         'INTEGER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,55)NX
   55   FORMAT('      VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        DHNM=0.0D0
        GOTO9000
      ELSEIF(DM.LE.1.0D0)THEN
        WRITE(ICOUT,51)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,63)
   63   FORMAT('      THE SECOND ARGUMENT (M) MUST BE > 1')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,65)DM
   65   FORMAT('      VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        DHNM=0.0D0
        GOTO9000
      ENDIF
C
CCCCC DX=DM
C
CCCCC DSTERM=DX*(DX+1.0D0)*(DX+2.0D0)*
CCCCC1       (DX+3.0D0)*(DX+4.0D0)/30240.0D0
CCCCC DTERM1=DSTERM*(2.0D0**DX)/DEPS
CCCCC DTERM2=DTERM1**(1.0D0/(DX+5.0D0))
CCCCC IF(DTERM2.LE.10.01)THEN
CCCCC   N=10
CCCCC ELSE
CCCCC   N=INT(DTERM2)
CCCCC ENDIF
C
CCCCC DSUM2=0.0D0
CCCCC DO190I=1,MIN(N,NX)
CCCCC     DSUM2=DSUM2 + 1.0D0/DBLE(I)**DX
CC190 CONTINUE
CCCCC print *,'nx,n,dsum2=',nx,n,dsum2
C
C     FOR NOW, JUST COMPUTE BY DIRECT SUMMATION.  NEED TO
C     FIND A BETTER ALGORITHM FOR THIS FUNCTION.
C
      DX=DM
      N=NX
CCCCC IF(N.LE.30)THEN
        DSUM=0.0D0
        DO200I=N,1,-1
          DSUM=DSUM + 1.0D0/DBLE(I)**DX
  200   CONTINUE
        DHNM=DSUM
C
C     OTHERWISE, USE ZETA APPROXIMATION WHERE N MAY BE
C     TRUNCATED SOONER THAN FOR ZETA.
C
CCCCC ELSE
CCCCC   FN=DBLE(N)
CCCCC   DNEGX=-DX
CCCCC   DSUM=0.0D0
CCCCC   DO100K=2,N-1
CCCCC     DSUM=DSUM + DBLE(K)**DNEGX
C100    CONTINUE
C
CCCCC   DSUM = DSUM +
CCCCC1         (FN**DNEGX)*(0.5D0 + FN/(DX-1.0D0)
CCCCC1         + DX*(1.0D0 -
CCCCC1         (DX+1.0D0)*(DX+2.0D0)/(60.0D0*FN*FN))/(12.0D0*FN))
CCCCC1         + DSTERM/(FN**(DX+0.5D0))
C
CCCCC   DHNM=DSUM + 1.0D0
CCCCC ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS,
     +     SX,STEPMX,
CDPLT+     OPTFCN,SX,STEPMX,
     +     STEPTL,DLT,IRETCD,MXTAKE,AMU,DLTP,PHI,PHIP0,
     +     SC,XPLSP,WRK0,EPSM,ITNCNT,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C FIND A NEXT NEWTON ITERATE (XPLS) BY THE MORE-HEBDON METHOD
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE X[K-1]
C F            --> FUNCTION VALUE AT OLD ITERATE, F(X)
C G(N)         --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE
C A(N,N)       --> CHOLESKY DECOMPOSITION OF HESSIAN IN LOWER
C                  TRIANGULAR PART AND DIAGONAL.
C                  HESSIAN IN UPPER TRIANGULAR PART AND UDIAG.
C UDIAG(N)     --> DIAGONAL OF HESSIAN IN A(.,.)
C P(N)         --> NEWTON STEP
C XPLS(N)     <--  NEW ITERATE X[K]
C FPLS        <--  FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C DLT         <--> TRUST REGION RADIUS
C IRETCD      <--  RETURN CODE
C                    =0 SATISFACTORY XPLS FOUND
C                    =1 FAILED TO FIND SATISFACTORY XPLS SUFFICIENTLY
C                       DISTINCT FROM X
C MXTAKE      <--  BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C AMU         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C DLTP        <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHI         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHIP0       <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C SC(N)        --> WORKSPACE
C XPLSP(N)     --> WORKSPACE
C WRK0(N)      --> WORKSPACE
C EPSM         --> MACHINE EPSILON
C ITNCNT       --> ITERATION COUNT
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION X(N),G(N),P(N),XPLS(N),SX(N)
      DIMENSION A(NR,1),UDIAG(N)
      DIMENSION SC(N),XPLSP(N),WRK0(N)
      LOGICAL MXTAKE,NWTAKE
      LOGICAL FSTIME
CDPLT EXTERNAL OPTFCN
C
      IRETCD=4
      FSTIME=.TRUE.
      TMP=0.
      DO 5 I=1,N
        TMP=TMP+SX(I)*SX(I)*P(I)*P(I)
    5 CONTINUE
      RNWTLN=SQRT(TMP)
C$    WRITE(IPR,954) RNWTLN
C
      IF(ITNCNT.GT.1) GO TO 100
C     IF(ITNCNT.EQ.1)
C     THEN
        AMU=0.
C
C       IF FIRST ITERATION AND TRUST REGION NOT PROVIDED BY USER,
C       COMPUTE INITIAL TRUST REGION.
C
        IF(DLT.NE. (-1.)) GO TO 100
C       IF(DLT.EQ. (-1.))
C       THEN
          ALPHA=0.
          DO 10 I=1,N
            ALPHA=ALPHA+(G(I)*G(I))/(SX(I)*SX(I))
   10     CONTINUE
          BETA=0.0
          DO 30 I=1,N
            TMP=0.
            DO 20 J=I,N
              TMP=TMP + (A(J,I)*G(J))/(SX(J)*SX(J))
   20       CONTINUE
            BETA=BETA+TMP*TMP
   30     CONTINUE
          DLT=ALPHA*SQRT(ALPHA)/BETA
          DLT = MIN(DLT, STEPMX)
C$        WRITE(IPR,950)
C$        WRITE(IPR,951) ALPHA,BETA,DLT
C       ENDIF
C     ENDIF
C
  100 CONTINUE
C
C FIND NEW STEP BY MORE-HEBDON ALGORITHM
      CALL HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU,
     +     DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR)
      DLTP=DLT
C
C CHECK NEW POINT AND UPDATE TRUST REGION
CDPLT CALL TREGUP(NR,N,X,F,G,A,OPTFCN,SC,SX,NWTAKE,STEPMX,STEPTL,
      CALL TREGUP(NR,N,X,F,G,A,SC,SX,NWTAKE,STEPMX,STEPTL,
     +         DLT,IRETCD,XPLSP,FPLSP,XPLS,FPLS,MXTAKE,IPR,3,UDIAG)
      IF(IRETCD.LE.1) RETURN
      GO TO 100
C
CC950 FORMAT(43H HOOKDR    INITIAL TRUST REGION NOT GIVEN. ,
CC   +       21H COMPUTE CAUCHY STEP.)
CC951 FORMAT(18H HOOKDR    ALPHA =,E20.13/
CC   +       18H HOOKDR    BETA  =,E20.13/
CC   +       18H HOOKDR    DLT   =,E20.13)
CC952 FORMAT(28H HOOKDR    CURRENT STEP (SC))
CC954 FORMAT(18H0HOOKDR    RNWTLN=,E20.13)
CC955 FORMAT(14H HOOKDR       ,5(E20.13,3X))
      END
      SUBROUTINE HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU,
     +     DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C FIND NEW STEP BY MORE-HEBDON ALGORITHM
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C G(N)         --> GRADIENT AT CURRENT ITERATE, G(X)
C A(N,N)       --> CHOLESKY DECOMPOSITION OF HESSIAN IN
C                  LOWER TRIANGULAR PART AND DIAGONAL.
C                  HESSIAN OR APPROX IN UPPER TRIANGULAR PART
C UDIAG(N)     --> DIAGONAL OF HESSIAN IN A(.,.)
C P(N)         --> NEWTON STEP
C SX(N)        --> DIAGONAL SCALING MATRIX FOR N
C RNWTLN       --> NEWTON STEP LENGTH
C DLT         <--> TRUST REGION RADIUS
C AMU         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C DLTP         --> TRUST REGION RADIUS AT LAST EXIT FROM THIS ROUTINE
C PHI         <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C PHIP0       <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS]
C FSTIME      <--> BOOLEAN. =.TRUE. IF FIRST ENTRY TO THIS ROUTINE
C                  DURING K-TH ITERATION
C SC(N)       <--  CURRENT STEP
C NWTAKE      <--  BOOLEAN, =.TRUE. IF NEWTON STEP TAKEN
C WRK0         --> WORKSPACE
C EPSM         --> MACHINE EPSILON
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
      DIMENSION G(N),P(N),SX(N),SC(N),WRK0(N)
      DIMENSION A(NR,1),UDIAG(N)
      LOGICAL NWTAKE,DONE
      LOGICAL FSTIME
C
      PHIP=0.0
C
C HI AND ALO ARE CONSTANTS USED IN THIS ROUTINE.
C CHANGE HERE IF OTHER VALUES ARE TO BE SUBSTITUTED.
      IPR=IPR
      HI=1.5
      ALO=.75
C -----
      IF(RNWTLN.GT.HI*DLT) GO TO 15
C     IF(RNWTLN.LE.HI*DLT)
C     THEN
C
C       TAKE NEWTON STEP
C
        NWTAKE=.TRUE.
        DO 10 I=1,N
          SC(I)=P(I)
   10   CONTINUE
        DLT=MIN(DLT,RNWTLN)
        AMU=0.
C$      WRITE(IPR,951)
        RETURN
C     ELSE
C
C       NEWTON STEP NOT TAKEN
C
   15   CONTINUE
C$      WRITE(IPR,952)
        NWTAKE=.FALSE.
        IF(AMU.LE.0.) GO TO 20
C       IF(AMU.GT.0.)
C       THEN
          AMU=AMU- (PHI+DLTP) *((DLTP-DLT)+PHI)/(DLT*PHIP)
C$        WRITE(IPR,956) AMU
C       ENDIF
   20   CONTINUE
        PHI=RNWTLN-DLT
        IF(.NOT.FSTIME) GO TO 28
C       IF(FSTIME)
C       THEN
          DO 25 I=1,N
            WRK0(I)=SX(I)*SX(I)*P(I)
   25     CONTINUE
C
C         SOLVE L*Y = (SX**2)*P
C
          CALL FORSLV(NR,N,A,WRK0,WRK0)
          PHIP0=-DNRM2(N,WRK0,1)**2/RNWTLN
          FSTIME=.FALSE.
C       ENDIF
   28   PHIP=PHIP0
        AMULO=-PHI/PHIP
        AMUUP=0.0
        DO 30 I=1,N
          AMUUP=AMUUP+(G(I)*G(I))/(SX(I)*SX(I))
   30   CONTINUE
        AMUUP=SQRT(AMUUP)/DLT
        DONE=.FALSE.
C$      WRITE(IPR,956) AMU
C$      WRITE(IPR,959) PHI
C$      WRITE(IPR,960) PHIP
C$      WRITE(IPR,957) AMULO
C$      WRITE(IPR,958) AMUUP
C
C       TEST VALUE OF AMU; GENERATE NEXT AMU IF NECESSARY
C
  100   CONTINUE
        IF(DONE) RETURN
C$      WRITE(IPR,962)
        IF(AMU.GE.AMULO .AND. AMU.LE.AMUUP) GO TO 110
C       IF(AMU.LT.AMULO .OR.  AMU.GT.AMUUP)
C       THEN
          AMU=MAX(SQRT(AMULO*AMUUP),AMUUP*1.0E-3)
C$        WRITE(IPR,956) AMU
C       ENDIF
  110   CONTINUE
C
C       COPY (H,UDIAG) TO L
C       WHERE H <-- H+AMU*(SX**2) [DO NOT ACTUALLY CHANGE (H,UDIAG)]
        DO 130 J=1,N
          A(J,J)=UDIAG(J) + AMU*SX(J)*SX(J)
          IF(J.EQ.N) GO TO 130
          JP1=J+1
          DO 120 I=JP1,N
            A(I,J)=A(J,I)
  120     CONTINUE
  130   CONTINUE
C
C       FACTOR H=L(L+)
C
        CALL CHOLDC(NR,N,A,0.0D0,SQRT(EPSM),ADDMAX)
C
C       SOLVE H*P = L(L+)*SC = -G
C
        DO 140 I=1,N
          WRK0(I)=-G(I)
  140   CONTINUE
        CALL LLTSLV(NR,N,A,SC,WRK0)
C$      WRITE(IPR,955)
C$      WRITE(IPR,963) (SC(I),I=1,N)
C
C       RESET H.  NOTE SINCE UDIAG HAS NOT BEEN DESTROYED WE NEED DO
C       NOTHING HERE.  H IS IN THE UPPER PART AND IN UDIAG, STILL INTACT
C
        STEPLN=0.
        DO 150 I=1,N
          STEPLN=STEPLN + SX(I)*SX(I)*SC(I)*SC(I)
  150   CONTINUE
        STEPLN=SQRT(STEPLN)
        PHI=STEPLN-DLT
        DO 160 I=1,N
          WRK0(I)=SX(I)*SX(I)*SC(I)
  160   CONTINUE
        CALL FORSLV(NR,N,A,WRK0,WRK0)
        PHIP=-DNRM2(N,WRK0,1)**2/STEPLN
C$      WRITE(IPR,961) DLT,STEPLN
C$      WRITE(IPR,959) PHI
C$      WRITE(IPR,960) PHIP
        IF((ALO*DLT.GT.STEPLN .OR. STEPLN.GT.HI*DLT) .AND.
     +       (AMUUP-AMULO.GT.0.)) GO TO 170
C       IF((ALO*DLT.LE.STEPLN .AND. STEPLN.LE.HI*DLT) .OR.
C            (AMUUP-AMULO.LE.0.))
C       THEN
C
C         SC IS ACCEPTABLE HOOKSTEP
C
C$        WRITE(IPR,954)
          DONE=.TRUE.
          GO TO 100
C       ELSE
C
C         SC NOT ACCEPTABLE HOOKSTEP.  SELECT NEW AMU
C
  170     CONTINUE
C$        WRITE(IPR,953)
          AMULO=MAX(AMULO,AMU-(PHI/PHIP))
          IF(PHI.LT.0.) AMUUP=MIN(AMUUP,AMU)
          AMU=AMU-(STEPLN*PHI)/(DLT*PHIP)
C$        WRITE(IPR,956) AMU
C$        WRITE(IPR,957) AMULO
C$        WRITE(IPR,958) AMUUP
          GO TO 100
C       ENDIF
C     ENDIF
C
CC951 FORMAT(27H0HOOKST    TAKE NEWTON STEP)
CC952 FORMAT(32H0HOOKST    NEWTON STEP NOT TAKEN)
CC953 FORMAT(31H HOOKST    SC IS NOT ACCEPTABLE)
CC954 FORMAT(27H HOOKST    SC IS ACCEPTABLE)
CC955 FORMAT(28H HOOKST    CURRENT STEP (SC))
CC956 FORMAT(18H HOOKST    AMU   =,E20.13)
CC957 FORMAT(18H HOOKST    AMULO =,E20.13)
CC958 FORMAT(18H HOOKST    AMUUP =,E20.13)
CC959 FORMAT(18H HOOKST    PHI   =,E20.13)
CC960 FORMAT(18H HOOKST    PHIP  =,E20.13)
CC961 FORMAT(18H HOOKST    DLT   =,E20.13/
CCCCC+       18H HOOKST    STEPLN=,E20.13)
CC962 FORMAT(23H0HOOKST    FIND NEW AMU)
CC963 FORMAT(14H HOOKST       ,5(E20.13,3X))
      END
      SUBROUTINE HORIND(X,XMIN,XMAX,I1,I2,I,IBUGU2,ISUBRO,IERROR)
C
C     PURPOSE--TRANSLATE A FLOATING POINT NUMBER
C              BETWEEN XMIN AND XMAX
C              INTO AN INTEGER INDEX BETWEEN I1 AND I2.
C              THIS IS USED IN REFERENCING ELEMENTS
C              IN HTE HORIZON TABLES USED IN
C              3-D HIDDEN LINE REMOVAL.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               **************************************************
C               **  STEP 11--                                   **
C               **  COMPUTE THE INTEGER INDEX.                  **
C               **************************************************
C
      IERROR='NO'
C
      P=(X-XMIN)/(XMAX-XMIN)
      AI1=I1
      AI2=I2
      AI=AI1+P*(AI2-AI1)
      I=INT(AI+0.5)
C
C               **************************************************
C               **  STEP 90--                                   **
C               **  EXIT.                                       **
C               **************************************************
C
      IF(IBUGU2.EQ.'ON' .OR. ISUBRO.EQ.'NDEX')THEN
        WRITE(ICOUT,9014)X,XMIN,XMAX,I1,I2,I
 9014   FORMAT('FROM HORIND--X,XMIN,XMAX,I1,I2,I = ',3E15.7,3I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE HPSORT (HX, N, STRBEG, STREND, IPERM, KFLAG, WORK, IER)
C***BEGIN PROLOGUE  HPSORT
C***PURPOSE  Return the permutation vector generated by sorting a
C            substring within a character array and, optionally,
C            rearrange the elements of the array.  The array may be
C            sorted in forward or reverse lexicographical order.  A
C            slightly modified quicksort algorithm is used.
C***LIBRARY   SLATEC
C***CATEGORY  N6A1C, N6A2C
C***TYPE      CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H)
C***KEYWORDS  PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING
C***AUTHOR  Jones, R. E., (SNLA)
C           Rhoads, G. S., (NBS)
C           Sullivan, F. E., (NBS)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C   HPSORT returns the permutation vector IPERM generated by sorting
C   the substrings beginning with the character STRBEG and ending with
C   the character STREND within the strings in array HX and, optionally,
C   rearranges the strings in HX.   HX may be sorted in increasing or
C   decreasing lexicographical order.  A slightly modified quicksort
C   algorithm is used.
C
C   IPERM is such that HX(IPERM(I)) is the Ith value in the
C   rearrangement of HX.  IPERM may be applied to another array by
C   calling IPPERM, SPPERM, DPPERM or HPPERM.
C
C   An active sort of numerical data is expected to execute somewhat
C   more quickly than a passive sort because there is no need to use
C   indirect references. But for the character data in HPSORT, integers
C   in the IPERM vector are manipulated rather than the strings in HX.
C   Moving integers may be enough faster than moving character strings
C   to more than offset the penalty of indirect referencing.
C
C   Description of Parameters
C      HX - input/output -- array of type character to be sorted.
C           For example, to sort a 80 element array of names,
C           each of length 6, declare HX as character HX(100)*6.
C           If ABS(KFLAG) = 2, then the values in HX will be
C           rearranged on output; otherwise, they are unchanged.
C      N  - input -- number of values in array HX to be sorted.
C      STRBEG - input -- the index of the initial character in
C               the string HX that is to be sorted.
C      STREND - input -- the index of the final character in
C               the string HX that is to be sorted.
C      IPERM - output -- permutation array such that IPERM(I) is the
C              index of the string in the original order of the
C              HX array that is in the Ith location in the sorted
C              order.
C      KFLAG - input -- control parameter:
C            =  2  means return the permutation vector resulting from
C                  sorting HX in lexicographical order and sort HX also.
C            =  1  means return the permutation vector resulting from
C                  sorting HX in lexicographical order and do not sort
C                  HX.
C            = -1  means return the permutation vector resulting from
C                  sorting HX in reverse lexicographical order and do
C                  not sort HX.
C            = -2  means return the permutation vector resulting from
C                  sorting HX in reverse lexicographical order and sort
C                  HX also.
C      WORK - character variable which must have a length specification
C             at least as great as that of HX.
C      IER - output -- error indicator:
C          =  0  if no error,
C          =  1  if N is zero or negative,
C          =  2  if KFLAG is not 2, 1, -1, or -2,
C          =  3  if work array is not long enough,
C          =  4  if string beginning is beyond its end,
C          =  5  if string beginning is out-of-range,
C          =  6  if string end is out-of-range.
C
C     E X A M P L E  O F  U S E
C
C      CHARACTER*2 HX, W
C      INTEGER STRBEG, STREND
C      DIMENSION HX(10), IPERM(10)
C      DATA (HX(I),I=1,10)/ '05','I ',' I','  ','Rs','9R','R9','89',
C     1     ',*','N"'/
C      DATA STRBEG, STREND / 1, 2 /
C      CALL HPSORT (HX,10,STRBEG,STREND,IPERM,1,W)
C      PRINT 100, (HX(IPERM(I)),I=1,10)
C 100 FORMAT (2X, A2)
C      STOP
C      END
C
C***REFERENCES  R. C. Singleton, Algorithm 347, An efficient algorithm
C                 for sorting with minimal storage, Communications of
C                 the ACM, 12, 3 (1969), pp. 185-187.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   761101  DATE WRITTEN
C   761118  Modified by John A. Wisniewski to use the Singleton
C           quicksort algorithm.
C   811001  Modified by Francis Sullivan for string data.
C   850326  Documentation slightly modified by D. Kahaner.
C   870423  Modified by Gregory S. Rhoads for passive sorting with the
C           option for the rearrangement of the original data.
C   890620  Algorithm for rearranging the data vector corrected by R.
C           Boisvert.
C   890622  Prologue upgraded to Version 4.0 style by D. Lozier.
C   920507  Modified by M. McClain to revise prologue text.
C   920818  Declarations section rebuilt and code restructured to use
C           IF-THEN-ELSE-ENDIF.  (SMR, WRB)
C***END PROLOGUE  HPSORT
C     .. Scalar Arguments ..
      INTEGER IER, KFLAG, N, STRBEG, STREND
      CHARACTER * (*) WORK
C     .. Array Arguments ..
      INTEGER IPERM(*)
      CHARACTER * (*) HX(*)
C     .. Local Scalars ..
      REAL R
      INTEGER I, IJ, INDX, INDX0, IR, ISTRT, J, K, KK, L, LM, LMT, M,
     +        NN, NN2
C     .. Local Arrays ..
      INTEGER IL(21), IU(21)
C     .. External Subroutines ..
CCCCC EXTERNAL XERMSG
C     .. Intrinsic Functions ..
      INTRINSIC ABS, INT, LEN
C
      INCLUDE 'DPCOP2.INC'
C
C***FIRST EXECUTABLE STATEMENT  HPSORT
      IER = 0
      NN = N
      IF (NN .LT. 1) THEN
         IER = 1
         WRITE(ICOUT,999)
  999    FORMAT(1X)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
  901    FORMAT('***** ERROR IN HPSORT (SORTING CHARACTER DATA--')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,903)
  903    FORMAT('      THE NUMBER OF VALUES TO BE SORTED IS ',
     1          'NON-POSITIVE')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      KK = ABS(KFLAG)
      IF (KK.NE.1 .AND. KK.NE.2) THEN
         IER = 2
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,921)
  921    FORMAT('      THE SORT CONTROL PARAMETER HAS AN INVALID ',
     1          'VALUE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
C
      IF(LEN(WORK) .LT. LEN(HX(1))) THEN
         IER = 3
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,931)
  931    FORMAT('      THE LENGTH OF THE WORK VARIABLE IS TOO SHORT.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STRBEG .GT. STREND) THEN
         IER = 4
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,941)STRBEG,STREND
  941    FORMAT('      THE STRING BEGINNING, ',I8,' IS BEYOND ITS ',
     1          'END, ',I8,' .')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STRBEG .LT. 1 .OR. STRBEG .GT. LEN(HX(1))) THEN
         IER = 5
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,951)STRBEG
  951    FORMAT('      THE STRING BEGINNING, ',I8,' IS OUT-OF-RANGE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
      IF (STREND .LT. 1 .OR. STREND .GT. LEN(HX(1))) THEN
         IER = 6
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,901)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,961)STREND
  961    FORMAT('      THE STRING END, ',I8,' IS OUT-OF-RANGE.')
         CALL DPWRST('XXX','BUG ')
         GOTO9999
      ENDIF
C
C     Initialize permutation vector
C
      DO 10 I=1,NN
         IPERM(I) = I
   10 CONTINUE
C
C     Return if only one value is to be sorted
C
      IF (NN .EQ. 1) RETURN
C
C     Sort HX only
C
      M = 1
      I = 1
      J = NN
      R = .375E0
C
   20 IF (I .EQ. J) GO TO 70
      IF (R .LE. 0.5898437E0) THEN
         R = R+3.90625E-2
      ELSE
         R = R-0.21875E0
      ENDIF
C
   30 K = I
C
C     Select a central element of the array and save it in location L
C
      IJ = I + INT((J-I)*R)
      LM = IPERM(IJ)
C
C     If first element of array is greater than LM, interchange with LM
C
      IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) THEN
         IPERM(IJ) = IPERM(I)
         IPERM(I) = LM
         LM = IPERM(IJ)
      ENDIF
      L = J
C
C     If last element of array is less than LM, interchange with LM
C
      IF (HX(IPERM(J))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) THEN
         IPERM(IJ) = IPERM(J)
         IPERM(J) = LM
         LM = IPERM(IJ)
C
C        If first element of array is greater than LM, interchange
C        with LM
C
         IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND))
     +      THEN
               IPERM(IJ) = IPERM(I)
               IPERM(I) = LM
               LM = IPERM(IJ)
         ENDIF
      ENDIF
      GO TO 50
   40 LMT = IPERM(L)
      IPERM(L) = IPERM(K)
      IPERM(K) = LMT
C
C     Find an element in the second half of the array which is smaller
C     than LM
C
   50 L = L-1
      IF (HX(IPERM(L))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND))
     +    GO TO 50
C
C     Find an element in the first half of the array which is greater
C     than LM
C
   60 K = K+1
      IF (HX(IPERM(K))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND))
     +   GO TO 60
C
C     Interchange these elements
C
      IF (K .LE. L) GO TO 40
C
C     Save upper and lower subscripts of the array yet to be sorted
C
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 80
C
C     Begin again on another portion of the unsorted array
C
   70 M = M-1
      IF (M .EQ. 0) GO TO 110
      I = IL(M)
      J = IU(M)
C
   80 IF (J-I .GE. 1) GO TO 30
      IF (I .EQ. 1) GO TO 20
      I = I-1
C
   90 I = I+1
      IF (I .EQ. J) GO TO 70
      LM = IPERM(I+1)
      IF (HX(IPERM(I))(STRBEG:STREND) .LE. HX(LM)(STRBEG:STREND))
     +   GO TO 90
      K = I
C
  100 IPERM(K+1) = IPERM(K)
      K = K-1
C
      IF (HX(LM)(STRBEG:STREND) .LT. HX(IPERM(K))(STRBEG:STREND))
     +    GO TO 100
      IPERM(K+1) = LM
      GO TO 90
C
C     Clean up
C
  110 IF (KFLAG .LE. -1) THEN
C
C        Alter array to get reverse order, if necessary
C
         NN2 = NN/2
         DO 120 I=1,NN2
           IR = NN-I+1
           LM = IPERM(I)
           IPERM(I) = IPERM(IR)
           IPERM(IR) = LM
  120    CONTINUE
      ENDIF
C
C     Rearrange the values of HX if desired
C
      IF (KK .EQ. 2) THEN
C
C        Use the IPERM vector as a flag.
C        If IPERM(I) < 0, then the I-th value is in correct location
C
         DO 140 ISTRT=1,NN
            IF (IPERM(ISTRT) .GE. 0) THEN
               INDX = ISTRT
               INDX0 = INDX
               WORK = HX(ISTRT)
  130          IF (IPERM(INDX) .GT. 0) THEN
                  HX(INDX) = HX(IPERM(INDX))
                  INDX0 = INDX
                  IPERM(INDX) = -IPERM(INDX)
                  INDX = ABS(IPERM(INDX))
                  GO TO 130
               ENDIF
               HX(INDX0) = WORK
            ENDIF
  140    CONTINUE
C
C        Revert the signs of the IPERM values
C
         DO 150 I=1,NN
            IPERM(I) = -IPERM(I)
  150    CONTINUE
C
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HPTRPT(IXC,IYC,ICSTR,NCSTR,ISUBN0)
C
C     PURPOSE--TRANSLATE AN INTEGER PAIR OF COORDINATES
C              (HP MBP = MULTIPLE BYTE PAIR OF NUMBERS)
C              INTO A 5-BYTE PACKED CHARACTER REPRESENTATION
C              THAT WILL BE UNDERSTOOD BY A HEWLETT-PACKARD
C              GRAPHICS DEVICE.
C     NOTE--THE RESULTING PACKED WORDS
C           WILL BE PLACED IN SPECIFIC ELEMENTS
C           OF THE CHARACTER*130 VARIABLE ICSTR(.:.).
C           THE VALUE OF THE VARIABLE    NCSTR
C           REPRESENTS THE NUMBER OF ELEMENTS IN ICSTR(.:.)
C           THAT HAVE ALREADY BEEN FILLED.
C           THE RESULTING PACKED WORDS WILL GO INTO
C           THE NEXT AVAILABLE ELEMENTS OF ICSTR(.:.)
C           AND THE VALUE OF    NCSTR    WILL BE
C           UPDATED ACCORDINGLY.
C     NOTE--MORE COMPACT (1 TO 4-BYTE REPRESENTATIONS)
C           ARE POSSIBLE FOR HP DEVICES FOR SMALLER
C           RANGES (0 TO 3, 0 TO 31, 0 TO 255, AND
C           0 TO 2047, RESPECTIVELY) OF THE INPUT X AND Y
C           COORDINATES.
C           THIS SUBROUTINE IS GENERAL AND TREATS ALL
C           X AND Y VALUES FROM 0 TO 2**14-1 (= 16383).
C           THE OUTPUT WILL THUS ALWAYS BE A 5-BYTE
C           REPRESENTATION.
C     DANGER--NCSTR IS BOTH AN INPUT ARGUMENT
C             AND AN OUTPUT ARGUMENT OF THIS SUBROUTINE.
C     NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED HPTRPT
C                    (AND THEREBY HAVE WALKBACK INFORMATION).
C     REFERENCE--HP 7221 C AND HP 7221T GRAPHICS PLOTTER
C                OPERATING AND PROGRAMMING MANUAL,
C                PAGES 71-72 AND 319.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--83.6
C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH     1984.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------------
C
      CHARACTER*4 ISUBN0
C
      CHARACTER*130 ICSTR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOGR.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-----------------------------------------------
C
      DATA K2/4/
      DATA K4/16/
      DATA K6/64/
      DATA K10/1024/
      DATA K12/4096/
C
C-----START POINT-----------------------------------------------------
C
      IERRG4='NO'
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HPTRPT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBN0
   52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IXC,IYC
   53 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)K2,K4,K6,K10,K12
   55 FORMAT('K2,K4,K6,K10,K12 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,56)IGUNIT
   56 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,63)NCSTR
   63 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO67
      DO65I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,66)I,ICSTR(I:I),IASCNE
   66 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   67 CONTINUE
      WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4
   69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      IVX=IXC
      IVY=IYC
      IF(IVX.LT.0)IVX=0
      IF(IVY.LT.0)IVY=0
C
C               ******************************************************
C               **  STEP 1--                                        **
C               **  FORM THE HIGH-X 7-BIT BYTE--                    **
C               **  THE LEFT 3 BITS ARE 1 1 0;                      **
C               **  THE RIGHT 4 BITS = BITS 13 TO 10 OF X.          **
C               **  SHIFT THE X VALUE TO THE RIGHT 10 PLACES;       **
C               **  THEN KEEP ONLY THE RIGHT 4 PLACES;              **
C               **  THEN PLACE A 1 1 0 IN BITS 6, 5, AND 4          **
C               **  (WHERE BIT 6 = LEFT-MOST BIT IN A 7-BIT BYTE).  **
C               ******************************************************
C
      NCSTR=NCSTR+1
      IBYTE1=MOD(IVX/K10,K4)+96
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE1)
      CALL DPCONA(IBYTE1,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 2--                                                 **
C               **  FORM THE MIDDLE-X 7-BIT BYTE--                           **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 9 TO 4 OF X.                     **
C               **  SHIFT THE X VALUE TO THE RIGHT 4 PLACES;                 **
C               **  THEN KEEP ONLY THE RIGHT 6 PLACES;                       **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE2=MOD(IVX/K4,K6)
      IF(IBYTE2.LE.31)IBYTE2=IBYTE2+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE2)
      CALL DPCONA(IBYTE2,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 3--                                                 **
C               **  FORM THE SHARED (LOW-X, HIGH Y) 7-BIT BYTE--             **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE NEXT 4 BITS = BITS 3 TO 0 OF X;                      **
C               **  THE RIGHT 2 BITS = BITS 13 AND 12 OF Y.                  **
C               **  KEEP ONLY THE RIGHT 4 BITS OF X;                         **
C               **  SHIFT THESE 4 BITS TO THE LEFT 2 PLACES;                 **
C               **  SHIFT THE Y VALUE TO THE RIGHT 12 PLACES;                **
C               **  THEN KEEP ONLY THE RIGHT 2 BITS;                         **
C               **  THEN MERGE THE 4 X BITS AND THE 2 Y BITS;                **
C               **  FINALLY, IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,       **
C               **  OR       IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.       **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE3=MOD(IVX,K4)*K2+MOD(IVY/K12,K2)
      IF(IBYTE3.LE.31)IBYTE3=IBYTE3+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE3)
      CALL DPCONA(IBYTE3,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 4--                                                 **
C               **  FORM THE MIDDLE-Y 7-BIT BYTE--                           **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 11 TO 6 OF Y.                    **
C               **  SHIFT THE Y VALUE 6 PLACES TO THE RIGHT;                 **
C               **  THEN KEEP ONLY THE RIGHT 6 PLACES;                       **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE4=MOD(IVY/K6,K6)
      IF(IBYTE4.LE.31)IBYTE4=IBYTE4+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE4)
      CALL DPCONA(IBYTE4,ICSTR(NCSTR:NCSTR))
C
C               ***************************************************************
C               **  STEP 5--                                                 **
C               **  FORM THE LOW-Y 7-BIT BYTE--                              **
C               **  THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT;  **
C               **  THE RIGHT 6 BITS = BITS 5 TO 0 OF Y.                     **
C               **  KEEP ONLY THE RIGHT 6 BITS OF Y;                         **
C               **  THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6,           **
C               **  OR   IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6.           **
C               ***************************************************************
C
      NCSTR=NCSTR+1
      IBYTE5=MOD(IVY,K6)
      IF(IBYTE5.LE.31)IBYTE5=IBYTE5+64
CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE5)
      CALL DPCONA(IBYTE5,ICSTR(NCSTR:NCSTR))
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO9090
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF TKTRPT--')
      WRITE(ICOUT,9012)IXC,IYC
 9012 FORMAT('IXC,IYC = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IVX,IVY
 9013 FORMAT('IVX,IVY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)K2,K4,K6,K10,K12
 9015 FORMAT('K2,K4,K6,K10,K12 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)IGUNIT
 9016 FORMAT('IGUNIT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5
 9017 FORMAT('IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5 = ',5I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9023)NCSTR
 9023 FORMAT('NCSTR = ',I8)
      CALL DPWRST('XXX','BUG ')
      IF(NCSTR.LE.0)GOTO9027
      DO9025I=1,NCSTR
CCCCC IASCNE=ICHAR(ICSTR(I:I))
      CALL DPCOAN(ICSTR(I:I),IASCNE)
      WRITE(ICOUT,9026)I,ICSTR(I:I),IASCNE
 9026 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8)
      CALL DPWRST('XXX','BUG ')
 9025 CONTINUE
 9027 CONTINUE
      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 HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C***BEGIN PROLOGUE  HQR
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C2B
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues of a real upper Hessenberg matrix
C            using the QR method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR,
C     NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C     This subroutine finds the eigenvalues of a REAL
C     UPPER Hessenberg matrix by the QR method.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        H contains the upper Hessenberg matrix.  Information about
C          the transformations used in the reduction to Hessenberg
C          form by  ELMHES  or  ORTHES, if performed, is stored
C          in the remaining triangle under the Hessenberg matrix.
C
C     On OUTPUT
C
C        H has been destroyed.  Therefore, it must be saved
C          before calling  HQR  if subsequent calculation and
C          back transformation of eigenvectors is to be performed.
C
C        WR and WI contain the real and imaginary parts,
C          respectively, of the eigenvalues.  The eigenvalues
C          are unordered except that complex conjugate pairs
C          of values appear consecutively with the eigenvalue
C          having the positive imaginary part first.  If an
C          error exit is made, the eigenvalues should be correct
C          for indices IERR+1,...,N.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  HQR
C
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N)
      REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2
      LOGICAL NOTLAS
C
      R=0.0
      Q=0.0
      P=0.0
      M=0
C
C***FIRST EXECUTABLE STATEMENT  HQR
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
            NORM = NORM + ABS(H(I,J))
   40    CONTINUE
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
         H(I,I) = H(I,I) - X
  120 CONTINUE
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 WR(EN) = X + T
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      X = X + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C***BEGIN PROLOGUE  HQR2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4C2B
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues and eigenvectors of real upper
C            Hessenberg matrix using QR method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR2,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a REAL UPPER Hessenberg matrix by the QR method.  The
C     eigenvectors of a REAL GENERAL matrix can also be found
C     if  ELMHES  and  ELTRAN  or  ORTHES  and  ORTRAN  have
C     been used to reduce this general matrix to Hessenberg form
C     and to accumulate the similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        LOW and IGH are integers determined by the balancing
C          subroutine  BALANC.  If  BALANC  has not been used,
C          set LOW=1, IGH=N.
C
C        H contains the upper Hessenberg matrix.
C
C        Z contains the transformation matrix produced by  ELTRAN
C          after the reduction by  ELMHES, or by  ORTRAN  after the
C          reduction by  ORTHES, if performed.  If the eigenvectors
C          of the Hessenberg matrix are desired, Z must contain the
C          identity matrix.
C
C     On OUTPUT
C
C        H has been destroyed.
C
C        WR and WI contain the real and imaginary parts,
C          respectively, of the eigenvalues.  The eigenvalues
C          are unordered except that complex conjugate pairs
C          of values appear consecutively with the eigenvalue
C          having the positive imaginary part first.  If an
C          error exit is made, the eigenvalues should be correct
C          for indices IERR+1,...,N.
C
C        Z contains the real and imaginary parts of the eigenvectors.
C          If the I-th eigenvalue is real, the I-th column of Z
C          contains its eigenvector.  If the I-th eigenvalue is complex
C          with positive imaginary part, the I-th and (I+1)-th
C          columns of Z contain the real and imaginary parts of its
C          eigenvector.  The eigenvectors are unnormalized.  If an
C          error exit is made, none of the eigenvectors has been found.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  CDIV
C***END PROLOGUE  HQR2
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN
      INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N),Z(NM,N)
      REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1
      LOGICAL NOTLAS
C
      S=0.0
      R=0.0
      P=0.0
      M=0
C
C***FIRST EXECUTABLE STATEMENT  HQR2
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
            NORM = NORM + ABS(H(I,J))
   40    CONTINUE
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
         H(I,I) = H(I,I) - X
  120 CONTINUE
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, N
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = 1, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
         DO 250 I = LOW, IGH
            P = X * Z(I,K) + Y * Z(I,K+1)
            IF (.NOT. NOTLAS) GO TO 240
            P = P + ZZ * Z(I,K+2)
            Z(I,K+2) = Z(I,K+2) - P * R
  240       Z(I,K+1) = Z(I,K+1) - P * Q
            Z(I,K) = Z(I,K) - P
  250    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      X = H(EN,NA)
      S = ABS(X) + ABS(ZZ)
      P = X / S
      Q = ZZ / S
      R = SQRT(P*P+Q*Q)
      P = P / R
      Q = Q / R
C     .......... ROW MODIFICATION ..........
      DO 290 J = NA, N
         ZZ = H(NA,J)
         H(NA,J) = Q * ZZ + P * H(EN,J)
         H(EN,J) = Q * H(EN,J) - P * ZZ
  290 CONTINUE
C     .......... COLUMN MODIFICATION ..........
      DO 300 I = 1, EN
         ZZ = H(I,NA)
         H(I,NA) = Q * ZZ + P * H(I,EN)
         H(I,EN) = Q * H(I,EN) - P * ZZ
  300 CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
      DO 310 I = LOW, IGH
         ZZ = Z(I,NA)
         Z(I,NA) = Q * ZZ + P * Z(I,EN)
         Z(I,EN) = Q * Z(I,EN) - P * ZZ
  310 CONTINUE
C
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  340 IF (NORM .EQ. 0.0E0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
      DO 800 NN = 1, N
         EN = N + 1 - NN
         P = WR(EN)
         Q = WI(EN)
         NA = EN - 1
CCCCC    IF (Q) 710, 600, 800
         IF (Q.LT.0.) THEN
            GOTO710
         ELSEIF (Q.EQ.0.) THEN
            GOTO600
         ELSE
            GOTO800
         ENDIF
C     .......... REAL VECTOR ..........
  600    M = EN
         H(EN,EN) = 1.0E0
         IF (NA .EQ. 0) GO TO 800
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 700 II = 1, NA
            I = EN - II
            W = H(I,I) - P
            R = H(I,EN)
            IF (M .GT. NA) GO TO 620
C
            DO 610 J = M, NA
               R = R + H(I,J) * H(J,EN)
  610       CONTINUE
C
  620       IF (WI(I) .GE. 0.0E0) GO TO 630
            ZZ = W
            S = R
            GO TO 700
  630       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 640
            T = W
            IF (T .NE. 0.0E0) GO TO 635
            T = NORM
  632       T = 0.5E0*T
            IF (NORM + T .GT. NORM) GO TO 632
            T = 2.0E0*T
  635       H(I,EN) = -R / T
            GO TO 700
C     .......... SOLVE REAL EQUATIONS ..........
  640       X = H(I,I+1)
            Y = H(I+1,I)
            Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
            T = (X * S - ZZ * R) / Q
            H(I,EN) = T
            IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
            H(I+1,EN) = (-R - W * T) / X
            GO TO 700
  650       H(I+1,EN) = (-S - Y * T) / ZZ
  700    CONTINUE
C     .......... END REAL VECTOR ..........
         GO TO 800
C     .......... COMPLEX VECTOR ..........
  710    M = NA
C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
         IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
         H(NA,NA) = Q / H(EN,NA)
         H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
         GO TO 730
  720    CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
  730    H(EN,NA) = 0.0E0
         H(EN,EN) = 1.0E0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 800
C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
         DO 790 II = 1, ENM2
            I = NA - II
            W = H(I,I) - P
            RA = 0.0E0
            SA = H(I,EN)
C
            DO 760 J = M, NA
               RA = RA + H(I,J) * H(J,NA)
               SA = SA + H(I,J) * H(J,EN)
  760       CONTINUE
C
            IF (WI(I) .GE. 0.0E0) GO TO 770
            ZZ = W
            R = RA
            S = SA
            GO TO 790
  770       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 780
            CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
            GO TO 790
C     .......... SOLVE COMPLEX EQUATIONS ..........
  780       X = H(I,I+1)
            Y = H(I+1,I)
            VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
            VI = (WR(I) - P) * 2.0E0 * Q
            IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 783
            S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ))
            VR = S1
  782       VR = 0.5E0*VR
            IF (S1 + VR .GT. S1) GO TO 782
            VR = 2.0E0*VR
  783       CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
     1                H(I,NA),H(I,EN))
            IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
            H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
            H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
            GO TO 790
  785       CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
     1                H(I+1,NA),H(I+1,EN))
  790    CONTINUE
C     .......... END COMPLEX VECTOR ..........
  800 CONTINUE
C     .......... END BACK SUBSTITUTION.
C                VECTORS OF ISOLATED ROOTS ..........
      DO 840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
            Z(I,J) = H(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 885 I = LOW, IGH
            ZZ = 0.0E0
C
            DO 860 K = LOW, M
               ZZ = ZZ + Z(I,K) * H(K,J)
  860       CONTINUE
C
            Z(I,J) = ZZ
  885    CONTINUE
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE HSECDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C----COMMON-----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA PI / 3.1415926535/
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.80.0)THEN
        CDF=1.0
        GOTO9999
      ELSEIF(X.LT.-80.0)THEN
        CDF=0.0
        GOTO9999
      ELSE
        ARG=X/2.0
        TERM1=(EXP(ARG)-EXP(-ARG))/(EXP(ARG)+EXP(-ARG))
        CDF=0.5 + (2.0/PI)*ATAN(TERM1)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE HSEPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = SECH(X)/PI
C                   = (1/PI)*(2/(EXP(X) + EXP(-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DPDF, DPI
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C---------------------------------------------------------------------
C
      DX=DBLE(X)
      IF(DABS(DX).GT.500.0D0)THEN
        PDF=0.0
      ELSE
        DPDF=2.0D0/(DEXP(DX) + DEXP(-DX))
        PDF=SNGL(DPDF/DPI)
      ENDIF
C
      RETURN
      END
      SUBROUTINE HSEPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION
C              THE PROBABILITY DENSITY FUNCTION IS
C              F(X) = SECH(X)/PI
C                   = (1/PI)*(2/(EXP(X) + EXP(-X))
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 147
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95.10
C     ORIGINAL VERSION--OCTOBER   1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DPPF
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HSEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DARG=DPI*(DBLE(P)-0.5D0)/2.0D0
      DTERM1=DTAN(DARG)
      DPPF=DLOG((1.0+DTERM1)/(1.0D0-DTERM1))
      PPF=SNGL(DPPF)
C
      RETURN
      END
      SUBROUTINE HSERAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE HYPERBOLIC SECANT DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE HYPERBOLIC SECANT DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'HSERAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N HYPERBOLIC SECANT RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      CALL HSEPPF(X(I),XTEMP)
      X(I)=XTEMP
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE HSNINT(NR,N,A,SX,METHOD)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C PROVIDE INITIAL HESSIAN WHEN USING SECANT UPDATES
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)      <--  INITIAL HESSIAN (LOWER TRIANGULAR MATRIX)
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C METHOD       --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM
C                    =1,2 FACTORED SECANT METHOD USED
C                    =3   UNFACTORED SECANT METHOD USED
C
      DIMENSION A(NR,1),SX(N)
C
      DO 100 J=1,N
        IF(METHOD.EQ.3) A(J,J)=SX(J)*SX(J)
        IF(METHOD.NE.3) A(J,J)=SX(J)
        IF(J.EQ.N) GO TO 100
        JP1=J+1
        DO 90 I=JP1,N
          A(I,J)=0.D0
   90   CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE HTTSQ1(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,
     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
     1DMEAN,Y1,Y2,Y3,INDEX,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              1-SAMPLE HOTELLING T-SQUARE STATISTIC.
C              HO: U = U0
C              T2=N*(XBAR-U0)'*SINV*(XBAR-U0)
C     INPUT  ARGUMENTS--AMAT1  = THE ORIGINAL SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT1
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT1
C                     --Y1     = VECTOR CONTAINING HYPOTHESIZED MEANS
C                     --Y2     = DUMMY VECTOR CONTAINING SAMPLE MEANS
C     OUTPUT ARGUMENTS--AMAT2  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED INVERTED VARIANCE-COVARIANCE
C                                MATRIX
C                     --TSTAT  = VALUE OF HOTELLING T-SQUARE
C                     --ASIG90 = CRITICAL VALUE FOR ALPHA = .90
C                     --ASIG95 = CRITICAL VALUE FOR ALPHA = .95
C                     --ASIG99 = CRITICAL VALUE FOR ALPHA = .99
C                     --ASG995= CRITICAL VALUE FOR ALPHA = .995
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             HOTELLING T-SQUARE VALUE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HOTT'
      ISUBN2='SQ  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HTTSQ1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,NC1
      WRITE(ICOUT,56)I,Y1(I)
   56 FORMAT('I,Y(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE HOTELLING T-SQUARE  **
C               **********************************
C
      ICASE='COLU'
      CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
      CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y2)
C
      IF(1.0+RCOND.EQ.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5171)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5172)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5173)
        CALL DPWRST('XXX','ERRO ')
        IERROR='YES'
        GOTO9000
      ENDIF
 5171 FORMAT('*** ERROR FROM HTTSQ1: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1       ' OTHER COLUMNS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
      IJOB=1
      CALL SGEDI(AMAT2,MAXROM,NC1,INDEX,Y2,Y3,IJOB)
C
      DO6000I=1,NC1
        DO6110J=1,NR1
          Y2(J)=AMAT1(J,I)
 6110   CONTINUE
        CALL MEAN(Y2,NR1,IWRITE,XMEAN,IBUGA3,IERROR)
        Y3(I)=XMEAN-Y1(I)
 6000 CONTINUE
      CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,
     1            XQUAD,IBUGA3,IERROR)
      TSTAT=REAL(NR1)*XQUAD
C
      AFACT=REAL(NC1*(NR1-1)/(NR1-NC1))
      CALL FPPF(0.90,NC1,NR1-NC1,ATEMP1)
      ASIG90=AFACT*ATEMP1
      CALL FPPF(0.95,NC1,NR1-NC1,ATEMP1)
      ASIG95=AFACT*ATEMP1
      CALL FPPF(0.99,NC1,NR1-NC1,ATEMP1)
      ASIG99=AFACT*ATEMP1
      CALL FPPF(0.995,NC1,NR1-NC1,ATEMP1)
      ASG995=AFACT*ATEMP1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HTTSQ1--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HTTSQ2(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NR2,NC1,
     1TSTAT,ASIG90,ASIG95,ASIG99,ASG995,
     1DMEAN,Y1,Y2,Y3,INDEX,
     1IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              2-SAMPLE HOTELLING T-SQUARE STATISTIC.
C              HO: U1 = U2
C              T2=N1*N2*(XBAR1-XBAR2)'*SINV*(XBAR1-XBAR2)/(N1+N2)
C              WHERE SINV IS THE INVERSE OF THE POOLED COVARIANCE
C              MATRIX.
C     INPUT  ARGUMENTS--AMAT1  = THE SAMPLE 1 SINGLE PRECISION MATRIX
C                     --AMAT2  = THE SAMPLE 2 SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT1
C                     --NR2    = THE INTEGER NUMBER OF ROWS OF AMAT2
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT1
C                     --Y1     = DUMMY VECTOR CONTAINING SAMPLE 1 MEANS
C                     --Y2     = DUMMY VECTOR CONTAINING SAMPLE 2 MEANS
C     OUTPUT ARGUMENTS--AMAT3  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED INVERTED VARIANCE-COVARIANCE
C                                MATRIX
C                     --TSTAT  = VALUE OF HOTELLING T-SQUARE
C                     --ASIG90 = CRITICAL VALUE FOR ALPHA = .90
C                     --ASIG95 = CRITICAL VALUE FOR ALPHA = .95
C                     --ASIG99 = CRITICAL VALUE FOR ALPHA = .99
C                     --ASG995= CRITICAL VALUE FOR ALPHA = .995
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             HOTELLING T-SQUARE VALUE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='HTTS'
      ISUBN2='Q2  '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF HTTSQ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NR2,NC1
   53 FORMAT('NR1, NR2, NC1 = ',3I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE HOTELLING T-SQUARE  **
C               **********************************
C
      CALL VARPOO(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,NR2,
     1            DMEAN,IBUGA3,IERROR)
      CALL SGECO(AMAT3,MAXROM,NC1,INDEX,RCOND,Y1)
C
      IF(1.0+RCOND.EQ.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5171)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5172)
        CALL DPWRST('XXX','ERRO ')
        WRITE(ICOUT,5173)
        CALL DPWRST('XXX','ERRO ')
        IERROR='YES'
        GOTO9000
      ENDIF
 5171 FORMAT('*** ERROR FROM HTTSQ2: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE POOLED COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ',
     1       ' OTHER COLUMNS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL COLUMNS.')
C
      IJOB=1
      CALL SGEDI(AMAT3,MAXROM,NC1,INDEX,Y1,Y2,IJOB)
C
      DO6000I=1,NC1
        DO6110J=1,NR1
          Y1(J)=AMAT1(J,I)
 6110   CONTINUE
        DO6120J=1,NR2
          Y2(J)=AMAT2(J,I)
 6120   CONTINUE
        CALL MEAN(Y1,NR1,IWRITE,XMEAN1,IBUGA3,IERROR)
        CALL MEAN(Y2,NR2,IWRITE,XMEAN2,IBUGA3,IERROR)
        Y3(I)=XMEAN1-XMEAN2
 6000 CONTINUE
      CALL QUAFRM(AMAT3,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE,
     1            XQUAD,IBUGA3,IERROR)
      TSTAT=REAL(NR1*NR2)*XQUAD/REAL(NR1+NR2)
C
      AFACT=REAL((Nr1+NR2-NC1-1)/((NR1+NR2-2)*NC1))
      CALL FPPF(0.90,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG90=AFACT*ATEMP1
      CALL FPPF(0.95,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG95=AFACT*ATEMP1
      CALL FPPF(0.99,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASIG99=AFACT*ATEMP1
      CALL FPPF(0.995,NC1,NR1+NR2-NC1-1,ATEMP1)
      ASG995=AFACT*ATEMP1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF HTTSQ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE HYGFX(A,B,C,X,HF,IERROR)
C
C       ====================================================
C       Purpose: Compute hypergeometric function F(a,b,c,x)
C       Input :  a --- Parameter
C                b --- Parameter
C                c --- Parameter, c <> 0,-1,-2,...
C                x --- Argument   ( x < 1 )
C       Output:  HF --- F(a,b,c,x)
C                IERROR--ERROR FLAG
C       Routines called:
C            (1) GAMMA for computing gamma function
C            (2) PSI for computing psi function
C       ====================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        LOGICAL L0,L1,L2,L3,L4,L5
C
        HW=0.0D0
        NM=0
C
        PI=3.141592653589793D0
        EL=.5772156649015329D0
        L0=C.EQ.INT(C).AND.C.LT.0.0
        L1=1.0D0-X.LT.1.0D-15.AND.C-A-B.LE.0.0
        L2=A.EQ.INT(A).AND.A.LT.0.0
        L3=B.EQ.INT(B).AND.B.LT.0.0
        L4=C-A.EQ.INT(C-A).AND.C-A.LE.0.0
        L5=C-B.EQ.INT(C-B).AND.C-B.LE.0.0
        IF (L0) THEN
           IERROR=1
CCCCC      WRITE(*,*)'The hypergeometric series is divergent'
           RETURN
        ENDIF
        IF (L1) THEN
           IERROR=2
CCCCC      WRITE(*,*)'The hypergeometric series is divergent'
           RETURN
        ENDIF
        EPS=1.0D-15
        IF (X.GT.0.95) EPS=1.0D-8
        IF (X.EQ.0.0.OR.A.EQ.0.0.OR.B.EQ.0.0) THEN
           HF=1.0D0
           RETURN
        ELSE IF (1.0D0-X.EQ.EPS.AND.C-A-B.GT.0.0) THEN
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC      CALL GAMMA(C,GC)
CCCCC      CALL GAMMA(C-A-B,GCAB)
CCCCC      CALL GAMMA(C-A,GCA)
CCCCC      CALL GAMMA(C-B,GCB)
           GC=DGAMMA(C)
           GCAB=DGAMMA(C-A-B)
           GCA=DGAMMA(C-A)
           GCB=DGAMMA(C-B)
           HF=GC*GCAB/(GCA*GCB)
           RETURN
        ELSE IF (1.0D0+X.LE.EPS.AND.DABS(C-A+B-1.0).LE.EPS) THEN
           G0=DSQRT(PI)*2.0D0**(-A)
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC      CALL GAMMA(C,G1)
CCCCC      CALL GAMMA(1.0D0+A/2.0-B,G2)
CCCCC      CALL GAMMA(0.5D0+0.5*A,G3)
           G1=DGAMMA(C)
           G2=DGAMMA(1.0D0+A/2.0-B)
           G3=DGAMMA(0.5D0+0.5*A)
           HF=G0*G1/(G2*G3)
           RETURN
        ELSE IF (L2.OR.L3) THEN
           IF (L2) NM=INT(ABS(A))
           IF (L3) NM=INT(ABS(B))
           HF=1.0D0
           R=1.0D0
           DO 10 K=1,NM
              R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
              HF=HF+R
10         CONTINUE
           RETURN
        ELSE IF (L4.OR.L5) THEN
           IF (L4) NM=INT(ABS(C-A))
           IF (L5) NM=INT(ABS(C-B))
           HF=1.0D0
           R=1.0D0
           DO 15 K=1,NM
              R=R*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*X
              HF=HF+R
15         CONTINUE
           HF=(1.0D0-X)**(C-A-B)*HF
           RETURN
        ENDIF
        AA=A
        BB=B
        X1=X
        IF (X.LT.0.0D0) THEN
           X=X/(X-1.0D0)
           IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN
              A=BB
              B=AA
           ENDIF
           B=C-B
        ENDIF
        IF (X.GE.0.75D0) THEN
           GM=0.0D0
           IF (DABS(C-A-B-INT(C-A-B)).LT.1.0D-15) THEN
              M=INT(C-A-B)
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC         CALL GAMMA(A,GA)
CCCCC         CALL GAMMA(B,GB)
CCCCC         CALL GAMMA(C,GC)
CCCCC         CALL GAMMA(A+M,GAM)
CCCCC         CALL GAMMA(B+M,GBM)
              GA=DGAMMA(A)
              GB=DGAMMA(B)
              GC=DGAMMA(C)
              GAM=DGAMMA(A+M)
              GBM=DGAMMA(B+M)
CCCCC USE CMLIB DPSI ROUTINE
CCCCC         CALL PSI(A,PA)
CCCCC         CALL PSI(B,PB)
              PA=DPSI(A)
              PB=DPSI(B)
              IF (M.NE.0) GM=1.0D0
              DO 30 J=1,ABS(M)-1
                 GM=GM*J
30            CONTINUE
              RM=1.0D0
              DO 35 J=1,ABS(M)
                 RM=RM*J
35            CONTINUE
              F0=1.0D0
              R0=1.0D0
              R1=1.0D0
              SP0=0.D0
              SP=0.0D0
              IF (M.GE.0) THEN
                 C0=GM*GC/(GAM*GBM)
                 C1=-GC*(X-1.0D0)**M/(GA*GB*RM)
                 DO 40 K=1,M-1
                    R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(K-M))*(1.0-X)
                    F0=F0+R0
40               CONTINUE
                 DO 45 K=1,M
                    SP0=SP0+1.0D0/(A+K-1.0)+1.0/(B+K-1.0)-1.0/K
45               CONTINUE
                 F1=PA+PB+SP0+2.0D0*EL+DLOG(1.0D0-X)
                 DO 55 K=1,250
                    SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                    SM=0.0D0
                    DO 50 J=1,M
                       SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0))+1.0/
     &                    (B+J+K-1.0)
50                  CONTINUE
                    RP=PA+PB+2.0D0*EL+SP+SM+DLOG(1.0D0-X)
                    R1=R1*(A+M+K-1.0D0)*(B+M+K-1.0)/(K*(M+K))*(1.0-X)
                    F1=F1+R1*RP
                    IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 60
                    HW=F1
55               CONTINUE
60               HF=F0*C0+F1*C1
              ELSE IF (M.LT.0) THEN
                 M=-M
                 C0=GM*GC/(GA*GB*(1.0D0-X)**M)
                 C1=-(-1)**M*GC/(GAM*GBM*RM)
                 DO 65 K=1,M-1
                    R0=R0*(A-M+K-1.0D0)*(B-M+K-1.0)/(K*(K-M))*(1.0-X)
                    F0=F0+R0
65               CONTINUE
                 DO 70 K=1,M
                    SP0=SP0+1.0D0/K
70               CONTINUE
                 F1=PA+PB-SP0+2.0D0*EL+DLOG(1.0D0-X)
                 DO 80 K=1,250
                    SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0))
                    SM=0.0D0
                    DO 75 J=1,M
                       SM=SM+1.0D0/(J+K)
75                  CONTINUE
                    RP=PA+PB+2.0D0*EL+SP-SM+DLOG(1.0D0-X)
                    R1=R1*(A+K-1.0D0)*(B+K-1.0)/(K*(M+K))*(1.0-X)
                    F1=F1+R1*RP
                    IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 85
                    HW=F1
80               CONTINUE
85               HF=F0*C0+F1*C1
              ENDIF
           ELSE
CCCCC USE CMLIB DGAMMA ROUTINE
CCCCC         CALL GAMMA(A,GA)
CCCCC         CALL GAMMA(B,GB)
CCCCC         CALL GAMMA(C,GC)
CCCCC         CALL GAMMA(C-A,GCA)
CCCCC         CALL GAMMA(C-B,GCB)
CCCCC         CALL GAMMA(C-A-B,GCAB)
CCCCC         CALL GAMMA(A+B-C,GABC)
              GA=DGAMMA(A)
              GB=DGAMMA(B)
              GC=DGAMMA(C)
              GCA=DGAMMA(C-A)
              GCB=DGAMMA(C-B)
              GCAB=DGAMMA(C-A-B)
              GABC=DGAMMA(A+B-C)
              C0=GC*GCAB/(GCA*GCB)
              C1=GC*GABC/(GA*GB)*(1.0D0-X)**(C-A-B)
              HF=0.0D0
              R0=C0
              R1=C1
              DO 90 K=1,250
                 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(A+B-C+K))*(1.0-X)
                 R1=R1*(C-A+K-1.0D0)*(C-B+K-1.0)/(K*(C-A-B+K))
     &              *(1.0-X)
                 HF=HF+R0+R1
                 IF (DABS(HF-HW).LT.DABS(HF)*EPS) GO TO 95
                 HW=HF
90            CONTINUE
95            HF=HF+C0+C1
           ENDIF
        ELSE
           A0=1.0D0
           IF (C.GT.A.AND.C.LT.2.0D0*A.AND.
     &         C.GT.B.AND.C.LT.2.0D0*B) THEN
              A0=(1.0D0-X)**(C-A-B)
              A=C-A
              B=C-B
           ENDIF
           HF=1.0D0
           R=1.0D0
           DO 100 K=1,250
              R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X
              HF=HF+R
              IF (DABS(HF-HW).LE.DABS(HF)*EPS) GO TO 105
              HW=HF
100        CONTINUE
105        HF=A0*HF
        ENDIF
        IF (X1.LT.0.0D0) THEN
           X=X1
           C0=1.0D0/(1.0D0-X)**AA
           HF=C0*HF
        ENDIF
        A=AA
        B=BB
        IF (K.GT.120) THEN
CCCCC     WRITE(*,115)
C115      FORMAT(1X,'Warning! You should check the accuracy')
          IERROR=3
        ENDIF
        RETURN
        END
      SUBROUTINE HYPCDF(LL,KK,NN,MM,POINT,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE INTEGER VALUE LL
C              FOR THE HYPERGEOMETRIC DISTRIBUTION.
C              THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF
C              SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE
C              KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF
C              MM ITEMS, NN OF WHICH ARE MARKED.  IT HAS CDF OF:
C                 CDF = P(X<= LL | KK, NN, MM)
C     INPUT  ARGUMENTS--LL     = THE INTEGER VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                IT SHOULD BE INTEGRAL-VALUED,
C                                AND BETWEEN 0.0 (INCLUSIVELY)
C                                AND MM (INCLUSIVELY).
C                     --KK     = THE INTEGER VALUE INDICATING THE
C                                SAMPLE SIZE.
C                     --NN     = THE NUMBER OF MARKED ITEMS IN THE
C                                POPULATION.
C                     --MM     = THE POPULATION SIZE.
C                     --POINT  = LOGICAL VARIABLE THAT SPECIFIES
C                                WHETHER THE CDF OR PDF SHOULD BE
C                                COMPUTED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--LL SHOULD BE INTEGRAL-VALUED,
C                   AND BETWEEN 0 AND MM (INCLUSIVELY)
C                 --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C                 --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C     OTHER SUBROUTINES NEEDED--NORCDF, DLNGAM
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--THIS ROUTINE USES ALGORITHM AS R77 FROM THE
C              APPLIED STATISTICS JOURNAL. CODE RETRIEVED FROM STATLIB.
C
C     ALGORITHM AS R77  APPL. STATIST. (1989), VOL.38, NO.1
C     Replaces AS 59 and AS 152
C     Incorporates AS R86 from vol.40(2)
C
C     Auxiliary routines required: ALNFAC (AS 245), ALNORM (AS 66)
C
C     REFERENCES--HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C               --JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969.
C               --REMARK AS R77, AS152, AND AS59 FROM THE APPLIED
C                 STATISTICS JOURNAL.
C               --"THE ACCURACY OF PIEZER APPROXIMATIONS TO THE
C                 HYPERGEOMETRIC DISTRIBUTION, WITH COMPARISONS TO
C                 SOME OTHER APPROXIMATIONS", LING AND PRATT, JASA,
C                 MARCH, 1984.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER  KK, LL, MM, NN, K, L, M, N, I, J, NL, KL,
     *         MNKL, MVBIG, MBIG
CCCCC DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT, MEAN,
CCCCC*                 SIG, SXTEEN, SCALE, ROOTPI, ARG, HUNDRD, DCDF,
      DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT,
     *                 SXTEEN, SCALE, ROOTPI, HUNDRD, DCDF,
     *                 XMAX,XMAXT,DTERM1,
     *                 DTERM2,DTERM3,DTERM4,DTERM5,DTERM6,DTERM7,DTERM8
      DOUBLE PRECISION P1, P2, A, B, C, D, DCDF2
      LOGICAL   POINT, DIR
      PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, MVBIG = 1000,
     *           MBIG = 600, SXTEEN = 16.0D0,
     *           ROOTPI = 2.50662 82746 31001D0,
     *           HUNDRD = 100.0D0)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
      IF(NN.LE.0.OR.NN.GT.MM)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE THIRD ARGUMENT TO HYPCDF ',
     1         '(THE NUMBER OF MARKED ITEMS)')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1         'SIZE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NN
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(KK.LE.0.OR.KK.GT.MM)THEN
        WRITE(ICOUT,21)
   21   FORMAT('***** ERROR--THE SECOND ARGUMENT TO HYPCDF ',
     1         '(THE SAMPLE SIZE)')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE POULATION ',
     1         'SIZE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)KK
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(LL.LT.0.OR.KK-LL.GT.MM-NN)THEN
        WRITE(ICOUT,31)MM-NN
   31   FORMAT('***** WARNING--THE FIRST INPUT ARGUMENT TO ',
     1         'HYPCDF IS OUTSIDE THE (0,',I8,') INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LL
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(LL.GT.NN.OR.LL.GT.KK)THEN
        WRITE(ICOUT,41)
   41   FORMAT('***** WARNING--THE FIRST ARGUMENT TO HYPCDF ',
     1         'IS GREATER THAN THE SAMPLE SIZE ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,42)
   42   FORMAT('      OR GREATER THAN THE NUMBER OF MARKED ITEMS.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LL
        CALL DPWRST('XXX','BUG ')
        IF(.NOT.POINT)CDF=1.0
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
C  CALCULATE EXPONENTIAL LIMIT FOR UNDERFLOW
C
      XMAXT = -DLOG(D1MACH(1))
      XMAX = XMAXT - 0.5D0*XMAXT*DLOG(XMAXT)/(XMAXT+0.5D0) - 0.01D0
      ELIMIT=-XMAX
      SCALE = D1MACH(1) + 1000.D0*D1MACH(3)
C
C     TREAT IMMEDIATELY THE SPECIAL CASES WHICH RETURN A VALUE OF
C     0 OR 1.
C
      K = KK + 1
      L = LL + 1
      M = MM + 1
      N = NN + 1
      DIR = .TRUE.
      DCDF = ONE
      IF (K .EQ. 1 .OR. K .EQ. M .OR. N .EQ. 1 .OR. N .EQ. M) GOTO9999
      IF (.NOT. POINT .AND. LL .EQ. MIN(KK, NN)) GOTO9999
C
      P = DBLE(NN) / DBLE(MM - NN)
C
C     Use a normal approximation for sufficently large arguments
C
C     THE NORMAL APPROXIMATION HERE DOES NOT SEEM TO PRODUCE
C     PARTICULARLY ACCURATE RESULTS.  USE A BINOMIAL APPROXIMATION
C     INSTEAD (TAKEN FROM LING AND PRATT ARTICLE IN REFERENCE).
CCCCC IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND.
CCCCC*   MM .GT. MVBIG .AND. ELIMIT .GT. -HUNDRD) THEN
      IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND.
     *   MM .GT. MVBIG ) THEN
        K=KK
        M=MM
        N=NN
        L=LL
        IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN
          I = K
          K = N
          N = I
        END IF
        IF (M-K .LT. K-1) THEN
          DIR = .NOT. DIR
          L = N - L + 1
          K = M - K + 1
        END IF
CCCCC   MEAN = DBLE(K) * DBLE(N) / DBLE(M)
CCCCC   SIG = DSQRT(MEAN*(DBLE(M-N)/DBLE(M))*(DBLE(M-K)/(DBLE(M-1))))
CCCCC   IF (POINT) THEN
CCCCC     ARG = -HALF * (((DBLE(L) - MEAN) / SIG)**2)
CCCCC     DCDF = ZERO
CCCCC     IF (ARG .GE. ELIMIT) DCDF = DEXP(ARG)/(SIG*ROOTPI)
CCCCC   ELSE
CCCCC     DTERM1=(DBLE(L)+HALF-MEAN)/SIG
CCCCC     CALL NORCDF(SNGL(DTERM1),CDF)
CCCCC     DCDF = DBLE(CDF)
CCCCC     IF(.NOT.DIR)DCDF=1.0D0 - DCDF
CCCCC   END IF
C
C     BINOMIAL APPROXIMATION.
C
        A=DBLE(L)
        B=DBLE(K-L)
        C=DBLE(N-L)
        D=DBLE(M+L-N-K)
        P1=DBLE(2*N-L)/DBLE(2*M-K+1)
        DTERM1=DBLE(K+1)*(A*P1-(B-1.0D0)*(1.0D0-P1))
        DTERM2=-A*(A+2.0D0)/P1 + (B**2-1.0D0)/(1.0D0-P1)
        DTERM3=6.0D0*(2.0D0*DBLE(M)-DBLE(K)+1.0D0)**2
        P2=P1+(DTERM1+DTERM2)/DTERM3
        AP1=SNGL(P1)
        AP2=SNGL(P2)
        AX=REAL(L)
        IF (POINT) THEN
          CALL BINCDF(DBLE(AX),DBLE(AP2),K,DCDF)
          IF(AX.GT.0.1)THEN
            AX=AX-1.0
            CALL BINCDF(DBLE(AX),DBLE(AP2),K,DCDF2)
            DCDF=DCDF-DCDF2
          ENDIF
        ELSE
          CALL BINCDF(DBLE(AX),DBLE(AP2),K,DCDF)
          IF(.NOT.DIR) DCDF=1.0D0-DCDF
        ENDIF
C
C     Calculate exact hypergeometric probabilities.
C     Interchange K and N if this saves calculations.
C
      ELSE
        IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN
          I = K
          K = N
          N = I
        END IF
        IF (M-K .LT. K-1) THEN
          DIR = .NOT. DIR
          L = N - L + 1
          K = M - K + 1
        END IF
        IF (MM .GT. MBIG) THEN
C
C     Take logarithms of factorials.
C     Use fact that GAMMA(N)=(N-1)!.  USE DLNGAM function.
C
CCCCC     P = ALNFAC(NN) - ALNFAC(MM) + ALNFAC(MM-KK) + ALNFAC(KK) +
CCCCC*        ALNFAC(MM-NN)-ALNFAC(LL)-ALNFAC(NN-LL)-ALNFAC(KK-LL)
CCCCC*        - ALNFAC(MM-NN-KK+LL)
CCCCC     P = DLNGAM(DBLE(NN-1)) - DLNGAM(DBLE(MM-1)) +
CCCCC*        DLNGAM(DBLE(MM-KK-1)) + DLNGAM(DBLE(KK-1)) +
CCCCC*        DLNGAM(DBLE(MM-NN-1)) - DLNGAM(DBLE(LL-1)) -
CCCCC*        DLNGAM(DBLE(NN-LL-1)) - DLNGAM((KK-LL-1)) -
CCCCC*        DLNGAM(DBLE(MM-NN-KK+LL-1))
          DTERM1=DLNGAM(DBLE(NN+1))
          DTERM2=DLNGAM(DBLE(MM+1))
          DTERM3=DLNGAM(DBLE(MM-KK+1))
          DTERM4=DLNGAM(DBLE(KK+1))
          DTERM5=DLNGAM(DBLE(MM-NN+1))
          DTERM6=DLNGAM(DBLE(LL+1))
          DTERM7=DLNGAM(DBLE(NN-LL+1))
          DTERM8=DLNGAM(DBLE(KK-LL+1))
          DTERM9=DLNGAM(DBLE(MM-NN-KK+LL+1))
          P=DTERM1-DTERM2+DTERM3+DTERM4+DTERM5-
     *      DTERM6-DTERM7-DTERM8-DTERM9
          DCDF = ZERO
          IF (P .GE. ELIMIT) DCDF = DEXP(P)
C
C     Use Freeman/Lund algorithm
C
        ELSE
          DO 3 I = 1, L-1
            DCDF= DCDF*DBLE(K-I)*DBLE(N-I)/(DBLE(L-I)*DBLE(M-I))
    3     CONTINUE
          IF (L .NE. K) THEN
            J = M - N + L
            DO 5 I = L, K-1
              DCDF = DCDF * DBLE(J-I) / DBLE(M-I)
    5       CONTINUE
          END IF
C
        END IF
C
        IF (POINT) GOTO9999
C
C     We must recompute the point probability since it has underflowed.
C
        IF (DCDF .EQ. ZERO) THEN
          IF (MM.LE.MBIG)
     *      P = DLNGAM(DBLE(NN+1)) - DLNGAM(DBLE(MM+1)) +
     *      DLNGAM(DBLE(KK+1)) + DLNGAM(DBLE(MM-NN+1)) -
     *      DLNGAM(DBLE(LL+1)) - DLNGAM(DBLE(NN-LL+1)) -
     *      DLNGAM(DBLE(KK-LL+1)) - DLNGAM(DBLE(MM-NN-KK+LL+1)) +
     *      DLNGAM(DBLE(MM-KK+1))
          P = P + DLOG(SCALE)
          IF (P .LT. ELIMIT) THEN
            WRITE(ICOUT,51)
   51       FORMAT('***** WARNING--UNDERFLOW DETECTED.  RESULT MAY ',
     1             'BE IN ERROR.')
            CALL DPWRST('XXX','BUG ')
            IF (LL .GT. DBLE(NN*KK + NN + KK +1)/(MM +2)) DCDF = ONE
            GOTO9999
          ELSE
            P = DEXP(P)
          END IF
        ELSE
C
C     Scale up at this point.
C
          P = DCDF * SCALE
        END IF
C
        PT = ZERO
        NL = N - L
        KL = K - L
        MNKL = M - N - KL + 1
        IF (L .LE. KL) THEN
          DO 7 I = 1, L-1
            P = P * DBLE(L-I) * DBLE(MNKL-I) /(DBLE(NL+I) * DBLE(KL+I))
            PT = PT + P
    7     CONTINUE
          IF (P .EQ. ZERO) THEN
            WRITE(ICOUT,51)
            CALL DPWRST('XXX','BUG ')
          ENDIF
        ELSE
          DIR = .NOT. DIR
          DO 9 J = 0, KL-1
            P=P*DBLE(NL-J)*DBLE(KL-J)/(DBLE(L+J)*DBLE(MNKL+J))
            PT = PT + P
    9     CONTINUE
          IF (P .EQ. ZERO) THEN
            WRITE(ICOUT,51)
            CALL DPWRST('XXX','BUG ')
          ENDIF
        END IF
C
        IF (DIR) THEN
          DCDF = DCDF + (PT / SCALE)
        ELSE
          DCDF = ONE - (PT / SCALE)
        END IF
C
      END IF
C
 9999 CONTINUE
      CDF=SNGL(DCDF)
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HYPPPF(P,K,N,M,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE HYPERGEOMETRIC DISTRIBUTION
C              THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF
C              SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE
C              KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF
C              MM ITEMS, NN OF WHICH ARE MARKED.  IT HAS CDF OF:
C                 CDF = P(X<= LL | KK, NN, MM)
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                IT SHOULD BE IN THE INTERVAL (0,1).
C                     --KK     = THE INTEGER VALUE INDICATING THE
C                                SAMPLE SIZE.
C                     --NN     = THE NUMBER OF MARKED ITEMS IN THE
C                                POPULATION.
C                     --MM     = THE POPULATION SIZE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0 and 1 (INCLUSIVELY).
C                 --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C                 --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT  .
C             FUNCTION VALUE PPF
C             FOR THE HYPERGEOMETRIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--PPAR SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C                 --N SHOULD BE A POSITIVE INTEGER.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (INCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF, HYPCDF.
C     MODE OF INTERNAL OPERATIONS--SINGLE AND DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT
C              FROM THIS DISCRETE DISTRIBUTION
C              PERCENT POINT FUNCTION
C              SUBROUTINE MUST NECESSARILY BE A
C              DISCRETE INTEGER VALUE,
C              THE OUTPUT VARIABLE PPF IS SINGLE
C              PRECISION IN MODE.
C              PPF HAS BEEN SPECIFIED AS SINGLE
C              PRECISION SO AS TO CONFORM WITH THE DATAPAC
C              CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL
C              DATAPAC SUBROUTINES ARE SINGLE PRECISION.
C              THIS CONVENTION IS BASED ON THE BELIEF THAT
C              1) A MIXTURE OF MODES (FLOATING POINT
C              VERSUS INTEGER) IS INCONSISTENT AND
C              AN UNNECESSARY COMPLICATION
C              IN A DATA ANALYSIS; AND
C              2) FLOATING POINT MACHINE ARITHMETIC
C              (AS OPPOSED TO INTEGER ARITHMETIC)
C              IS THE MORE NATURAL MODE FOR DOING
C              DATA ANALYSIS.
C     REFERENCES--JOHNSON AND KOTZ, DISCRETE
C                 DISTRIBUTIONS, 1969.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--94/9
C     ORIGINAL VERSION--SEPTEMBER 1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      LOGICAL POINT
C
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LT.0.0.OR.P.GT.1.0)THEN
        WRITE(ICOUT,1)
    1   FORMAT('***** ERROR--THE FIRST ARGUMENT TO HYPPPF ',
     1         'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.LE.0.OR.N.GT.M)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE THIRD ARGUMENT TO HYPPPF ',
     1         '(THE NUMBER OF MARKED ITEMS)')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE ',
     1         'POPULATION SIZE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(K.LE.0.OR.K.GT.M)THEN
        WRITE(ICOUT,21)
   21   FORMAT('***** ERROR--THE SECOND ARGUMENT TO HYPPPF ',
     1         '(THE SAMPLE SIZE) ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      IS LESS THAN ZERO OR GREATER THAN THE ',
     1         'POULATION SIZE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)K
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
      PPF=0.0
      IX0=0
      IX1=0
      IX2=0
      P0=0.0
      P1=0.0
      P2=0.0
C
C     TREAT CERTAIN SPECIAL CASES IMMEDIATELY--
C     1) P = 0.0 OR 1.0
C
      IF(P.EQ.0.0)GOTO110
      IF(P.EQ.1.0)GOTO120
      GOTO190
  110 PPF=0.0
      RETURN
  120 PPF=REAL(MIN(N,K))
      RETURN
  190 CONTINUE
C
C     DETERMINE AN INITIAL APPROXIMATION TO THE HYPERGEOMETRIC
C     PERCENT POINT BY USE OF THE BINOMIAL APPROXIMATION
C     TO THE HYPERGEOMETRIC.
C
      PPAR=REAL(N)/REAL(M)
      IF(PPAR.LT.0.0.OR.PPAR.GT.1.0)PPAR=0.5
      CALL BINPPF(DBLE(P),DBLE(PPAR),K,DPPF)
      IX2=INT(DPPF)
C
C     CHECK AND MODIFY (IF NECESSARY) THIS INITIAL
C     ESTIMATE OF THE PERCENT POINT
C     TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO MIN(N,K).
C
      ITERM=MIN(N,K)
      IF(IX2.LT.0)IX2=0
      IF(IX2.GT.ITERM)IX2=ITERM
C
C     DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED
C     PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE)
C     FROM THE ORIGINAL APPROXIMATION AT STEPS
C     OF 1 STANDARD DEVIATION.
C     THE RESULTING BOUNDS WILL BE AT MOST
C     1 STANDARD DEVIATION APART.
C
      IX0=0
      IX1=N
      SD=(REAL(M-K)/REAL(M-1))*REAL(K)*(REAL(N)/REAL(M))*
     1(1.0-REAL(N)/REAL(M))
      ISD=INT(SD+1.0)
      POINT=.FALSE.
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
C
      IF(P2.LT.P)GOTO210
      GOTO250
C
  210 CONTINUE
      IX0=IX2
      I=1
  215 CONTINUE
      IX2=IX0+ISD
      IF(IX2.GE.IX1)GOTO275
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P2.GE.P)GOTO230
      IX0=IX2
      I=I+1
      IF(I.LE.1000000)GOTO215
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,222)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  230 CONTINUE
      IX1=IX2
      GOTO275
C
  250 CONTINUE
      IX1=IX2
      I=1
  255 CONTINUE
      IX2=IX1-ISD
      IF(IX2.LE.IX0)GOTO275
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P2.LT.P)GOTO270
      IX1=IX2
C
      I=I+1
      IF(I.LE.1000000)GOTO255
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,262)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  270 CONTINUE
      IX0=IX2
C
  275 CONTINUE
      IF(IX0.EQ.IX1)GOTO280
      GOTO295
  280 CONTINUE
      IF(IX0.EQ.0)GOTO285
      IF(IX0.EQ.N)GOTO290
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,282)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  285 CONTINUE
      IX1=IX1+1
      GOTO295
  290 CONTINUE
      IX0=IX0-1
  295 CONTINUE
C
C     COMPUTE HYPERGEOMETRIC PROBABILITIES FOR THE
C     DERIVED LOWER AND UPPER BOUNDS.
C
      CALL HYPCDF(IX0,K,N,M,POINT,P0)
      CALL HYPCDF(IX1,K,N,M,POINT,P1)
C
C     CHECK THE PROBABILITIES FOR PROPER ORDERING
C
      IF(P0.LT.P.AND.P.LE.P1)GOTO490
      IF(P0.EQ.P)GOTO410
      IF(P1.EQ.P)GOTO420
      IF(P0.GT.P1)GOTO430
      IF(P0.GT.P)GOTO440
      IF(P1.LT.P)GOTO450
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,401)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  410 CONTINUE
      PPF=IX0
      RETURN
  420 CONTINUE
      PPF=IX1
      RETURN
  430 CONTINUE
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,431)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  440 CONTINUE
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,441)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  450 CONTINUE
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,451)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  490 CONTINUE
C
C     THE STOPPING CRITERION IS THAT THE LOWER BOUND
C     AND UPPER BOUND ARE EXACTLY 1 UNIT APART.
C     CHECK TO SEE IF IX1 = IX0 + 1;
C     IF SO, THE ITERATIONS ARE COMPLETE;
C     IF NOT, THEN BISECT, COMPUTE PROBABILIIES,
C     CHECK PROBABILITIES, AND CONTINUE ITERATING
C     UNTIL IX1 = IX0 + 1.
C
  300 CONTINUE
      IX0P1=IX0+1
      IF(IX1.EQ.IX0P1)GOTO690
      IX2=(IX0+IX1)/2
      IF(IX2.EQ.IX0)GOTO610
      IF(IX2.EQ.IX1)GOTO620
      CALL HYPCDF(IX2,K,N,M,POINT,P2)
      IF(P0.LT.P2.AND.P2.LT.P1)GOTO630
      IF(P2.LE.P0)GOTO640
      IF(P2.GE.P1)GOTO650
  610 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  620 WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,611)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  630 CONTINUE
      IF(P2.LE.P)GOTO635
      IX1=IX2
      P1=P2
      GOTO300
  635 CONTINUE
      IX0=IX2
      P0=P2
      GOTO300
  640 CONTINUE
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,641)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  650 CONTINUE
      WRITE(ICOUT,249)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,651)
      CALL DPWRST('XXX','BUG ')
      GOTO950
  690 CONTINUE
      PPF=IX1
      IF(P0.EQ.P)PPF=IX0
      RETURN
C
  950 CONTINUE
      WRITE(ICOUT,240)IX0,P0
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,241)IX1,P1
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,242)IX2,P2
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,244)P
      CALL DPWRST('XXX','BUG ')
C
  222 FORMAT('NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS')
  240 FORMAT('IX0  = ',I8,10X,'P0 = ',F14.7)
  241 FORMAT('IX1  = ',I8,10X,'P1 = ',F14.7)
  242 FORMAT('IX2  = ',I8,10X,'P2 = ',F14.7)
  244 FORMAT('P    = ',F14.7)
  249 FORMAT('***** INTERNAL ERROR IN HYPPPF SUBROUTINE *****')
  262 FORMAT('NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS')
  282 FORMAT('LOWER AND UPPER BOUND IDENTICAL')
  401 FORMAT('IMPOSSIBLE BRANCH CONDITION ENCOUNTERED')
  431 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1       'UPPER BOUND PROBABILITY (P1)')
  441 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ',
     1       'INPUT PROBABILITY (P)')
  451 FORMAT('UPPER BOUND PROBABILITY (P1) LESS    THAN ',
     1       'INPUT PROBABILITY (P)')
  611 FORMAT('BISECTION VALUE (X2) = LOWER BOUND (X0)')
CC621 FORMAT('BISECTION VALUE (X2) = UPPER BOUND (X1)')
  641 FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1       'LESS THAN LOWER BOUND PROBABILITY (P0)')
  651 FORMAT('BISECTION VALUE PROBABILITY (P2) ',
     1       'GREATER THAN UPPER BOUND PROBABILITY (P1)')
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE HYPRAN(KK,NN1,NN2,ISEED,JX)
CCCCC SUBROUTINE H2PEC(KK,NN1,NN2,ISEED,JX)
C
C      ALGORITHM 668, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 14, NO. 4, PP. 397-398.
C
C
C     HYPERGEOMETRIC RANDOM VARIATE GENERATOR
C
C     METHOD
C        IF (MODE - MAX(0,KK-NN2) .LT. 10), USE THE INVERSE CDF.
C           OTHERWISE, USE ALGORITHM H2PE: ACCEPTANCE-REJECTION VIA
C           THREE REGION COMPOSITION.  THE THREE REGIONS ARE A
C           RECTANGLE, AND EXPONENTIAL LEFT AND RIGHT TAILS.
C        H2PE  REFERS TO HYPERGEOMETRIC-2 POINTS-EXPONENTIAL TAILS.
C        H2PEC REFERS TO H2PE AND "COMBINED."  THUS H2PE IS THE
C           RESEARCH RESULT AND H2PEC IS THE IMPLEMENTATION OF A
C           COMPLETE USABLE ALGORITHM.
C
C     REFERENCE
C        VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,
C
C        "COMPUTER GENERATION OF HYPERGEOMETRIC RANDOM VARIATES,"
C        JOURNAL OF STATISTICAL COMPUTATION AND SIMULATION,
C        22(1985), 2, 1985, 127-145.
C
C     REQUIRED SUBPROGRAMS
C        AFC() : A DOUBLE-PRECISION FUNCTION TO EVALUATE
C                   THE LOGARITHM OF THE FACTORIAL.
C        RAND(): A UNIFORM (0,1) RANDOM NUMBER GENERATOR.
C
C     ARGUMENTS
C        NN1   : NUMBER OF WHITE BALLS          (INPUT)
C        NN2   : NUMBER OF BLACK BALLS          (INPUT)
C        KK    : NUMBER OF BALLS TO BE DRAWN    (INPUT)
C        ISEED : RANDOM NUMBER SEED  (INPUT AND OUTPUT)
C        JX    : NUMBER OF WHITE BALLS DRAWN   (OUTPUT)
C
C     STRUCTURAL VARIABLES
C        REJECT: LOGICAL FLAG TO REJECT THE VARIATE GENERATE BY H2PE.
C        SETUP1: LOGICAL FLAG TO SETUP FOR NEW VALUES OF NN1 OR NN2.
C        SETUP2: LOGICAL FLAG TO SETUP FOR NEW VALUES OF KK.
C        IX    : INTEGER CANDIDATE VALUE.
C        M     : DISTRIBUTION MODE.
C        MINJX : DISTRIBUTION LOWER BOUND.
C        MAXJX : DISTRIBUTION UPPER BOUND.
C        KS    : SAVED VALUE OF KK FROM THE LAST CALL TO H2PEC.
C        N1S   : SAVED VALUE OF NN1 FROM THE LAST CALL TO H2PEC.
C        N2S   : SAVED VALUE OF NN2 FROM THE LAST CALL TO H2PEC.
C        K,N1,N2: ALTERNATE VARIABLES FOR KK, NN1, AND NN2
C                   (ALWAYS (N1 .LE. N2) AND (K .LE. (N1+N2)/2)).
C        TN    : TOTAL NUMBER OF WHITE AND BLACK BALLS
C
C     INVERSE-TRANSFORMATION VARIABLES
C        CON   : NATURAL LOGARITHM  OF SCALE.
C        P     : CURRENT SCALED PROBABILITY FOR THE INVERSE CDF.
C        SCALE : A BIG CONSTANT (1.E25) USED TO SCALE THE
C                   PROBABILITY TO AVOID NUMERICAL UNDERFLOW
C        U     : THE UNIFORM VARIATE BETWEEN (0, 1.E25).
C        W     : SCALED HYPERGEOMETRIC PROBABILITY OF MINJX.
C
C     H2PE VARIABLES
C        S     : DISTRIBUTION STANDARD DEVIATION.
C        D     : HALF THE AREA OF THE RECTANGLE.
C        XL    : LEFT END OF THE RECTANGLE.
C        XR    : RIGHT END OF THE RECTANGLE.
C        A     : A SCALING CONSTANT.
C        KL    : HIGHEST POINT OF THE LEFT-TAIL REGION.
C        KR    : HIGHEST POINT OF THE RIGHT-TAIL REGION.
C        LAMDL : RATE FOR THE LEFT EXPONENTIAL TAIL.
C        LAMDR : RATE FOR THE RIGHT EXPONENTIAL TAIL.
C        P1    : AREA OF THE RECTANGLE.
C        P2    : AREA OF THE LEFT EXPONENTIAL TAIL PLUS P1.
C        P3    : AREA OF THE RIGHT EXPONENTIAL TAIL PLUS P2.
C        U     : A UNIFORM (0,P3) RANDOM VARIATE USED FIRST TO SELECT
C                   ONE OF THE THREE REGIONS AND THEN CONDITIONALLY TO
C                   GENERATE A VALUE FROM THE REGION.
C        V     : U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM
C                   VALUE OR TO ACCEPT OR REJECT THE CANDIDATE VALUE.
C        F     : THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
C                   ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL.
C        I     : INDEX FOR EXPLICIT CALCULATION OF F FOR H2PE.
C
C   THE FOLLOWING VARIABLES ARE TEMPORARY VARIABLES USED IN
C   COMPUTING THE UPPER AND LOWER BOUNDS OF THE NATURAL LOGARITHM
C   OF THE SCALED DENSITY.  THE DETAILED DESCRIPTION IS GIVEN IN
C   PROPOSITIONS 2 AND 3 OF THE APPENDIX IN THE REFERENCE.
C              Y, Y1, YM, YN, YK, NK, R, S, T, E, G, DG, GU, GL, XM,
C              XN, XK, NM
C
C        Y     : PRELIMINARY CONTINUOUS CANDIDATE VALUE, FLOAT(IX)
C        UB    : UPPER BOUND FOR THE NATURAL LOGARITHM OF THE SCALED
C                   DENSITY.
C        ALV   : NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V.
C        DR, DS, DT, DE: ONE OF MANY TERMS SUBTRACTED FROM THE UPPER
C                   BOUND TO OBTAIN THE LOWER BOUND ON THE NATURAL
C                   LOGARITHM OF THE SCALED DENSITY.
C        DELTAU: A CONSTANT, THE VALUE 0.0034 IS OBTAINED BY SETTING
C                   N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
C                   THE FUNCTION DELTA_U IN LEMMA 1 AND ROUNDING THE
C                   VALUE TO FOUR DECIMAL PLACES.
C        DELTAL: A CONSTANT, THE VALUE 0.0078 IS OBTAINED BY SETTING
C                   N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
C                   THE FUNCTION DELTA_L IN LEMMA 1 AND ROUNDING THE
C                   VALUE TO FOUR DECIMAL PLACES.
C
      SAVE
CCCCC SEPTEMBER 1995.  USE DLNGAM FUNCTION IN PLACE OF AFC
CCCCC DOUBLE PRECISION AFC,CON,P,SCALE,U,W,A,XL,XR
      DOUBLE PRECISION DLNGAM,CON,P,SCALE,U,W,A,XL,XR
      REAL KL,KR,LAMDL,LAMDR,NK,NM
CCCCC AUGUST 1995.  ADD FOLLOWING ARRAY FOR DATAPLOT
CCCCC UNIFORM RANDOM NUMBER GENERATOR.
      REAL XTEMP(1)
C
      LOGICAL REJECT,SETUP1,SETUP2
      DATA KS,N1S,N2S/-1,-1,-1/
      DATA CON,DELTAL,DELTAU,SCALE/57.56462733D0,0.0078,0.0034,1.D25/
C
C*****CHECK PARAMETER VALIDITY
C
      IF (  (NN1 .LT. 0)  .OR.
     $      (NN2 .LT. 0)  .OR.
     $      (KK  .LT. 0)  .OR.
     $      (KK  .GT. NN1 + NN2 )  ) THEN
         JX     = -1
         RETURN
      ENDIF
C
C*****IF NEW PARAMETER VALUES, INITIALIZE
C
      REJECT = .TRUE.
      SETUP1 = .FALSE.
      SETUP2 = .FALSE.
      IF ((NN1 .NE. N1S) .OR. (NN2 .NE. N2S))  THEN
            SETUP1 = .TRUE.
            SETUP2 = .TRUE.
      ELSEIF (KK .NE. KS)  THEN
            SETUP2 = .TRUE.
      ENDIF
C
      IF (SETUP1)  THEN
         N1S   = NN1
         N2S   = NN2
         TN    = REAL(NN1 + NN2)
         IF (NN1 .LE. NN2)  THEN
            N1 = NN1
            N2 = NN2
         ELSE
            N1 = NN2
            N2 = NN1
         ENDIF
      ENDIF
C
      IF (SETUP2)  THEN
         KS    = KK
         IF (KK+KK .GE. INT(TN+0.1))  THEN
            K  = INT(TN - REAL(KK))
         ELSE
            K  = KK
         ENDIF
      ENDIF
C
      IF (SETUP1 .OR. SETUP2)  THEN
         M     = INT ((K+1.) * (N1+1.) / (TN+2.))
         MINJX = MAX (0, K-N2)
         MAXJX = MIN (N1, K)
      ENDIF
C
C*****GENERATE RANDOM VARIATE
C
      IF (MINJX .EQ. MAXJX)  THEN
C
C        ...DEGENERATE DISTRIBUTION...
C
         IX      = MAXJX
         RETURN
      ELSEIF (M-MINJX .LT. 10)  THEN
C
C        ...INVERSE TRANSFORMATION...
C
         IF (SETUP1 .OR. SETUP2)  THEN
            IF (K .LT. N2) THEN
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC          W = EXP (CON + AFC(N2) + AFC(N1+N2-K)
CCCCC$                       - AFC(N2-K) - AFC(N1+N2))
               W = EXP (CON + DLNGAM(DBLE(N2+1))+DLNGAM(DBLE(N1+N2-K+1))
     $                 - DLNGAM(DBLE(N2-K+1)) - DLNGAM(DBLE(N1+N2+1)))
            ELSE
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC          W = EXP (CON + AFC(N1) + AFC(K)
CCCCC$                       - AFC(K-N2) - AFC(N1+N2))
               W = EXP (CON + DLNGAM(DBLE(N1+1)) + DLNGAM(DBLE(K+1))
     $                 - DLNGAM(DBLE(K-N2+1)) - DLNGAM(DBLE(N1+N2+1)))
            ENDIF
         ENDIF
C
   10    P  = W
         IX = MINJX
CCCCC SEPTEMBER 1995.  REPLACE RAND WITH DATAPLOT UNIFORM RANDOM
CCCCC NUMBER GENERATOR.
         NTEMP=1
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         U = XTEMP(1)*SCALE
CCCCCC   U  = RANDDP (ISEED) * SCALE
   20    IF (U .GT. P)  THEN
            U  = U - P
            P  = P * (N1-IX)*(K-IX)
            IX = IX + 1
            P  = P / IX / (N2-K+IX)
            IF (IX .GT. MAXJX)  GO TO 10
            GO TO 20
         ENDIF
      ELSE
C
C        ...H2PE...
C
         IF (SETUP1 .OR. SETUP2)  THEN
            S     = SQRT ((TN-K) * K * N1 * N2 / (TN-1) / TN /TN)
C
C           ...REMARK:  D IS DEFINED IN REFERENCE WITHOUT INT.
C           THE TRUNCATION CENTERS THE CELL BOUNDARIES AT 0.5
C
            D     = INT (1.5*S) + .5
            XL    = M - D + .5
            XR    = M + D + .5
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC       A     = AFC(M) + AFC(N1-M) + AFC(K-M) + AFC(N2-K+M)
CCCCC       KL    = EXP (A - AFC(INT(XL)) - AFC(INT(N1-XL))
CCCCC$                  - AFC(INT(K-XL)) - AFC(INT(N2-K+XL)))
CCCCC       KR    = EXP (A - AFC(INT(XR-1)) - AFC(INT(N1-XR+1))
CCCCC$                  - AFC(INT(K-XR+1)) - AFC(INT(N2-K+XR-1)))
            A     = DLNGAM(DBLE(M+1)) + DLNGAM(DBLE(N1-M+1)) +
     1              DLNGAM(DBLE(K-M+1)) + DLNGAM(DBLE(N2-K+M+1))
            KL    = EXP (A - DLNGAM(DBLE(INT(XL)+1)) -
     1              DLNGAM(DBLE(INT(N1-XL)+1))
     1              - DLNGAM(DBLE(INT(K-XL)+1)) -
     1              DLNGAM(DBLE(INT(N2-K+XL)+1)))
            KR    = EXP(A-DLNGAM(DBLE(INT(XR-1)+1)) -
     1              DLNGAM(DBLE(INT(N1-XR+1)+1))
     1              - DLNGAM(DBLE(INT(K-XR+1)+1)) -
     1              DLNGAM(DBLE(INT(N2-K+XR-1)+1)))
            LAMDL = -LOG (XL * (N2-K+XL) / (N1-XL+1) / (K-XL+1))
            LAMDR = -LOG ((N1-XR+1) * (K-XR+1) / XR / (N2-K+XR))
            P1    = D + D
            P2    = P1 + KL / LAMDL
            P3    = P2 + KR / LAMDR
         ENDIF
C
 30      CONTINUE
CCCCC AUGUST 1995.  REPLACE RAND WITH DATAPLOT UNIFORM RANDOM
CCCCC NUMBER GENERATOR.
         NTEMP=1
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         U = XTEMP(1) * P3
         CALL UNIRAN(NTEMP,ISEED,XTEMP)
         V = XTEMP(1)
CCC30    U     = RANDDP (ISEED) * P3
CCCCC    V     = RANDDP (ISEED)
         IF (U .LT. P1)  THEN
C
C           ...RECTANGULAR REGION...
C
            IX    = INT(XL + U)
         ELSEIF (U .LE. P2)  THEN
C
C           ...LEFT TAIL...
C
            IX    = INT(XL + LOG(V)/LAMDL)
            IF (IX .LT. MINJX)  GO TO 30
            V     = V * (U-P1) * LAMDL
         ELSE
C
C           ...RIGHT TAIL...
C
            IX    = INT(XR - LOG(V)/LAMDR)
            IF (IX .GT. MAXJX)  GO TO 30
            V     = V * (U-P2) * LAMDR
         ENDIF
C
C        ...ACCEPTANCE/REJECTION TEST...
C
         IF (M .LT. 100 .OR. IX .LE. 50)  THEN
C
C           ...EXPLICIT EVALUATION...
C
            F     = 1.0
            IF (M .LT. IX)  THEN
               DO 40 I = M+1,IX
                  F      = F * (N1-I+1) * (K-I+1) / (N2-K+I) / I
   40          CONTINUE
            ELSEIF (M .GT. IX)  THEN
               DO 50 I = IX+1,M
                  F      = F * I * (N2-K+I) / (N1-I) / (K-I)
   50          CONTINUE
            ENDIF
            IF (V .LE. F)  THEN
               REJECT = .FALSE.
            ENDIF
         ELSE
C
C        ...SQUEEZE USING UPPER AND LOWER BOUNDS...
C
            Y   = IX
            Y1  = Y + 1.
            YM  = Y - M
            YN  = N1 - Y + 1.
            YK  = K - Y + 1.
            NK  = N2 - K + Y1
            R   = -YM / Y1
            S   = YM / YN
            T   = YM / YK
            E   = -YM / NK
            G   = YN * YK / (Y1*NK) - 1.
            DG  = 1.
            IF (G .LT. 0.)  DG = 1.+G
            GU  = G * (1.+G*(-.5+G/3.))
            GL  = GU - .25 * (G*G)**2 / DG
            XM  = M + .5
            XN  = N1 - M + .5
            XK  = K - M + .5
            NM  = N2 - K + XM
            UB  = Y * GU - M * GL + DELTAU
     $              + XM * R * (1.+R*(-.5+R/3.))
     $              + XN * S * (1.+S*(-.5+S/3.))
     $              + XK * T * (1.+T*(-.5+T/3.))
     $              + NM * E * (1.+E*(-.5+E/3.))
C
C           ...TEST AGAINST UPPER BOUND...
C
            ALV = LOG(V)
            IF (ALV .GT. UB)  THEN
               REJECT = .TRUE.
            ELSE
C
C              ...TEST AGAINST LOWER BOUND...
C
               DR = XM * (R*R)**2
               IF (R .LT. 0.)  DR = DR / (1.+R)
               DS = XN * (S*S)**2
               IF (S .LT. 0.)  DS = DS / (1.+S)
               DT = XK * (T*T)**2
               IF (T .LT. 0.)  DT = DT / (1.+T)
               DE = NM * (E*E)**2
               IF (E .LT. 0.)  DE = DE / (1.+E)
               IF (ALV .LT. UB-.25*(DR+DS+DT+DE)
     $                         +(Y+M)*(GL-GU)-DELTAL)  THEN
                  REJECT = .FALSE.
               ELSE
C
C                 ...STIRLING'S FORMULA TO MACHINE ACCURACY...
C
CCCCC SEPTEMBER 1995.  USE DLNGAM INSTEAD OF AFC
CCCCC             IF (ALV .LE. (A - AFC(IX) - AFC(N1-IX)
CCCCC$                       - AFC(K-IX) - AFC(N2-K+IX)) )  THEN
                  IF (ALV .LE.(A-DLNGAM(DBLE(IX+1)) -
     $                        DLNGAM(DBLE(N1-IX+1))
     $                        - DLNGAM(DBLE(K-IX+1))
     $                        - DLNGAM(DBLE(N2-K+IX+1))))
     $            THEN
                     REJECT = .FALSE.
                  ELSE
                     REJECT = .TRUE.
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
         IF (REJECT)  GO TO 30
      ENDIF

C
C*****RETURN APPROPRIATE VARIATE
C
      IF (KK + KK .GE. TN)  THEN
         IF (NN1 .GT. NN2)  THEN
            IX = KK - NN2 + IX
         ELSE
            IX =  NN1 - IX
         ENDIF
      ELSE
         IF (NN1 .GT. NN2)  IX = KK - IX
      ENDIF
      JX = IX
      RETURN
      END
      DOUBLE PRECISION FUNCTION I0INT(XVALUE)
C
C   DESCRIPTION:
C      This program computes the integral of the modified Bessel
C      function I0(x) using the definition
C
C         I0INT(x) = {integral 0 to x} I0(t) dt
C
C      The program uses Chebyshev expansions, the coefficients of
C      which are given to 20 decimal places.
C
C
C   ERROR RETURNS:
C      If |XVALUE| larger than a certain limit, the value of
C      I0INT would cause an overflow. If such a situation occurs
C      the programs prints an error message, and returns the
C      value sign(XVALUE)*XMAX, where XMAX is the largest
C      acceptable floating-pt. value.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used from the array ARI01.
C                The recommended value is such that
C                    ABS(ARI01(NTERM1)) < EPS/100
C
C      NTERM2 - The no. of terms to be used from the array ARI0A.
C                The recommended value is such that
C                    ABS(ARI0A(NTERM2)) < EPS/100
C
C      XLOW - The value below which I0INT(x) = x, to machine precision.
C             The recommended value is
C                  sqrt(12*EPS).
C
C      XHIGH - The value above which overflow will occur. The
C              recommended value is
C                  ln(XMAX) + 0.5*ln(ln(XMAX)) + ln(2).
C
C      For values of EPS and XMAX refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      Dr. Allan J. MacLeod,
C      Dept. of Mathematics and Statistics,
C      University of Paisley,
C      High St.,
C      Paisley,
C      SCOTLAND
C      PA1 2BE
C
C      (e-mail :   macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                   23 January, 1996
C
      INTEGER IND,NTERM1,NTERM2
      DOUBLE PRECISION ARI01(0:28),ARI0A(0:33),
     1     ATEEN,CHEVAL,HALF,LNR2PI,ONEHUN,T,TEMP,THREE,THIRT6,
     2     X,XHIGH,XLOW,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER FNNAME*6,ERRMSG*26
CCCCC DATA FNNAME/'I0INT '/
CCCCC DATA ERRMSG/'SIZE OF ARGUMENT TOO LARGE'/
      DATA ZERO,HALF,THREE/ 0.0 D 0 , 0.5 D 0 , 3.0 D 0 /
      DATA ATEEN,THIRT6,ONEHUN/ 18.0 D 0 , 36.0 D 0 , 100.0 D 0/
      DATA LNR2PI/0.91893 85332 04672 74178 D 0/
      DATA ARI01(0)/  0.41227 90692 67815 16801  D    0/
      DATA ARI01(1)/ -0.34336 34515 00815 19562  D    0/
      DATA ARI01(2)/  0.22667 58871 57512 42585  D    0/
      DATA ARI01(3)/ -0.12608 16471 87422 60032  D    0/
      DATA ARI01(4)/  0.60124 84628 77799 0271   D   -1/
      DATA ARI01(5)/ -0.24801 20462 91335 8248   D   -1/
      DATA ARI01(6)/  0.89277 33895 65563 897    D   -2/
      DATA ARI01(7)/ -0.28325 37299 36696 605    D   -2/
      DATA ARI01(8)/  0.79891 33904 17129 94     D   -3/
      DATA ARI01(9)/ -0.20053 93366 09648 90     D   -3/
      DATA ARI01(10)/ 0.44168 16783 01431 3      D   -4/
      DATA ARI01(11)/-0.82237 70422 46068        D   -5/
      DATA ARI01(12)/ 0.12005 97942 19015        D   -5/
      DATA ARI01(13)/-0.11350 86500 4889         D   -6/
      DATA ARI01(14)/ 0.69606 01446 6            D   -9/
      DATA ARI01(15)/ 0.18062 27728 36           D   -8/
      DATA ARI01(16)/-0.26039 48137 0            D   -9/
      DATA ARI01(17)/-0.16618 8103               D  -11/
      DATA ARI01(18)/ 0.51050 0232               D  -11/
      DATA ARI01(19)/-0.41515 879                D  -12/
      DATA ARI01(20)/-0.73681 38                 D  -13/
      DATA ARI01(21)/ 0.12793 23                 D  -13/
      DATA ARI01(22)/ 0.10324 7                  D  -14/
      DATA ARI01(23)/-0.30379                    D  -15/
      DATA ARI01(24)/-0.1789                     D  -16/
      DATA ARI01(25)/ 0.673                      D  -17/
      DATA ARI01(26)/ 0.44                       D  -18/
      DATA ARI01(27)/-0.14                       D  -18/
      DATA ARI01(28)/-0.1                        D  -19/
      DATA ARI0A(0)/  2.03739 65457 11432 87070  D    0/
      DATA ARI0A(1)/  0.19176 31647 50331 0248   D   -1/
      DATA ARI0A(2)/  0.49923 33451 92881 47     D   -3/
      DATA ARI0A(3)/  0.22631 87103 65981 5      D   -4/
      DATA ARI0A(4)/  0.15868 21082 85561        D   -5/
      DATA ARI0A(5)/  0.16507 85563 6318         D   -6/
      DATA ARI0A(6)/  0.23850 58373 640          D   -7/
      DATA ARI0A(7)/  0.39298 51823 04           D   -8/
      DATA ARI0A(8)/  0.46042 71419 9            D   -9/
      DATA ARI0A(9)/ -0.70725 58172              D  -10/
      DATA ARI0A(10)/-0.67471 83961              D  -10/
      DATA ARI0A(11)/-0.20269 62001              D  -10/
      DATA ARI0A(12)/-0.87320 338                D  -12/
      DATA ARI0A(13)/ 0.17552 0014               D  -11/
      DATA ARI0A(14)/ 0.60383 944                D  -12/
      DATA ARI0A(15)/-0.39779 83                 D  -13/
      DATA ARI0A(16)/-0.80490 48                 D  -13/
      DATA ARI0A(17)/-0.11589 55                 D  -13/
      DATA ARI0A(18)/ 0.82731 8                  D  -14/
      DATA ARI0A(19)/ 0.28229 0                  D  -14/
      DATA ARI0A(20)/-0.77667                    D  -15/
      DATA ARI0A(21)/-0.48731                    D  -15/
      DATA ARI0A(22)/ 0.7279                     D  -16/
      DATA ARI0A(23)/ 0.7873                     D  -16/
      DATA ARI0A(24)/-0.785                      D  -17/
      DATA ARI0A(25)/-0.1281                     D  -16/
      DATA ARI0A(26)/ 0.121                      D  -17/
      DATA ARI0A(27)/ 0.214                      D  -17/
      DATA ARI0A(28)/-0.27                       D  -18/
      DATA ARI0A(29)/-0.36                       D  -18/
      DATA ARI0A(30)/ 0.7                        D  -19/
      DATA ARI0A(31)/ 0.6                        D  -19/
      DATA ARI0A(32)/-0.2                        D  -19/
      DATA ARI0A(33)/-0.1                        D  -19/
C
      XLOW=CPUMIN
C
C   Start computation
C
      IND = 1
      X = XVALUE
      IF ( XVALUE .LT. ZERO ) THEN
         IND = -1
         X = -X
      ENDIF
C
C   Compute the machine-dependent constants.
C
      T = LOG(D1MACH(2))
      XHIGH = T + LOG(T)*HALF - LOG(HALF)
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I0INT = EXP ( XHIGH - LNR2PI - HALF * LOG(XHIGH) )
         IF ( IND .EQ. -1 ) I0INT = -I0INT
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0INT--SIZE OF THE INPUT ARGUMENT ',
     1        'IS TOO LARGE, ARGUMENT = ',G15.7)
C
C   Continue with machine-constants
C
      TEMP = D1MACH(3)
      T = TEMP / ONEHUN
      IF ( X .LE. ATEEN ) THEN
         DO 10 NTERM1 = 28 , 0 , -1
            IF ( ABS(ARI01(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = SQRT ( THIRT6 * TEMP / THREE )
      ELSE
         DO 40 NTERM2 = 33 , 0 , -1
            IF ( ABS(ARI0A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      CONTINUE
      ENDIF
C
C   Code for 0 <= |x| <= 18
C
      IF ( X .LE. ATEEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I0INT = X
         ELSE
            T = ( THREE * X - ATEEN ) / ( X + ATEEN )
            I0INT = X * EXP(X) * CHEVAL(NTERM1,ARI01,T)
         ENDIF
      ELSE
C
C   Code for |x| > 18
C
         T = ( THIRT6 / X - HALF ) - HALF
         TEMP = X - HALF*LOG(X) - LNR2PI + LOG(CHEVAL(NTERM2,ARI0A,T))
         I0INT = EXP(TEMP)
      ENDIF
      IF ( IND .EQ. -1 ) I0INT = -I0INT
      RETURN
      END
      DOUBLE PRECISION FUNCTION I0ML0(XVALUE)
C
C   DESCRIPTION:
C
C      This program calculates the function I0ML0 defined as
C
C                I0ML0(x) = I0(x) - L0(x)
C
C      where I0(x) is the modified Bessel function of the first kind of
C      order 0, and L0(x) is the modified Struve function of order 0.
C
C      The code uses Chebyshev expansions with the coefficients
C      given to an accuracy of 20D.
C
C
C   ERROR RETURNS:
C
C      The coefficients are only suitable for XVALUE >= 0.0. If
C      XVALUE < 0.0, an error message is printed and the function
C      returns the value 0.0
C
C
C   MACHINE-DEPENDENT PARAMETERS:
C
C      NTERM1 - INTEGER - The number of terms required for the array
C                         AI0L0. The recommended value is such that
C                              ABS(AI0L0(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The number of terms required for the array
C                         AI0L0A. The recommended value is such that
C                              ABS(AI0L0A(NTERM2)) < EPS/100
C
C      XLOW - DOUBLE PRECISION - The value below which I0ML0(x) = 1 to machine
C                    precision. The recommended value is
C                               EPSNEG
C
C      XHIGH - DOUBLE PRECISION - The value above which I0ML0(x) = 2/(pi*x) to
C                     machine precision. The recommended value is
C                               SQRT(800/EPS)
C
C      For values of EPS, and EPSNEG see the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod
C          Dept. of Mathematics and Statistics
C          University of Paisley
C          High St.
C          Paisley
C          SCOTLAND
C          PA1 2BE
C
C          ( e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AI0L0(0:23),AI0L0A(0:23),ATEHUN,CHEVAL,
     1     FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWOBPI,TWO88,X,XHIGH,
     2     XLOW,XSQ,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER FNNAME*6,ERRMSG*14
CCCCC DATA FNNAME/'I0ML0 '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,ONE/ 0.0 D 0 , 1.0 D 0 /
      DATA SIX,SIXTEN/ 6.0 D 0 , 16.0 D 0 /
      DATA FORTY,ONEHUN/ 40.0 D 0 , 100.0 D 0 /
      DATA TWO88,ATEHUN/ 288.0 D 0 , 800.0 D 0 /
      DATA TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA AI0L0(0)/  0.52468 73679 14855 99138  D    0/
      DATA AI0L0(1)/ -0.35612 46069 96505 86196  D    0/
      DATA AI0L0(2)/  0.20487 20286 40099 27687  D    0/
      DATA AI0L0(3)/ -0.10418 64052 04026 93629  D    0/
      DATA AI0L0(4)/  0.46342 11095 54842 9228   D   -1/
      DATA AI0L0(5)/ -0.17905 87192 40349 8630   D   -1/
      DATA AI0L0(6)/  0.59796 86954 81143 177    D   -2/
      DATA AI0L0(7)/ -0.17177 75476 93565 429    D   -2/
      DATA AI0L0(8)/  0.42204 65446 91714 22     D   -3/
      DATA AI0L0(9)/ -0.87961 78522 09412 5      D   -4/
      DATA AI0L0(10)/ 0.15354 34234 86922 3      D   -4/
      DATA AI0L0(11)/-0.21978 07695 84743        D   -5/
      DATA AI0L0(12)/ 0.24820 68393 6666         D   -6/
      DATA AI0L0(13)/-0.20327 06035 607          D   -7/
      DATA AI0L0(14)/ 0.90984 19842 1            D   -9/
      DATA AI0L0(15)/ 0.25617 93929              D  -10/
      DATA AI0L0(16)/-0.71060 9790               D  -11/
      DATA AI0L0(17)/ 0.32716 960                D  -12/
      DATA AI0L0(18)/ 0.23002 15                 D  -13/
      DATA AI0L0(19)/-0.29210 9                  D  -14/
      DATA AI0L0(20)/-0.3566                     D  -16/
      DATA AI0L0(21)/ 0.1832                     D  -16/
      DATA AI0L0(22)/-0.10                       D  -18/
      DATA AI0L0(23)/-0.11                       D  -18/
      DATA AI0L0A(0)/ 2.00326 51024 11606 43125  D    0/
      DATA AI0L0A(1)/ 0.19520 68515 76492 081    D   -2/
      DATA AI0L0A(2)/ 0.38239 52356 99083 28     D   -3/
      DATA AI0L0A(3)/ 0.75342 80817 05443 6      D   -4/
      DATA AI0L0A(4)/ 0.14959 57655 89707 8      D   -4/
      DATA AI0L0A(5)/ 0.29994 05312 10557        D   -5/
      DATA AI0L0A(6)/ 0.60769 60482 2459         D   -6/
      DATA AI0L0A(7)/ 0.12399 49554 4506         D   -6/
      DATA AI0L0A(8)/ 0.25232 62552 649          D   -7/
      DATA AI0L0A(9)/ 0.50463 48573 32           D   -8/
      DATA AI0L0A(10)/0.97913 23623 0            D   -9/
      DATA AI0L0A(11)/0.18389 11524 1            D   -9/
      DATA AI0L0A(12)/0.33763 09278              D  -10/
      DATA AI0L0A(13)/0.61117 9703               D  -11/
      DATA AI0L0A(14)/0.10847 2972               D  -11/
      DATA AI0L0A(15)/0.18861 271                D  -12/
      DATA AI0L0A(16)/0.32803 45                 D  -13/
      DATA AI0L0A(17)/0.56564 7                  D  -14/
      DATA AI0L0A(18)/0.93300                    D  -15/
      DATA AI0L0A(19)/0.15881                    D  -15/
      DATA AI0L0A(20)/0.2791                     D  -16/
      DATA AI0L0A(21)/0.389                      D  -17/
      DATA AI0L0A(22)/0.70                       D  -18/
      DATA AI0L0A(23)/0.16                       D  -18/
C
      XLOW=CPUMIN
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I0ML0 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0ML0--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XSQ = D1MACH(3)
      T = XSQ / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(AI0L0(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = XSQ
      ELSE
         DO 40 NTERM2 = 23 , 0 , -1
            IF ( ABS(AI0L0A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = SQRT ( ATEHUN / XSQ )
      ENDIF
C
C   Code for x <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I0ML0 = ONE
            RETURN
         ELSE
            T = ( SIX * X - FORTY ) / ( X + FORTY )
            I0ML0 = CHEVAL(NTERM1,AI0L0,T)
            RETURN
         ENDIF
      ELSE
C
C   Code for x > 16
C
         IF ( X .GT. XHIGH ) THEN
            I0ML0 = TWOBPI / X
         ELSE
            XSQ = X * X
            T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ )
            I0ML0 = CHEVAL(NTERM2,AI0L0A,T) * TWOBPI / X
         ENDIF
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION I1ML1(XVALUE)
C
C   DESCRIPTION:
C
C      This program calculates the function I1ML1 defined as
C
C                I1ML1(x) = I1(x) - L1(x)
C
C      where I1(x) is the modified Bessel function of the first kind of
C      order 1, and L1(x) is the modified Struve function of order 1.
C
C      The code uses Chebyshev expansions with the coefficients
C      given to an accuracy of 20D.
C
C
C   ERROR RETURNS:
C
C      The coefficients are only suitable for XVALUE >= 0.0. If
C      XVALUE < 0.0, an error message is printed and the function
C      returns the value 0.0
C
C
C   MACHINE-DEPENDENT PARAMETERS:
C
C      NTERM1 - INTEGER - The number of terms required for the array
C                         AI1L1. The recommended value is such that
C                              ABS(AI1L1(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The number of terms required for the array
C                         AI1L1A. The recommended value is such that
C                              ABS(AI1L1A(NTERM2)) < EPS/100
C
C      XLOW - DOUBLE PRECISION - The value below which I1ML1(x) = x/2 to machine
C                    precision. The recommended value is
C                               2*EPSNEG
C
C      XHIGH - DOUBLE PRECISION - The value above which I1ML1(x) = 2/pi to
C                     machine precision. The recommended value is
C                               SQRT(800/EPS)
C
C      For values of EPS, and EPSNEG see the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      ABS , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod
C          Dept. of Mathematics and Statistics
C          University of Paisley
C          High St.
C          Paisley
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER NTERM1,NTERM2
      DOUBLE PRECISION AI1L1(0:23),AI1L1A(0:25),ATEHUN,CHEVAL
CCCCC DOUBLE PRECISION FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWO,TWOBPI,TWO88
      DOUBLE PRECISION FORTY,ONEHUN,SIX,SIXTEN,T,TWO,TWOBPI,TWO88
      DOUBLE PRECISION X,XHIGH,XLOW,XSQ,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*14
CCCCC DATA FNNAME/'I1ML1 '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0 /
      DATA ZERO,TWO/ 0.0D0,2.0D0 /
      DATA SIX,SIXTEN,FORTY/ 6.0 D 0 , 16.0 D 0 , 40.0 D 0 /
      DATA ONEHUN,TWO88,ATEHUN/ 100.0 D 0 , 288.0 D 0 , 800.0 D 0 /
      DATA TWOBPI/0.63661 97723 67581 34308 D 0/
      DATA AI1L1(0)/  0.67536 36906 23505 76137  D    0/
      DATA AI1L1(1)/ -0.38134 97109 72665 59040  D    0/
      DATA AI1L1(2)/  0.17452 17077 51339 43559  D    0/
      DATA AI1L1(3)/ -0.70621 05887 23502 5061   D   -1/
      DATA AI1L1(4)/  0.25173 41413 55880 3702   D   -1/
      DATA AI1L1(5)/ -0.78709 85616 06423 321    D   -2/
      DATA AI1L1(6)/  0.21481 43686 51922 006    D   -2/
      DATA AI1L1(7)/ -0.50862 19971 79062 36     D   -3/
      DATA AI1L1(8)/  0.10362 60828 04423 30     D   -3/
      DATA AI1L1(9)/ -0.17954 47212 05724 7      D   -4/
      DATA AI1L1(10)/ 0.25978 82745 15414        D   -5/
      DATA AI1L1(11)/-0.30442 40632 4667         D   -6/
      DATA AI1L1(12)/ 0.27202 39894 766          D   -7/
      DATA AI1L1(13)/-0.15812 61441 90           D   -8/
      DATA AI1L1(14)/ 0.18162 09172              D  -10/
      DATA AI1L1(15)/ 0.64796 7659               D  -11/
      DATA AI1L1(16)/-0.54113 290                D  -12/
      DATA AI1L1(17)/-0.30831 1                  D  -14/
      DATA AI1L1(18)/ 0.30563 8                  D  -14/
      DATA AI1L1(19)/-0.9717                     D  -16/
      DATA AI1L1(20)/-0.1422                     D  -16/
      DATA AI1L1(21)/ 0.84                       D  -18/
      DATA AI1L1(22)/ 0.7                        D  -19/
      DATA AI1L1(23)/-0.1                        D  -19/
      DATA AI1L1A(0)/  1.99679 36189 67891 36501  D    0/
      DATA AI1L1A(1)/ -0.19066 32614 09686 132    D   -2/
      DATA AI1L1A(2)/ -0.36094 62241 01744 81     D   -3/
      DATA AI1L1A(3)/ -0.68418 47304 59982 0      D   -4/
      DATA AI1L1A(4)/ -0.12990 08228 50942 6      D   -4/
      DATA AI1L1A(5)/ -0.24715 21887 05765        D   -5/
      DATA AI1L1A(6)/ -0.47147 83969 1972         D   -6/
      DATA AI1L1A(7)/ -0.90208 19982 592          D   -7/
      DATA AI1L1A(8)/ -0.17304 58637 504          D   -7/
      DATA AI1L1A(9)/ -0.33232 36701 59           D   -8/
      DATA AI1L1A(10)/-0.63736 42173 5            D   -9/
      DATA AI1L1A(11)/-0.12180 23975 6            D   -9/
      DATA AI1L1A(12)/-0.23173 46832              D  -10/
      DATA AI1L1A(13)/-0.43906 8833               D  -11/
      DATA AI1L1A(14)/-0.82847 110                D  -12/
      DATA AI1L1A(15)/-0.15562 249                D  -12/
      DATA AI1L1A(16)/-0.29131 12                 D  -13/
      DATA AI1L1A(17)/-0.54396 5                  D  -14/
      DATA AI1L1A(18)/-0.10117 7                  D  -14/
      DATA AI1L1A(19)/-0.18767                    D  -15/
      DATA AI1L1A(20)/-0.3484                     D  -16/
      DATA AI1L1A(21)/-0.643                      D  -17/
      DATA AI1L1A(22)/-0.118                      D  -17/
      DATA AI1L1A(23)/-0.22                       D  -18/
      DATA AI1L1A(24)/-0.4                        D  -19/
      DATA AI1L1A(25)/-0.1                        D  -19/
C
      XLOW=CPUMIN
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         I1ML1 = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I1ML1--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      XSQ = D1MACH(3)
      T = XSQ / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(AI1L1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = XSQ + XSQ
      ELSE
         DO 40 NTERM2 = 25 , 0 , -1
            IF ( ABS(AI1L1A(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = SQRT ( ATEHUN / XSQ )
      ENDIF
C
C   Code for x <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            I1ML1 = X / TWO
            RETURN
         ELSE
            T = ( SIX * X - FORTY ) / ( X + FORTY )
            I1ML1 = CHEVAL(NTERM1,AI1L1,T) * X / TWO
            RETURN
         ENDIF
      ELSE
C
C   Code for x > 16
C
         IF ( X .GT. XHIGH ) THEN
            I1ML1 = TWOBPI
         ELSE
            XSQ = X * X
            T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ )
            I1ML1 = CHEVAL(NTERM2,AI1L1A,T) * TWOBPI
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE IBCDF(X,ALPHA,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X, ALPHA, BETA > 0
C              THE CUMULATIVE DISTRIBUTION IS COMPUTED BY
C              ALPHAMERICALLY INTEGRATING THE PDF FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE DEGREES OF FREEDOM PARAMETER
C                     --BETA   = THE SKEWNESS PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE INVERTED BETA DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DQAGI.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION ALPHAMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER LIMIT
      INTEGER LENW
      PARAMETER(LIMIT=200)
      PARAMETER(LENW=4*LIMIT)
      INTEGER INF
      INTEGER NEVAL
      INTEGER IER
      INTEGER LAST
      INTEGER IWORK(LIMIT)
      REAL ALPHA
      REAL BETA
      REAL X
      REAL CDF
      DOUBLE PRECISION EPSABS
      DOUBLE PRECISION EPSREL
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DX
      DOUBLE PRECISION DA
      DOUBLE PRECISION ABSERR
      DOUBLE PRECISION WORK(LENW)
C
      DOUBLE PRECISION IBFUN
      EXTERNAL IBFUN
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      CDF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      IBCDF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
  106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBCDF ROUTINE ',
     1       'IS NON-POSITIVE.')
C
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      INF=+1
      EPSABS=1.0D-7
      EPSREL=1.0D-7
      IER=0
      IKEY=3
      CDF=0.0D0
C
      DA=1.0D-7
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
CCCCC REPLACE WITH A CODE FOR DEFINITE INTEGRAL.
CCCCC CALL DQAGI(IBFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL,
CCCCC1          IER,LIMIT,LENW,LAST,IWORK,WORK)
C
CCCCC DCDF=1.0D0 - DCDF
C
      CALL DQAG(IBFUN,DA,DX,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL,
     1          IER,LIMIT,LENW,LAST,IWORK,WORK)
      CDF=REAL(DCDF)
C
      IF(IER.EQ.1)THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      MAXIMUM NUMBER OF SUBDIVISIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      ROUNDOFF ERROR PREVENTS REQUESTED TOLERANCE ',
     1         'FROM BEING ACHIEVED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      BAD INTEGRAND BEHAVIOUR DETECTED.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      INTEGRATION DID NOT CONVERGE.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,153)
  153   FORMAT('      THE INTEGRATION IS PROBABLY DIVERGENT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IER.EQ.6)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,161)
  161   FORMAT('***** ERROR FROM IBCDF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,163)
  163   FORMAT('      INVALID INPUT TO THE INTEGRATION ROUTINE.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION IBFUN(DX)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X, ALPHA, BETA > 0
C              IDENTICAL TO IBPDF,
C              BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION
C              CODE CALLED BY IBCDF.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--IBFUN  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE SKEW-T DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLBETA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      EXTERNAL DLBETA
C
      DOUBLE PRECISION DLBETA
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DTERM1=(DALPHA-1.0D0)*DLOG(DX)
      DTERM2=DLBETA(DALPHA,DBETA)
      DTERM3=(DALPHA+DBETA)*DLOG(1.0D0+DX)
C
      DPDF=DTERM1 - DTERM2 - DTERM3
      IF(DPDF.LT.LOG(CPUMAX))THEN
        DPDF=DEXP(DPDF)
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        DPDF=LOG(CPUMAX)
      ENDIF
  501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ',
     1       'DETECTED.')
C
      IBFUN=DPDF
      RETURN
      END
      REAL FUNCTION IBFU2(X)
C
C     PURPOSE--IBPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT
C              POINT FUNCTION.  IBFU2 IS THE FUNCTION FOR WHICH
C              THE ZERO IS FOUND.  IT IS:
C                 P - IBCDF(X,LAMBDA)
C              WHERE P IS THE DESIRED PERCENT POINT.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE IBFU2.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IBCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      COMMON/IB2COM/P
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CALL IBCDF(X,REAL(DALPHA),REAL(DBETA),CDF)
      IBFU2=P - CDF
C
      RETURN
      END
      SUBROUTINE IBPDF(X,ALPHA,BETA,PDF)
C
C     NOTE--INVERTED BETA PDF IS:
C              IBPDF(X,A,B) = X**(ALPHA-1)/
C                             [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA),
C                             X > 0
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     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/5
C     ORIGINAL VERSION--MAY       2003.
C
C---------------------------------------------------------------------
C
      EXTERNAL DLBETA
      DOUBLE PRECISION DLBETA
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
  101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
  102 FORMAT('      IBPDF ROUTINE IS NON-POSITIVE.')
  103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
  104 FORMAT('      THE VALUE OF THE ARGUMENT IS ',E15.7,' ******')
  106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBPDF ROUTINE ',
     1       'IS NON-POSITIVE.')
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
C
      DTERM1=(DALPHA-1.0D0)*LOG(DX)
      DTERM2=DLBETA(DALPHA,DBETA)
      DTERM3=(DALPHA+DBETA)*LOG(1.0D0+DX)
C
      DPDF=DTERM1 - DTERM2 - DTERM3
      IF(DPDF.LT.LOG(CPUMAX))THEN
        DPDF=DEXP(DPDF)
      ELSE
        WRITE(ICOUT,501)
        CALL DPWRST('XXX','BUG ')
        DPDF=LOG(CPUMAX)
      ENDIF
  501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ',
     1       'DETECTED.')
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IBPPF(P,ALPHA,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION
C              WITH SHAPE PARAMETERS ALPHA AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              NUMERICALLY INVERTING THE CDF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--FZERO.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION,
C                 JOHN WILEY, 1994.
C               --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION ALPHAMBER--2003.12
C     ORIGINAL VERSION--DECEMBER  2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL PPF
C
      REAL IBFU2
      EXTERNAL IBFU2
C
      REAL P2
      COMMON/IB2COM/P2
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DBETA
      COMMON/IBCOM/DALPHA,DBETA
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      PPF=0.0
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
  102   FORMAT('      IBPPF ROUTINE IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,103)
  103   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,104)BETA
  104   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO IBPPF')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7,'.')
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(P.EQ.0.0)THEN
        PPF=0.0
        GOTO9000
      ENDIF
C
C  STEP 1: FIND BRACKETING INTERVAL.  LOWER BOUND IS ZERO.  START WITH
C          10 AS GUESS FOR UPPER BOUND.  MULTIPLY BY 10 UNTIL
C          BRACKETING INTERVAL FOUND.
C
      XLOW=0.0000001
      XUP2=10.0
  200 CONTINUE
      CALL IBCDF(XUP2,ALPHA,BETA,PTEMP)
      IF(PTEMP.GT.P)THEN
        XUP=XUP2
      ELSE
        XUP2=XUP2*10.0
        IF(XUP2.GT.CPUMAX/100.)THEN
          WRITE(ICOUT,201)
  201     FORMAT('***** ERROR FROM IBPPF--UNABLE TO FIND A ',
     1           'BRACKETING INTERVAL')
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
        GOTO200
      ENDIF
C
      AE=1.E-6
      RE=1.E-6
      P2=P
      DALPHA=DBLE(ALPHA)
      DBETA=DBLE(BETA)
      CALL FZERO(IBFU2,XLOW,XUP,XUP,RE,AE,IFLAG)
C
      PPF=XLOW
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
  999   FORMAT(1X)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CC111   FORMAT('***** WARNING FROM IBPPF--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,113)
CC113   FORMAT('      PPF VALUE MAY NOT BE COMPUTED TO DESIRED ',
CCCCC1         'TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      PPF VALUE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,131)
  131   FORMAT('***** ERROR FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,133)
  133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,141)
  141   FORMAT('***** WARNING FROM IBPPF--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,143)
  143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IBRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED BETA DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS = ALPHA AND BETA.
C              THE PROTOTYPE INVERTED BETA DISTRIBUTION USED
C              HEREIN CAN BE EXPRESSED AS THE RATIO OF TWO INDEPENDENT
C              GAMMA DISTRIBUTIONS WITH SHAPE PARAMETERS ALPHA AND
C              BETA, RESPECTIVELY.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST  SHAPE PARAMETER.
C                                ALPHA SHOULD BE GREATER THAN 0.0.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                BETA  SHOULD BE GREATER THAN 0.0.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED BETA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE GREATER THAN
C                   OR EQUAL TO 0.0.
C                 --BETA  SHOULD BE GREATER THAN
C                   OR EQUAL TO 0.0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, GAMRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS AND PEACOCK, "STATISTICAL
C                 DISTRIBUTIONS--THIRD EDITION", WILEY, 2000.
C                 PAGES 41-42.
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 (1966)
C               EXCEPTION--HOLLARITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.5
C     ORIGINAL VERSION--MAY       2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XG1(1)
      DIMENSION XG2(1)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LT.0.0)THEN
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE NUMBER OF REQUESTED INVERTED ',
     1'BETA RANDOM NUMBERS IS NON-POSITIVE.')
   16 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ',
     1'INVERTED BETA IS LESS THAN 0.0 *****')
   26 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ',
     1'INVERTED BETA IS LESS THAN 0.0 *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N BETA RANDOM NUMBERS BY USING THE FACT THAT THE
C     INVERTED BETA IS A RATIO OF TWO INDEPENDENT GAMMA VARIATES.
C
      NTEMP=1
      DO100I=1,N
C
        CALL GAMRAN(NTEMP,ALPHA,ISEED,XG1)
        CALL GAMRAN(NTEMP,BETA,ISEED,XG2)
        X(I)=0.0
        IF(XG2(1).GT.0.0)X(I)=XG1(1)/XG2(1)
C
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C***BEGIN PROLOGUE  IDAMAX
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A2
C***KEYWORDS  BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT,
C             VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find largest component of d.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C   IDAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of double precision DX.
C     IDAMAX =  first I, I = 1 to N, to minimize  ABS(DX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  IDAMAX
C
      DOUBLE PRECISION DX(*),DMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  IDAMAX
      IDAMAX = 0
      IF(N.LE.0) RETURN
      IDAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      DMAX = DABS(DX(1))
      NS = N*INCX
      II = 1
          DO 10 I = 1,NS,INCX
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 5
          IDAMAX = II
          DMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 30
          IDAMAX = I
          DMAX = XMAG
   30 CONTINUE
      RETURN
      END
      SUBROUTINE IGACDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X.
C              THE PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C              THE CDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPHA) = GAMMAIP(1/X,ALPHA)
C              WHERE GAMMAIP = GAMMAI(ALPHA,X)/GAMMA(ALPHA).
C              THE CDF IS CAN BE COMPUTED WITH THE SLATEC ROUTINE
C              DGAMIC.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE INVERTED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA SHOULD BE A POSITIVE NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--GAMMIP.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                GAMMA CHAPTER.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/6
C     ORIGINAL VERSION--JUNE      2004. PREVIOUSLY IMPLEMENTED
C                                       AS SPECIAL CASE OF GGDCDF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMIP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE IGACDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGACDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C
      IF(X.LE.R1MACH(1))THEN
        CDF=0.0
        RETURN
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/DX)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGAPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER ALPHA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,ALPHA) = X**(-(ALPHA+1))*EXP(-1/X)/GAMMA(ALPHA)
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALPHA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE INVERTED GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --ALPHA AND X SHOULD BE POSITIVE NUMBERS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL
C                DISTRIBUTIONS", THIRD EDITION, WILEY, 2000,
C                GAMMA CHAPTER.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/6
C     ORIGINAL VERSION--JUNE      2004. PREVIOUSLY COMPUTED USING
C                                       GENERALIZED GAMMA WITH C=-1
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(ALPHA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ',
     1'TO THE IGAPDF SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IGAPDF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(X.LE.R1MACH(1))THEN
        PDF=0.0
        RETURN
      ENDIF
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      DTERM1=-(DALPHA+1.0D0)*DLOG(DX)
      DTERM2=-1.0D0/DX
      DTERM3=DLNGAM(DALPHA)
      DTERM4=DTERM1+DTERM2-DTERM3
      DPDF=0.0D0
      IF(DTERM4.GE.-80.0D0)DPDF=DEXP(DTERM4)
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGAPPF(P,ALPHA,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE INVERTED GAMMA
C                 DISTRIBUTION.  USES A BISECTION METHOD.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/6
C     ORIGINAL VERSION--JUNE      2004. PREVIOUSLY IMPLEMENTED AS
C                                       SPECIAL CASE OF GGDPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION DMEAN
      DOUBLE PRECISION DSD
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION XINC
      DOUBLE PRECISION X
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION P1
      DOUBLE PRECISION FCS
      DOUBLE PRECISION XRML
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION CDFL
      DOUBLE PRECISION CDFR
      DOUBLE PRECISION DGAMIP
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /0.0001D0/
      DATA SIG /1.0D-5/
      DATA ZERO /0.0D0/
      DATA MAXIT /5000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ELSEIF(ALPHA.LT.0.1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGAPPF ',
     1       'IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
   15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO IGAPPF ',
     1       'IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE SECOND ARGUMENT TO IGAPPF ',
     1       'IS < 0.1')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      IF(P.EQ.0.)THEN
        PPF=0.
        GOTO9999
      ENDIF
C
C  FIND BRACKETING INTERVAL.
C
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
C
      XL=0.0D0
      IF(ALPHA.GT.1.0)THEN
        DMEAN=1.0D0/(DALPHA-1.0D0)
      ELSE
        IF(ALPHA.GE.0.9)THEN
          DMEAN=10.0
        ELSEIF(ALPHA.GE.0.5)THEN
          DMEAN=50.0
        ELSEIF(ALPHA.GE.0.1)THEN
          DMEAN=200.0
          IF(P.GT.0.75)DMEAN=100000.
        ELSE
          DMEAN=500.0
          IF(P.GT.0.75)DMEAN=1000000.
        ENDIF
      ENDIF
      IF(ALPHA.GT.2.0)THEN
        DSD=DSQRT(1.0D0/((DALPHA-1.0D0)**2*(DALPHA-2.0)))
      ELSEIF(ALPHA.GE.0.9)THEN
        DSD=3.0
      ELSEIF(ALPHA.GE.0.5)THEN
        DSD=10.0
      ELSEIF(ALPHA.GE.0.1)THEN
        IF(P.LE.0.75)THEN
          DSD=1000.0
        ELSE
          DSD=10000.0
        ENDIF
      ELSE
        IF(P.LE.0.75)THEN
          DSD=1000.0
        ELSE
          DSD=5000.0
        ENDIF
      ENDIF
C
      XR=DMEAN
      XINC=DSD
      ICOUNT=0
      MAXCNT=20000
C
   91 CONTINUE
      IF(XL.LE.0.0D0)THEN
        CDFL=0.0D0
      ELSE
        CDFL=1.0D0 - DGAMIP(DALPHA,1.0D0/XL)
      ENDIF
      IF(XR.LE.0.0D0)XR=XL+DMEAN
      CDFR=1.0D0 - DGAMIP(DALPHA,1.0D0/XR)
      IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN
        XL=XR
        XR=XL+XINC
      ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN
        XL=XL-XINC
        IF(XL.LT.0.0D0)XL=0.0D0
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** ERROR--IGAPPF UNABLE TO FIND BRACKETING ',
     *       'INTERVAL.')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -DP
      FXR = 1.0D0 - DP
  105 CONTINUE
      X = (XL+XR)*0.5D0
      DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/X)
      P1=DCDF
      PPF=REAL(X)
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--IGAPPF ROUTINE DID NOT CONVERGE.')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE IGARAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED GAMMA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED GAMMA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED  VERSION--JANUARY   2005. BUG IF ROUTINE CALLED MORE
C                                       THAN ONCE, RESET AA AND AAA
C                                       AND STORE IN COMMON
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      COMMON/SGAMM/AA,AAA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'IGARAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'IGARAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
CCCCC CALL UNIRAN(N,ISEED,X)
      AA=0.0
      AAA=0.0
C
C     GENERATE N INVERTED GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
C     NOTE 6/2004: USE RELATIONSHIP TO GAMMA DISTRIBUTION.
C
CCCCC C=-1.0
      DO100I=1,N
        ATEMP=SGAMMA(ISEED,GAMMA)
        X(I)=1.0/ATEMP
CCCCC   CALL GGDPPF(X(I),GAMMA,C,XTEMP)
CCCCC   X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGCDF(DX,DGAMMA,DMU,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER
C              MU (ALTHOUGH MU IS ESSENTIALLY A SCALE PARAMETER, IT IS
C              NOT A SCALE PARAMETER IN THE TECHNICAL SENSE THAT THE
C              FOLLOWING RELATIONSHIP
C
C                  f(X;LOC,SCALE) = f((X-LOC)/SCALE;0,1)/SCALE
C
C              DOES NOT HOLD. THEREFORE, WE REFER TO IT AS A SHAPE
C              PARAMETER.
C
C              THE STANDARD FORM OF THE DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X AND HAS CUMULATIVE DISTRIBUTION FUNCTION
C              (PAGE 247 OF VOLUME 4 OF THE OF ENCYCLOPEDIA OF
C              STATISTICAL SCIENCES.
C
C                  F(X) = NORCDF(SQRT(GAMMA/X)*(-1 + (X/MU))) +
C                         EXP(2*GAMMA/MU)*NORCDF(SQRT(GAMMA/X)*(1 + (X/MU)))
C
C              THE PARAMETERIZATION DESCRIBED ABOVE WILL BE REFERRED TO
C              AS THE "TWEEDIE" PARAMETERIZATION.  NOTE THAT WHAT WE
C              CALL GAMMA IS CALLED LAMBDA IN MANY REFERENCES.  A
C              RE-PARAMETERIZATION, WHICH WE CALL THE CHAN PARAMETERIZATION,
C              USES
C
C                 SIGMA = SQRT(MU**3/GAMMA)
C
C     NOTE--THE INVERSE GAUSSIAN DISTRIBUTION--
C           1) GOES FROM 0 TO INFINITY
C           2) HAS MEAN = MU
C           3) HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) = SIGMA
C           4) HAS SHAPE PARAMETER = GAMMA
C           5) IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C           6) IS SYMMETRIC AND MODERATE-TAILED FOR LARGE GAMMA
C           7) APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE FIRST SHAPE PARAMETER,
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SECOND SHAPE PARAMETER,
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE INVERSE GAUSSIAN DISTRIBUTION WITH
C             WITH TAIL LENGTH PARAMETER = GAMMA AND SHAP PARAMETER MU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA AND AMU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND JOHNSON, "ENCYCLOPEDIA OF STATISTICAL SCIENCES",
C                 VOLUME 4, PP. 246-249.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --DECEMBER  1998. USE DOUBLE PRECISION
C     UPDATED         --OCTOBER   2001. BUG FIX.  MISSING SOME
C                                       DOUBLE PRECISION DECLARATIONS
C     UPDATED         --DECEMBER  2003. GENERAL CASE FOR MU (I.E.,
C                                       DON'T ASSUME MU=1)
C     UPDATED         --APRIL     2014. MAKE ARGUMENTS DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT CHAN PARAMETERIZATION
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
CCCCC OCTOBER 2001.  ADD FOLLOWING 3 LINES
      DOUBLE PRECISION DTERM4
      DOUBLE PRECISION DTERM5
      DOUBLE PRECISION DTERM6
      DOUBLE PRECISION DTRM12
      DOUBLE PRECISION DTRM14
      DOUBLE PRECISION DPI
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DCDF=0.0D0
C
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO IGCDF IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO IGCDF IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C     CHECK FOR CHAN PARAMETERIZATION: GAMMA = MU**3/SIGMA**2
C
      IF(IGAUDF.EQ.'CHAN')THEN
        DGAMMA=DMU**3/DGAMMA**2
      ENDIF
C
      IF(DX.GT.0.0D0)THEN
         DPI=3.141592653589793238462643383279503D0
         DTERM1=DSQRT(DGAMMA/DX)
         DTERM2=(-1.0D0+DX/DMU)
         DTERM3=2.0D0*DGAMMA/DMU
         DTERM4=(1.0D0+DX/DMU)
         DTRM12=DTERM1*DTERM2
         DTRM14=(-DTERM1*DTERM4)
         CALL NODCDF(DTRM12,DTERM5)
         CALL NODCDF(DTRM14,DTERM6)
         DCDF=DTERM5+DEXP(DTERM3)*DTERM6
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGCHA(DX,DGAMMA,DMU,DHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER
C              MU (ALTHOUGH MU IS ESSENTIALLY A SCALE PARAMETER, IT IS
C              NOT A SCALE PARAMETER IN THE TECHNICAL SENSE THAT THE
C              FOLLOWING RELATIONSHIP
C
C                  f(X;LOC,SCALE) = f((X-LOC)/SCALE;0,1)/SCALE
C
C              DOES NOT HOLD. THEREFORE, WE REFER TO IT AS A SHAPE
C              PARAMETER.
C
C              WE COMPUTE THE CUMULATIVE HAZARD FUNCTION IN TERMS OF THE
C              CDF FUNCTION.
C
C              THE DEFAULT PARAMETERIZATION WILL BE REFERRED TO
C              AS THE "TWEEDIE" PARAMETERIZATION.  NOTE THAT WHAT WE
C              CALL GAMMA IS CALLED LAMBDA IN MANY REFERENCES.  A
C              RE-PARAMETERIZATION, WHICH WE CALL THE CHAN PARAMETERIZATION,
C              USES
C
C                 SIGMA = SQRT(MU**3/GAMMA)
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH THE
C                                CUMULATIVE HAZARD FUNCTION IS TO BE
C                                EVALUATED.  X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE FIRST SHAPE PARAMETER,
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SECOND SHAPE PARAMETER,
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE DOUBLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE HAZARD FUNCTION VALUE HAZ
C             FOR THE INVERSE GAUSSIAN DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND JOHNSON, "ENCYCLOPEDIA OF STATISTICAL SCIENCES",
C                 VOLUME 4, PP. 246-249.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED         --DECEMBER  2003.
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT---------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DHAZ=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO IGCHA IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO IGCHA IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DX.LT.0.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGCHA IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DX
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
C
      CALL IGCDF(DX,DGAMMA,DMU,DCDF)
      DCDF=1.0D0 - DCDF
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=-DLOG(DCDF)
      ELSE
        WRITE(ICOUT,162)DX
  162   FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',G15.7,
     1         ' THE CDF IS ESSENTIALLY 0, CUMULATIVE HAZARD SET TO 0.')
        CALL DPWRST('XXX','BUG ')
        DHAZ=0.0D0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGHAZ(DX,DGAMMA,DMU,DHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER
C              MU (ALTHOUGH MU IS ESSENTIALLY A SCALE PARAMETER, IT IS
C              NOT A SCALE PARAMETER IN THE TECHNICAL SENSE THAT THE
C              FOLLOWING RELATIONSHIP
C
C                  f(X;LOC,SCALE) = f((X-LOC)/SCALE;0,1)/SCALE
C
C              DOES NOT HOLD. THEREFORE, WE REFER TO IT AS A SHAPE
C              PARAMETER.
C
C              WE COMPUTE THE HAZARD FUNCTION IN TERMS OF THE PDF AND
C              CDF FUNCTIONS.
C
C              THE DEFAULT PARAMETERIZATION WILL BE REFERRED TO
C              AS THE "TWEEDIE" PARAMETERIZATION.  NOTE THAT WHAT WE
C              CALL GAMMA IS CALLED LAMBDA IN MANY REFERENCES.  A
C              RE-PARAMETERIZATION, WHICH WE CALL THE CHAN PARAMETERIZATION,
C              USES
C
C                 SIGMA = SQRT(MU**3/GAMMA)
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT WHICH THE
C                                HAZARD FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE FIRST SHAPE PARAMETER,
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SECOND SHAPE PARAMETER,
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE DOUBLE PRECISION HAZARD FUNCTION
C                                VALUE.
C     OUTPUT--THE DOUBLE PRECISION HAZARD FUNCTION VALUE HAZ FOR THE
C             INVERSE GAUSSIAN DISTRIBUTION.
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA
C              AND SHAPE PARAMETER = MU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --GAMMA AND MU SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGPDF AND IGCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND JOHNSON, "ENCYCLOPEDIA OF STATISTICAL SCIENCES",
C                 VOLUME 4, PP. 246-249.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.4
C     ORIGINAL VERSION--APRIL     1998.
C     UPDATED  VERSION--DECEMBER  2003.
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DHAZ=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO IGHAZ IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO IGHAZ IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DX.LT.0.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGHAZ IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DX
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
C
      CALL IGPDF(DX,DGAMMA,DMU,DPDF)
      CALL IGCDF(DX,DGAMMA,DMU,DCDF)
      DCDF=1.0D0 - DCDF
      IF(DCDF.GT.0.0D0)THEN
        DHAZ=DPDF/DCDF
      ELSE
        WRITE(ICOUT,162)DX
  162   FORMAT('***** FOR THE VALUE OF THE ARGUMENT, ',
     1         G15.7,', THE CDF IS ESSENTIALLY 0, HAZARD SET TO 0.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGLI1(Y,N,ICASPL,ALOC,AMU,GAMMA,
     1                 ALIK,AIC,AICC,BIC,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE INVERSE GUASSIAN DISTRIBUTION.  THIS IS
C              FOR THE RAW DATA CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DG
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPI
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI/3.14159265358979D+00/
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='IGLI'
      ISUBN2='1   '
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF IGLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASPL
   52   FORMAT('IBUGA3,ISUBRO,ICASPL = ',2(A4,2X),A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,AMU,GAMMA
   55   FORMAT('N,ALOC,AMU,GAMMA = ',I8,3G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.EQ.'2IGA')ALOC=0.0
C
C     LOG-LIKELIHOOD FUNCTION IS:
C
C     (N/2)*LOG(GAMMA/(2*PI)) -
C     (3/2)*SUM[i=1 to N][LOG(Y(i) - LOC)] -
C     (GAMMA/(2*MU**2))*SUM[i=1 to N][(Y(i)-LOC-MU)**2/(Y(i)-LOC)]
C
      DN=DBLE(N)
      DLOC=DBLE(ALOC)
      DMU=DBLE(AMU)
      DG=DBLE(GAMMA)
C
      DTERM1=(DN/2.0D0)*DLOG(DG/(2.0D0*DPI))
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO1010I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + DLOG(DX-DLOC)
        DSUM2=DSUM2 + (DX-DLOC-DMU)**2/(DX-DLOC)
 1010 CONTINUE
C
      DLIK=DTERM1 - 1.5D0*DSUM1 - (DG/(2.0D0*DMU**2))*DSUM2
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'3IGA')DNP=3.0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF IGLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1
 9013   FORMAT('DSUM1,DSUM2,DTERM1 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE IGLI2(Y,X,N,NTOT,ICASPL,ALOC,AMU,GAMMA,
     1                 ALIK,AIC,AICC,BIC,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR THE
C              INVERSE GUASSIAN DISTRIBUTION FOR GROUPED DATA WITH
C              EQUAL BIN SIZES (I.E., X DENOTES THE BIN MID-POINTS) AND
C              NO  CENSORING.
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASPL
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DW
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='IGL2'
      ISUBN2='1   '
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF IGLI2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASPL
   52   FORMAT('IBUGA3,ISUBRO,ICASPL = ',2(A4,2X),A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,AMU,GAMMA
   55   FORMAT('N,ALOC,AMU,GAMMA = ',I8,3G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),X(I)
   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
      IF(ICASPL.EQ.'2IGA')ALOC=0.0
C
C     NOTE THAT THE INVERSE GAUSSIAN MAY SUPPORT AN OPTIONAL
C     LOCATION PARAMETER.  HOWEVER, THE SCALE PARAMETER IS NOT
C     TYPICALLY USED SINCE MU IS ESSENTIALLY A SCALE PARAMETER
C     (ALTHOUGH NOT IN THE STRICT TECHNICAL SENSE).  THE SCALE
C     PARAMETER IS NOT SUPPORTED HERE.
C
      DGAMMA=DBLE(GAMMA)
      DMU=DBLE(AMU)
      DLOC=DBLE(ALOC)
      DLIK=0.0D0
      DN=DBLE(NTOT)
C
      DO1010I=1,N
        IF(Y(I).LE.0.0)GOTO1010
        DX=DBLE(X(I)) - DLOC
        DW=DBLE(Y(I))
        CALL IGPDF(DX,DGAMMA,DMU,DPDF)
        IF(DPDF.LE.0.0D0)THEN
          IERROR='YES'
          GOTO9000
        ENDIF
        DLIK=DLIK + DLOG(DW*DPDF)
C
        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI2')THEN
          WRITE(ICOUT,1011)I,DX,DW,DPDF,DLIK
 1011     FORMAT('I,DX,DW,DPDF,DLIK = ',I8,4G15.7)
          CALL DPWRST('XXX','WRIT')
        ENDIF
C
 1010 CONTINUE
C
      ALIK=REAL(DLIK)
      DNP=2.0D0
      IF(ICASPL.EQ.'3IGA')DNP=3.0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF IGLI2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE IGML1(Y,N,PSTAMV,
     1                 XMEAN,XSD,XMIN,XSKEW,
     1                 ALOCML,AMUML,SIGMML,GAMMML,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 3-PARAMETER INVERSE GAUSSIAN DISTRIBUTION.
C
C              THIS IS FOR THE UNCENSORED, UPGROUPED CASE.
C
C              NOTE THAT THERE ARE SEVERAL PARAMETERIZATIONS OF THE
C              INVERSE GAUSSIAN DISTRIBUTION.
C
C              1) DATAPLOT USES THE TWEEDIE PARAMETERIZATION.  THIS
C                 PARAMETERIZATION HAS SHAPE PARAMETERS MU AND GAMMA
C                 (COHEN CALLS THE GAMMA PARAMETER LAMBDA) AND A
C                 THRESHOLD (LOCATION) PARAMETER.  COHEN USES GAMMA
C                 FOR THE THRESHOLD PARAMETER.
C
C              2) THE COHEN ALGORITHM ESTIMATES THE PARAMETERS BASED
C                 ON THE CHAN RE-PARAMETERIZATION:
C
C                    GAMMA = LAMBDA
C                          = MU**3/SIGMA**2
C
C                 THE COHEN/WHITTEN ALGORITHM GIVEN HERE ESTIMATES THE
C                 LOCATION PARAMETER, MU, AND SIGMA.  NOTE THAT GAMMA
C                 CAN BE COMPUTED FROM THE MU AND SIGMA.
C
C                 NOTE THAT NO ESTIMATION WILL BE PERFORMED FOR THE
C                 CASE WHERE THE SKEWNESS PARAMETER IS NEGATIVE.
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL Y(*)
C
      DOUBLE PRECISION AMOM(3)
      DOUBLE PRECISION VML(5)
      DOUBLE PRECISION TL
      DOUBLE PRECISION TU
      DOUBLE PRECISION T
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION F
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DN
      DOUBLE PRECISION BOUND
      DOUBLE PRECISION STEP
      DOUBLE PRECISION S1
      DOUBLE PRECISION S2
      DOUBLE PRECISION S3
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*40 IDIST
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='IGML'
      ISUBN2='1   '
      IERROR='NO'
C
      ALOCML=CPUMIN
      AMUML=CPUMIN
      SIGMML=CPUMIN
      GAMMML=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF IGML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,PSTAMV
   52   FORMAT('IBUGA3,ISUBRO,N,PSTAMV = ',2(A4,2X),I8,G15.7)
        CALL DPWRST('XXX','WRIT')
        DO55I=1,N
          WRITE(ICOUT,54)I,Y(I)
   54     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   55   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS FOR THE      **
C               **  INVERSE GAUSSIAN ML     ESTIMATES   **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IFLAG=0
      IDIST='INVERSE GAUSSIAN'
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      AMOM(1)=DBLE(XMEAN)
      AMOM(2)=DBLE(XSD)
      AMOM(3)=DBLE(XSKEW)
C
      IF(XSKEW.LE.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN INVERSE GAUSSIAN MLE ESTIMATION--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)
  112   FORMAT('      THE SAMPLE SKEWNESS IS NON-POSTIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,113)XSKEW
  113   FORMAT('      SKEWNESS = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(N.LT.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,122)
  122   FORMAT('      THE SAMPLE SIZE IS LESS THAN FIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,123)N
  123   FORMAT('      SAMPLE SIZE  = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  ML     ESTIMATES                    **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     IN CODE BELOW:
C
C        VML(1) = ESTIMATE OF LOCATION
C        VML(2) = ESTIMATE OF MU
C        VML(3) = ESTIMATE OF SIGMA
C        VML(4) = ESTIMATE OF MEAN
C               = LOC + MU
C        VML(5) = A3 (THIRD STANDARD MOMENT)
C               = 3*SIGMA/MU
C     CODE FROM PAGE 360-361 OF COHEN AND WHITTEN
C
      IERR=0
      EPS=0.1D-08
      DN=DBLE(N)
C
C     PLACE A LOWER BOUND ON THE LOCATION PARAMETER AND SET THE INITIAL
C     GUESS TO THE MINIMUM MINUS AN EPSILON (THIS WILL ALSO BE THE UPPER
C     BOUND.
C
      BOUND=DBLE(XMIN) - 30.0D0*AMOM(2)
      STEP=AMOM(2)/50.0D0
      TU=DBLE(XMIN) - EPS
      S1=0.0D0
      S2=0.0D0
      S3=0.0D0
      DO211I=1,N
        DX=DBLE(Y(I))
        S3=S3 + (DX-AMOM(1))**2/(DX-TU)
        S2=S2 + 1.0D0/(DX-TU)
        S1=S1 + 1.0D0/(DX-TU)**2
  211 CONTINUE
      FU=3.0D0*S3*S2/DN + DN - (AMOM(1)-TU)**2*S1
C
C     LOCATE A LOWER BOUND FOR THE LOCATION AND CHECK THAT IT IS IN
C     THE INTERVAL (TL,TU).
C
      TL=XMIN
      FL=FU
C
  300 CONTINUE
      IF(FL*FU.GT.0.0D0)THEN
        TL=TL-STEP
        IF(TL.LT.BOUND)THEN
          IERROR='YES'
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,322)
  322     FORMAT('      UNABLE TO FIND BRACKETING INTERVAL FOR THE ',
     1           'LOCATION PARMETER.')
          CALL DPWRST('XXX','WRIT')
          GOTO9000
        ELSE
          S1=0.0D0
          S2=0.0D0
          S3=0.0D0
          DO311I=1,N
            DX=DBLE(Y(I))
            S3=S3 + (DX-AMOM(1))**2/(DX-TL)
            S2=S2 + 1.0D0/(DX-TL)
            S1=S1 + 1.0D0/(DX-TL)**2
  311     CONTINUE
          FL=3.0D0*S3*S2/DN + DN - (AMOM(1)-TL)**2*S1
          GOTO300
        ENDIF
      ELSE
C
C       USE BINARY SEARCH TO FIND THE ESTIMATE OF THE LOCATION PARAMETER.
C
  400   CONTINUE
        T=(TU+TL)/2.0D0
        S1=0.0D0
        S2=0.0D0
        S3=0.0D0
        DO411I=1,N
          DX=DBLE(Y(I))
          S3=S3 + (DX-AMOM(1))**2/(DX-T)
          S2=S2 + 1.0D0/(DX-T)
          S1=S1 + 1.0D0/(DX-T)**2
  411   CONTINUE
        F=3.0D0*S3*S2/DN + DN - (AMOM(1)-T)**2*S1
        IF(DABS(T-TL).GT.EPS)THEN
          IF(F*FL.LT.0.0D0)THEN
            TU=T
          ELSE
            TL=T
            FL=F
          ENDIF
          GOTO400
        ELSE
          VML(2)=(AMOM(1) - T)
          VML(3)=DSQRT(VML(2)/DN*S3)
          VML(1)=T
          VML(4)=VML(2)+ VML(1)
          VML(5)=3.0D0*VML(3)/VML(2)
        ENDIF
      ENDIF
C
      ALOCML=REAL(VML(1))
      AMUML=REAL(VML(2))
      SIGMML=REAL(VML(3))
      GAMMML=REAL(VML(2)**3/VML(3)**2)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF IGML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)ALOCML,AMUML,SIGMML,GAMMML
 9012   FORMAT('ALOCML,AMUML,SIGMML,GAMMML = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE IGML5(ALOC,AMU,SIGMA,GAMMA,N,ICASAN,IGAUDF,COV,
     1                 XTEMP,ITEMP,MAXNXT,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE PARAMETER VARIANCE-COVARIANCE
C              MATRIX FOR THE 3-PARAMETER INVERSE GAUSSIAN DISTRIBUTION.
C
C              NOTE THAT THERE ARE 2 COMMON PARAMETERIZATIONS FOR THE
C              IVERSE GAUSSIAN DISTRIBUTION.
C
C              FOR THE CHAN/COHEN AND WHITEN PARAMETERIZATION:
C
C              THE EXPECTED INFORMATION MATRIX IS OBTAINED FROM THE
C              FOLLOWING QUANTITIES (3-PARAMETER CASE):
C
C                 I(1,1) = (N/SIGMA**2)*[7*A3**4*((A3**2/9) + 1)/54 +
C                          (A3**2/2) + 1]
C                 I(1,2) = (N/SIGMA**2)*((A3/2)*((A3**2/9) + 1) + 1)
C                 I(1,3) = -(N/SIGMA**2)*A3*((A3**2/9) + 1)
C                 I(2,2) = (N/SIGMA**2)*((A3**2/2) + 1)
C                 I(2,3) = -(N/SIGMA**2)*A3
C                 I(3,3) = 2*N/SIGMA**2
C
C              WHERE A3 = 3*SIGMA/MU
C
C              THE PARAMETER VARIANCE-COVARIANCE MATRIX IS THE
C              INVERSE OF THE INFORMATION MATRIX.
C
C              FOR THE ORIGINAL TWEEDIE PARAMETERIZATION, THE COVARIANCE
C              MATRIX TERMS ARE SIGMA(I,J)/D WHERE
C
C                 SIGMA(1,1) = 0.5/(GAMMA*MU**3)
C                 SIGMA(1,2) = -0.5/(GAMMA*MU**3)
C                 SIGMA(1,3) = -1.5*((1/MU**4) + 1/(GAMMA*MU**3))
C                 SIGMA(2,3) = 1.5*((1/MU**4) + 1/(GAMMA*MU**3))
C                 SIGMA(2,2) = 0.5*MU**3/GAMMA + 0.75/(GAMMA**3*MU) +
C                              3/GAMMA**4
C                 SIGMA(3,3) = 4.5*GAMMA/MU**5 + 10.5/MU**4 +
C                              10.5/(GAMMA*MU**3)
C
C                 D=0.75/(GAMMA**2*MU**4) + 3/(GAMMA**3*MU**3)
C
C
C     REFERENCE--COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 5.
C              --CHENG AND AMIN (1981), "MAXIMUM LIKELIHOOD ESTIMATION
C                OF PARAMETERS IN THE INVERSE GAUSSIAN DISTRIBUTION,
C                WITH UNKNOWN ORIGIN", TECHNOMETRICS, VOL. 23, NO. 3,
C                PP. 257-263.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
      REAL XTEMP(*)
      REAL FISH(3,3)
      REAL COV(3,3)
C
      INTEGER ITEMP(*)
C
      CHARACTER*4 ICASAN
      CHARACTER*4 IGAUDF
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION A3
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='IGML'
      ISUBN2='5   '
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF IGML5--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,IGAUDF,N
   52   FORMAT('IBUGA3,ISUBRO,ICASAN,IGAUDF,N = ',4(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,54)ALOC,SIGMA,AMU,GAMMA
   54   FORMAT('ALOC,SIGMA,AMU,GAMMA = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR VARIANCE-COVARIANCE MATRIX      **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO101J=1,3
        DO103I=1,3
          FISH(I,J)=CPUMIN
          COV(I,J)=CPUMIN
  103   CONTINUE
  101 CONTINUE
C
      DN=REAL(N)
      DLOC=DBLE(ALOC)
      DSIGMA=DBLE(SIGMA)
      DMU=DBLE(AMU)
      DGAMMA=DBLE(GAMMA)
      A3=3.0D0*DSIGMA/DMU
C
C     CHAN PARAMETERIZATION
C
      IF(IGAUDF.EQ.'CHAN')THEN
C
C       2-PARAMETER CASE
C
        IF(ICASAN.EQ.'2IGA')THEN
          DTERM1=DSIGMA**2/DN
          COV(1,1)=REAL(DTERM1)
          COV(2,2)=REAL((DTERM1/2.0D0)*((A3**2/2.0D0) + 1.0D0))
          COV(1,2)=REAL(DTERM1*A3/2.0D0)
          COV(2,1)=COV(1,2)
          GOTO9000
        ENDIF
C
C     3-PARAMETER CASE
C
        DTERM1=DN/DSIGMA**2
        DTERM2=7.0D0*A3**4*((A3**2/9.0D0) + 1.0D0)/54.0D0 +
     1         (A3**2/2.0D0) + 1.0D0
        FISH(1,1)=REAL(DTERM1*DTERM2)
        DTERM2=(A3**2/2.0D0)*((A3**2/9.0D0) + 1.0D0) + 1.0D0
        FISH(1,2)=REAL(DTERM1*DTERM2)
        DTERM2=A3*((A3**2/9.0D0) + 1.0D0)
        FISH(1,3)=REAL(-DTERM1*DTERM2)
        FISH(2,2)=REAL(DTERM1*((A3**2/2.0D0) + 1.0D0))
        FISH(2,3)=REAL(-DTERM1*A3)
        FISH(3,3)=REAL(2.0D0*DTERM1)
        FISH(2,1)=FISH(1,2)
        FISH(3,1)=FISH(1,3)
        FISH(3,2)=FISH(2,3)
C
        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')THEN
          DO120I=1,3
            WRITE(ICOUT,121)FISH(I,1),FISH(I,2),FISH(I,3)
  121       FORMAT('FISH(I,1),FISH(I,2),FISH(I,3) = ',3G15.7)
            CALL DPWRST('XXX','WRIT')
  120     CONTINUE
        ENDIF
C
        CALL SGECO(FISH,3,3,ITEMP,RCOND,XTEMP)
        IJOB=1
        CALL SGEDI(FISH,3,3,ITEMP,XTEMP,XTEMP(MAXNXT/2),IJOB)
        DO130J=1,3
          DO135I=1,3
            COV(I,J)=FISH(I,J)
  135     CONTINUE
  130   CONTINUE
C
C     TWEEDIE PARAMETERIZATION
C
      ELSE
        DTERM2=DGAMMA*DMU**3
        D=0.75D0/(DGAMMA**2*DMU**4) + 3.0D0/(DGAMMA**3*DMU**3)
C
        DTERM1=0.5D0/DTERM2
        COV(1,1)=REAL(DTERM1/D)
        DTERM1=-0.5D0/DTERM2
        COV(1,2)=REAL(DTERM1/D)
        DTERM1=-1.5D0*((1.0D0/DMU**4) + (1.0D0/DTERM2))
        COV(1,3)=REAL(DTERM1/D)
        DTERM1=1.5D0*((1.0D0/DMU**4) + (1.0D0/DTERM2))
        COV(2,3)=REAL(DTERM1/D)
        DTERM1=(0.5D0/DTERM2) + 0.75D0/(DGAMMA**3*DMU) +
     1         3.0D0/DGAMMA**4
        COV(2,2)=REAL(DTERM1/D)
        DTERM1=(4.5D0/(DGAMMA*DMU**5)) + (10.5D0/DMU**4) +
     1         (10.5D0/DTERM2)
        COV(3,3)=REAL(DTERM1/D)
        COV(2,1)=COV(1,2)
        COV(3,1)=COV(1,3)
        COV(3,2)=COV(2,3)
C
      ENDIF
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML5')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF IGML5--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)RCOND
 9012   FORMAT('RCOND = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        DO9020I=1,3
          WRITE(ICOUT,9021)COV(I,1),COV(I,2),COV(I,3)
 9021     FORMAT('COV(I,1),COV(I,2),COV(I,3) = ',3G15.7)
          CALL DPWRST('XXX','WRIT')
 9020   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE IGMO1(XMEAN,XSD,XMIN,XSKEW,N,PSTAMV,
     1                 ALOCMO,AMUMO,SIGMMO,GAMMMO,
     1                 ALOCMM,AMUMM,SIGMMM,GAMMMM,
     1                 ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES MOMENT AND MODIFIED MOMENT
C              ESTIMATES FOR THE 3-PARAMETER INVERSE GAUSSIAN
C              DISTRIBUTION.  THE INPUT VALUES ARE:
C
C                 XMEAN   - THE SAMPLE MEAN
C                 XSD     - THE SAMPLE STANDARD DEVIATION
C                 XSKEW   - THE SAMPLE SKEWNESS
C                 XMIN    - THE SAMPLE MINIMUM
C
C              THIS IS FOR THE UNCENSORED CASE.
C
C              NOTE THAT THERE ARE SEVERAL PARAMETERIZATIONS OF THE
C              INVERSE GAUSSIAN DISTRIBUTION.
C
C              1) DATAPLOT USES THE TWEEDIE PARAMETERIZATION.  THIS
C                 PARAMETERIZATION HAS SHAPE PARAMETERS MU AND GAMMA
C                 (COHEN CALLS THE GAMMA PARAMETER LAMBDA) AND A
C                 THRESHOLD (LOCATION) PARAMETER.  COHEN USES GAMMA
C                 FOR THE THRESHOLD PARAMETER.
C
C              2) THE COHEN ALGORITHM ESTIMATES THE PARAMETERS BASED
C                 ON THE CHAN RE-PARAMETERIZATION:
C
C                    GAMMA = LAMBDA
C                          = MU**3/SIGMA**2
C
C                 THE COHEN/WHITTEN ALGORITHM GIVEN HERE ESTIMATES THE
C                 LOCATION PARAMETER, MU, AND SIGMA.  NOTE THAT GAMMA
C                 CAN BE COMPUTED FROM THE MU AND SIGMA.
C
C                 NOTE THAT NO ESTIMATION WILL BE PERFORMED FOR THE
C                 CASE WHERE THE SKEWNESS PARAMETER IS NEGATIVE.
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 357-359.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION AMOM(3)
      DOUBLE PRECISION VMOM(5)
      DOUBLE PRECISION VMMOM(5)
      DOUBLE PRECISION A3
      DOUBLE PRECISION A3L
      DOUBLE PRECISION A3U
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION F
      DOUBLE PRECISION EPS
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNN
      DOUBLE PRECISION Z
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION VAL
      DOUBLE PRECISION VAL1
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='IGMO'
      ISUBN2='1   '
      IERROR='NO'
C
      ALOCMO=CPUMIN
      AMUMO=CPUMIN
      SIGMMO=CPUMIN
      GAMMMO=CPUMIN
      ALOCMM=CPUMIN
      AMUMM=CPUMIN
      SIGMMM=CPUMIN
      GAMMMM=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GMO1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF IGMO1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,54)XMEAN,XSD,XMIN,XSKEW
   54   FORMAT('XMEAN,XSD,XMIN,XSKEW = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS FOR THE      **
C               **  INVERSE GAUSSIAN MOMENT ESTIMATES   **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GMO1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(XMEAN.EQ.CPUMIN .OR. XMEAN.EQ.PSTAMV)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN GAMMA MOMENT ESTIMATION--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,102)
  102   FORMAT('      THE SAMPLE MEAN IS UNDEFINED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(XSD.EQ.CPUMIN .OR. XSD.EQ.PSTAMV .OR. XSD.LE.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,107)
  107   FORMAT('      THE SAMPLE STANDARD DEVIATION IS UNDEFINED OR ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(XSKEW.LE.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)
  112   FORMAT('      THE SAMPLE SKEWNESS IS NON-POSTIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,113)XSKEW
  113   FORMAT('      SKEWNESS = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(N.LT.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,122)
  122   FORMAT('      THE SAMPLE SIZE IS LESS THAN FIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,123)N
  123   FORMAT('      SAMPLE SIZE  = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 2--                            **
C               **  MOMENT ESTIMATES                    **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GMO1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     IN CODE BELOW:
C
C        VMOM(1) = ESTIMATE OF LOCATION
C        VMOM(2) = ESTIMATE OF MU
C        VMOM(3) = ESTIMATE OF SIGMA
C        VMOM(4) = ESTIMATE OF MEAN
C                = LOC + MU
C        VMOM(5) = A3 (THIRD STANDARD MOMENT)
C                = 3*SIGMA/MU
C     CODE FROM PAGE 357 OF COHEN AND WHITTEN
C
      AMOM(1)=DBLE(XMEAN)
      AMOM(2)=DBLE(XSD)
      AMOM(3)=DBLE(XSKEW)
C
      VMOM(3)=AMOM(2)
      VMOM(2)=3.0D0*VMOM(3)/AMOM(3)
      VMOM(1)=AMOM(1) - VMOM(2)
      VMOM(4)=VMOM(1) + VMOM(2)
      VMOM(5)=3.0D0*VMOM(3)/VMOM(2)
C
      ALOCMO=REAL(VMOM(1))
      AMUMO=REAL(VMOM(2))
      SIGMMO=REAL(VMOM(3))
      GAMMMO=REAL(VMOM(2)**3/VMOM(3)**2)
C
C     IN CODE BELOW:
C
C        VMMOM(1) = ESTIMATE OF LOCATION
C        VMMOM(2) = ESTIMATE OF MU
C        VMMOM(3) = ESTIMATE OF SIGMA
C        VMMOM(4) = ESTIMATE OF MEAN
C                 = LOC + MU
C        VMMOM(5) = A3 (THIRD STANDARD MOMENT)
C                 = 3*SIGMA/MU
C
C     COMPUTE MODIFIED MOMENT ESTIMATORS USING CODE FOUND ON
C     PP. 358-359 OF COHEN/WHITTEN BOOK.
C
C     IF XMIN PARAMETER NOT GIVEN, THEN SKIP THIS CASE.
C
      IF(XMIN.EQ.CPUMIN)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,212)
  212   FORMAT('      MINIMUM VALUE NOT SPECIFIED.  MODIFIED ',
     1         'MOMENTS WILL NOT BE COMPUTED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IERR=0
      EPS=0.1D-08
      DN=DBLE(N)
      DNN=1.0D0/(DN+1.0D0)
C
C     FIND THE STANDARDIZED FIRST ORDER STATISTIC
C
      Z=(DBLE(XMIN) - AMOM(1))/AMOM(2)
C
C     SET THE UPPER AND LOWER BOUND ON A3
C
      A3U=3.0D0*AMOM(2)/(AMOM(1)-DBLE(XMIN))
      A3L=0.18D0
C
C     CALCULATE FUNCTION AT UPPER AND LOWER BOUNDS, A3U
C
      FU=-DNN
      VAL=Z/DSQRT(1.0D0 + A3L*Z/3.0D0)
      CALL NODCDF(VAL,P1)
      VAL1=-VAL - 6.0D0/(A3L*DSQRT(1.0D0+A3L*Z/3.0D0))
      CALL NODCDF(VAL1,P2)
      FL=(P1+DEXP(18.D0/A3L**2)*P2)-DNN
C
C     DETERMINE IF THERE EXISTS AN A3 IN THE INTERVAL (A3L,A3U)
C     THAT SATISFIES THE EQUATION
C
      IF(FL*FU.GT.0.0D0)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,222)
  222   FORMAT('      NO MODIFIED MOMENT ESTIMATOR FOUND.')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ELSE
C
C       USE BINARY SEARCH TO FIND THE SOLUTUION OF THE MODIFIED
C       MOMENTS EQUATION.
C
        F=FL
300     CONTINUE
        A3=(A3U+A3L)/2.0D0
        IF(DABS(A3-A3L).GT.EPS)THEN
          VAL=Z/DSQRT(1.0D0 + A3*Z/3.0D0)
          CALL NODCDF(VAL,P1)
          VAL1=-VAL - 6.0D0/(A3*DSQRT(1.0D0+A3*Z/3.0D0))
          CALL NODCDF(VAL1,P2)
          F=(P1+DEXP(18.D0/A3**2)*P2)-DNN
          IF(F*FL.LT.0.0D0)THEN
            A3U=A3
          ELSE
            A3L=A3
            FL=F
          ENDIF
          A3=(A3U+A3L)/2.0D0
          GOTO300
        ELSE
          VMMOM(1)=AMOM(1) - 3.0D0*AMOM(2)/A3
          VMMOM(2)=3.0D0*AMOM(2)/A3
          VMMOM(3)=AMOM(2)
          VMMOM(4)=VMMOM(1)+ VMMOM(2)
          VMMOM(5)=A3
        ENDIF
      ENDIF
C
      ALOCMM=REAL(VMMOM(1))
      AMUMM=REAL(VMMOM(2))
      SIGMMM=REAL(VMMOM(3))
      GAMMMM=REAL(VMMOM(2)**3/VMMOM(3)**2)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GMO1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF IGMO1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)ALOCMO,AMUMO,SIGMMO,GAMMMO
 9012   FORMAT('ALOCMO,AMUMO,SIGMMO,GAMMMO = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)ALOCMM,AMUMM,SIGMMM,GAMMMM
 9013   FORMAT('ALOCMM,AMUMM,SIGMMM,GAMMMM = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE IGPDF(DX,DGAMMA,DMU,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY FUNCTION
C              VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER
C              MU.  ALTHOUGH MU IS ESSENTIALLY A SCALE PARAMETER, IT IS
C              NOT A SCALE PARAMETER IN THE TECHNICAL SENSE THAT THE
C              FOLLOWING RELATIONSHIP
C
C                  f(X;LOC,SCALE) = f((X-LOC)/SCALE;0,1)/SCALE
C
C              DOES NOT HOLD. THEREFORE, WE REFER TO IT AS A SHAPE
C              PARAMETER.
C
C              THE STANDARD FORM OF THE DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X AND HAS THE PROBABILITY DENSITY  FUNCTION
C              (PAGE 246 OF VOLUME 4 OF THE OF ENCYCLOPEDIA OF
C              STATISTICAL SCIENCES):
C
C                  f(X) = SQRT(GAMMA/(2*PI*X**3))*
C                         EXP((-GAMMA/(2*MU**2))*(X-MU)**2/X)
C
C              THE PARAMETERIZATION DESCRIBED ABOVE WILL BE REFERRED TO
C              AS THE "TWEEDIE" PARAMETERIZATION.  NOTE THAT WHAT WE
C              CALL GAMMA IS CALLED LAMBDA IN MANY REFERENCES.  A
C              RE-PARAMETERIZATION, WHICH WE CALL THE CHAN PARAMETERIZATION,
C              USES
C
C                 SIGMA = SQRT(MU**3/GAMMA)
C
C     NOTE--THE INVERSE GAUSSIAN DISTRIBUTION--
C           1) GOES FROM 0 TO INFINITY
C           2) HAS MEAN = MU
C           3) HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) = SIGMA
C           4) HAS SHAPE PARAMETER = GAMMA
C           5) IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C           6) IS SYMMETRIC AND MODERATE-TAILED FOR LARGE GAMMA
C           7) APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE FIRST SHAPE PARAMETER,
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SECOND SHAPE PARAMETER,
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE CDF FOR THE INVERSE GAUSSIAN DISTRIBUTION WITH
C             WITH TAIL LENGTH PARAMETER = GAMMA AND SHAP PARAMETER MU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X, GAMMA, M SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND JOHNSON, "ENCYCLOPEDIA OF STATISTICAL SCIENCES",
C                 VOLUME 4, PP. 246-249.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
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--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW PDF DEFINITION AND
C                                       REWRITTEN
C     UPDATED         --DECEMBER  2003. USE GENERAL VALUE OF MU
C                                       INSTEAD OF ASSUMING MU=1
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C
C-------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPI
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DLOW
      DOUBLE PRECISION DPDF
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
      DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 /
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPDF=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
        WRITE(ICOUT,51)
   51   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO IGPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)DGAMMA
   52   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DMU.LE.0.0D0 .AND. IGAUDF.NE.'STAN')THEN
        WRITE(ICOUT,71)
   71   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO IGPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)DMU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(IGAUDF.EQ.'STAN')THEN
        DLOW=-3.0D0/DGAMMA
        IF(DX.LE.DLOW)THEN
          WRITE(ICOUT,81)
   81     FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGPDF IS ',
     1           'LESS THAN -3/SHAPE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,52)DX
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,53)DLOW
   53     FORMAT('      THE VALUE OF -3/SHAPE IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(DX.LT.0.0D0)THEN
          WRITE(ICOUT,61)
   61     FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGPDF IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,52)DX
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
C     CHECK FOR:
C
C          1. CHAN PARAMETERIZATION: GAMMA = MU**3/SIGMA**2
C
C          2. CHAN "STANDARD" PARAMETERIZATION
C
C             f(X;alpha) = (1/SQRT(2*PI))*(3/(3+ALPHA*X))**(3/2)*
C                          EXP((-X**2/2)*(3/(3+ALPHA*X)))
C                          X > -3/ALPHA
C
      IF(IGAUDF.EQ.'STAN')THEN
        DTERM1=(3.0D0/(3.0D0 + DGAMMA*DX))**1.5D0*
     1         (1.0D0/DSQRT(2.0D0*DPI))
        DTERM2=DEXP(-(DX**2/2.0D0)*(3.0D0/(3.0D0+DGAMMA*DX)))
        DPDF=DTERM1*DTERM2
        GOTO9000
      ELSEIF(IGAUDF.EQ.'CHAN')THEN
        DGAMMA=DMU**3/DGAMMA**2
      ENDIF
C
      IF(DX.EQ.0.0D0)GOTO9000
C
      DTERM1=0.5D0*DLOG(DGAMMA/(2.0D0*DPI*DX**3))
      DTERM2=(-DGAMMA/(2.0D0*DMU*DMU*DX))
      DTERM3=(DX-DMU)**2
      DPDF=DTERM1 + DTERM2*DTERM3
      DPDF=DEXP(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGPPF(DP,DGAMMA,DMU,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION
C              VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION WITH TAIL
C              LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER MU.
C              ALTHOUGH MU IS ESSENTIALLY A SCALE PARAMETER, IT IS
C              NOT A SCALE PARAMETER IN THE TECHNICAL SENSE THAT THE
C              FOLLOWING RELATIONSHIP
C
C                  f(X;LOC,SCALE) = f((X-LOC)/SCALE;0,1)/SCALE
C
C              DOES NOT HOLD. THEREFORE, WE REFER TO IT AS A SHAPE
C              PARAMETER.
C
C              THE STANDARD FORM OF THE DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE X AND HAS CUMULATIVE DISTRIBUTION FUNCTION
C              (PAGE 247 OF VOLUME 4 OF THE OF ENCYCLOPEDIA OF
C              STATISTICAL SCIENCES.
C
C                  F(X) = NORCDF(SQRT(GAMMA/X)*(-1 + (X/MU))) +
C                         EXP(2*GAMMA/MU)*NORCDF(SQRT(GAMMA/X)*(1 + (X/MU)))
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY NUMERICALLY
C              INVERTING THE CDF FUNCTION.
C
C              THE PARAMETERIZATION DESCRIBED ABOVE WILL BE REFERRED TO
C              AS THE "TWEEDIE" PARAMETERIZATION.  NOTE THAT WHAT WE
C              CALL GAMMA IS CALLED LAMBDA IN MANY REFERENCES.  A
C              RE-PARAMETERIZATION, WHICH WE CALL THE CHAN PARAMETERIZATION,
C              USES
C
C                 SIGMA = SQRT(MU**3/GAMMA)
C
C     INPUT  ARGUMENTS--P      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE FIRST SHAPE PARAMETER,
C                                GAMMA SHOULD BE POSITIVE.
C                     --AMU    = THE SECOND SHAPE PARAMETER,
C                                AMU SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE INVERSE GAUSSIAN DISTRIBUTION WITH
C             WITH TAIL LENGTH PARAMETER = GAMMA AND SHAPE PARAMETER MU.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY).
C                 --GAMMA AND MU SHOULD BE POSITIVE
C     OTHER DATAPAC   SUBROUTINES NEEDED--IGCDF, NORCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ AND JOHNSON, "ENCYCLOPEDIA OF STATISTICAL SCIENCES",
C                 VOLUME 4, PP. 246-249.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., CHAPTER 5 AND
C                PP. 360-361.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --DECEMBER  2003. SUPPORT FOR MU NOT EQUAL 1
C     UPDATED         --APRIL     2014. CONVERT TO DOUBLE PRECISION
C     UPDATED         --APRIL     2014. SUPPORT FOR CHAN PARAMETERIZATION
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DMU
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION DX
      DOUBLE PRECISION TOL
      DOUBLE PRECISION DSD
      DOUBLE PRECISION XMIN
      DOUBLE PRECISION XMAX
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XMID
      DOUBLE PRECISION XDEL
      DOUBLE PRECISION PCALC
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
      IF(DGAMMA.LE.0.0D0)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER TO IGPPF IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DGAMMA
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DMU.LE.0.0D0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER TO IGPPF IS ',
     1          'NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST ARGUMENT TO IGPPF IS OUTSIDE')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      THE ALLOWABLE [0,1) INTERVAL.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)DP
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
      IF(DP.EQ.0.0D0)GOTO9000
C
C     CHECK FOR CHAN PARAMETERIZATION: GAMMA = MU**3/SIGMA**2
C
      IF(IGAUDF.EQ.'CHAN')THEN
        DGAMMA=DMU**3/DGAMMA**2
      ENDIF
C
      TOL=0.0000000001D0
      MAXIT=500
      XMIN=0.0D0
C
C     FROM THE KARLIN-STUDDEN INEQUALITY (PATEL/KAPADIA/OWEN, P. 30)
C     (BUT TRUE ONLY FOR X >= 1.5*MU)
C     FOR THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION,
C     MU = MU (AND HERE MU = 1)
CCCCC XMAX=10.0**30
C
      DSD=DSQRT(DMU**3/DGAMMA)
      XMAX=DMU/(2.0D0*(1.0D0-DP))
C
      XLOW=XMIN
      XUP=XMAX
C
CCCCC HOPEFULLY, SAM SAUNDERS CAN GIVE ME A BETTER
CCCCC FIRST APPROXIMATION TO G(P) THAN MY 1.0   !
CCCCC XMID=1.0
C
      XMID=DMU
      ICOUNT=0
C
  200 CONTINUE
      DX=XMID
      CALL IGCDF(DX,DGAMMA,DMU,PCALC)
C
      IF(PCALC.EQ.DP)THEN
        DPPF=XMID
        GOTO9000
      ELSEIF(PCALC.GT.DP)THEN
C
  220   CONTINUE
        XUP=XMID
        DX=XMID/2.0D0
        IF(DX.GT.XLOW)THEN
          XMID=DX
          CALL IGCDF(DX,DGAMMA,DMU,PCALC)
          IF(PCALC.EQ.DP)THEN
            DPPF=XMID
            GOTO9000
          ENDIF
          IF(PCALC.GT.DP)GOTO220
          XLOW=DX
        ENDIF
        XMID=(XLOW+XUP)/2.0D0
C
      ELSE
C
  210   CONTINUE
        XLOW=XMID
        DX=XMID*2.0D0
        IF(DX.LT.XUP)THEN
          XMID=DX
          CALL IGCDF(DX,DGAMMA,DMU,PCALC)
          IF(PCALC.EQ.DP)THEN
            DPPF=XMID
            GOTO9000
          ENDIF
          IF(PCALC.LT.DP)GOTO210
          XUP=DX
        ENDIF
        XMID=(XLOW+XUP)/2.0D0
      ENDIF
C
      XDEL=DABS(XMID-XLOW)
      ICOUNT=ICOUNT+1
      IF(XDEL.LT.TOL .OR. ICOUNT.GT.MAXIT)THEN
        DPPF=XMID
        GOTO9000
      ENDIF
      GOTO200
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IGRAN(N,GAMMA,AMU,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERSE GAUSSIAN DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = GAMMA
C              AND LOCATION PARAMETER MU = 1.
C              THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM
C              OF ENCYCLOPEDIA OF STATISTICAL SCIENCES
C                 WITH MU = 1
C     NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION--
C              GOES FROM 0 TO INFINITY
C              HAS MEAN = MU (HERE = 1)
C              HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA)
C              HAS SHAPE PARAMETER = GAMMA
C              IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA
C              IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA
C              APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY
C     NOTE--TO OBTAIN THE PDF FOR GENERAL MU,
C           COMPUTE THE PDF FOR X AROUND 1, AND THEN
C           SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU
C           AS IN Y2 = MU*Y
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERSE GAUSSIAN DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE HEREIN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES
C                 VOLUME 4, PAGE 247, COLUMN 1 (FOR CDF).
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C     VERSION NUMBER--90.6
C     ORIGINAL VERSION--MAY       1990.
C     UPDATED         --JANUARY   1995. NEW CDF DEFINITION & REWRITTEN
C     UPDATED         --NOVEMBER  2003. USE MICHEAL/SCHUCANY/HAAS
C                                       METHOD (FROM JAMES GENTLE
C                                       "RANDOM NUMBER GENERATION AND
C                                       MONTE CARLO METHODS", SECOND
C                                       EDITION, SPRINGER-VARLANG,
C                                       2003, P. 193.
C     UPDATED         --APRIL     2014. SUPPORT CHAN PARAMETERIZATION
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
         WRITE(ICOUT,51)
   51    FORMAT('***** ERROR--THE REQUESTED NUMBER OF INVERSE ',
     1          'GAUSSIAN RANDOM NUMBERS IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,52)N
   52    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(GAMMA.LE.0.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE GAMMA SHAPE PARAMETER FOR THE ',
     1          'INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)GAMMA
   63    FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ELSEIF(AMU.LE.0.0)THEN
         WRITE(ICOUT,71)
   71    FORMAT('***** ERROR--THE MU SHAPE PARAMETER FOR THE',
     1          ' INVERSE GAUSSIAN')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,72)
   72    FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)AMU
         CALL DPWRST('XXX','BUG ')
         GOTO9000
      ENDIF
C
C     CHECK FOR CHAN PARAMETERIZATION: GAMMA = MU**3/SIGMA**2
C
      IF(IGAUDF.EQ.'CHAN')THEN
        GAMMA=AMU**3/GAMMA**2
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
CCCCC CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N INVERSE GAUSSIAN DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
CCCCC DO100I=1,N
CCCCC XI=X(I)
CCCCC CALL IGPPF(XI,GAMMA,X(I))
C 100 CONTINUE
C
C     MICHEAL/SCHUCANY/HAAS ALGORITHM.
C
C     GENERATE N NORMAL (0,1) RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
      NTEMP=1
      DO100I=1,N
        Y=X(I)*X(I)
        X1=AMU + AMU*AMU*Y/(2.0*GAMMA) -
     1     (AMU/(2.0*GAMMA))*SQRT(4.0*AMU*GAMMA*Y + AMU*AMU*Y*Y)
        CALL UNIRAN(NTEMP,ISEED,X(I))
        U=X(I)
        IF(U.LE.AMU/(AMU+X1))THEN
          X(I)=X1
        ELSE
          X(I)=AMU*AMU/X1
        ENDIF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
C***BEGIN PROLOGUE  IMTQL2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  EIGENVALUES,EIGENVECTORS,EISPACK
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues and eigenvectors of symmetric
C            tridiagonal matrix using implicit QL method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure IMTQL2,
C     NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson,
C     as modified in NUM. MATH. 15, 450(1970) by Dubrulle.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method.
C     The eigenvectors of a FULL SYMMETRIC matrix can also
C     be found if  TRED2  has been used to reduce this
C     full matrix to tridiagonal form.
C
C     On INPUT
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C
C        Z contains the transformation matrix produced in the
C          reduction by  TRED2, if performed.  If the eigenvectors
C          of the tridiagonal matrix are desired, Z must contain
C          the identity matrix.
C
C      On OUTPUT
C
C        D contains the eigenvalues in ASCENDING order.  If an
C          error exit is made, the eigenvalues are correct but
C          UNORDERED for indices 1,2,...,IERR-1.
C
C        E has been destroyed.
C
C        Z contains orthonormal eigenvectors of the symmetric
C          tridiagonal (or full) matrix.  If an error exit is made,
C          Z contains the eigenvectors associated with the stored
C          eigenvalues.
C
C        IERR is set to
C          ZERO       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  IMTQL2
C
      INTEGER I,J,K,L,M,N,II,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL B,C,F,G,P,R,S,S1,S2
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  IMTQL2
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
        E(I-1) = E(I)
  100 CONTINUE
C
      E(N) = 0.0E0
C
      DO 240 L = 1, N
         J = 0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            S1 = ABS(D(M)) + ABS(D(M+1))
            S2 = S1 + ABS(E(M))
            IF (S2 .EQ. S1) GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         G = (D(L+1) - P) / (2.0E0 * E(L))
         R = PYTHAG(G,1.0E0)
         G = D(M) - P + E(L) / (G + SIGN(R,G))
         S = 1.0E0
         C = 1.0E0
         P = 0.0E0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF (ABS(F) .LT. ABS(G)) GO TO 150
            C = G / F
            R = SQRT(C*C+1.0E0)
            E(I+1) = F * R
            S = 1.0E0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = SQRT(S*S+1.0E0)
            E(I+1) = G * R
            C = 1.0E0 / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + 2.0E0 * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
C     .......... FORM VECTOR ..........
            DO 180 K = 1, N
               F = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * F
               Z(K,I) = C * Z(K,I) - S * F
  180       CONTINUE
C
  200    CONTINUE
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = 0.0E0
         GO TO 105
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE INITDA(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITDA.
C              (THE   DA    AT THE END OF    INITDA   STANDS FOR   DATA)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1989.  SOFT-CODING (ALAN)
C     UPDATED         --JULY      1989.  MAXCP1/2/3/4/5/6
C     UPDATED         --JANUARY   1998.  ADD MAXROM, MAXCOM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBLANK
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989
      INCLUDE 'DPCOM2.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INITDA--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
      IBLANK=' '
      IZERO=0
      ZERO=0.0
C
C               *****************************************************
C               **  INITIALIZE                                     **
C               **  THE MAXIMUM TOTAL NUMBER OF OBSERVATIONS, AND  **
C               **  THE TOTAL NUMBER OF OBSERVATIONS               **
C               *****************************************************
C
CCCCC MAXNK=10000
      MAXNK=MAXOBW
      NK=0
C
C               ************************************************************
C               **  INITIALIZE                                            **
C               **  THE MAXIMUM NUMBER OF OBSERVATIONS PER VARIABLE, AND  **
C               **  THE NUMBER OF OBSERVATIONS PER VARIABLE               **
C               ************************************************************
C
CCCCC IDEMXN=1000        ALAN HAS THIS ON THE CYBER
      IDEMXN=MAXOBV
      MAXN=IDEMXN
      N=0
C
C               ********************************************
C               **  INITIALIZE                            **
C               **  THE MAXIMUM NUMBER OF VARIABLES, AND  **
C               **  THE NUMBER OF VARIABLES (COLUMNS)     **
C               ********************************************
C
CCCCC IDEMXC=10
CCCCC IDEMXC=MAXNK/IDEMXN   ALAN HAS THIS ON THE CYBER
      IDEMXC=MAXOBW/MAXOBV
      MAXCOL=IDEMXC
      NUMCOL=0
C
CCCCC THE FOLLOWING 6 LINES WERE ADDED JULY 1989
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
C               ****************************************************************
C               **  INITIALIZE
C               **  THE MAXIMUM TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS, AN
C               **  THE TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS
C               ****************************************************************
C
CCCCC MAXCHF=1000
      MAXCHF=MAXF1
      NUMCHF=0
C
C               ********************************************
C               **  INITIALIZE                            **
C               **  THE MAXIMUM NUMBER OF FUNCTIONS, AND  **
C               **  THE NUMBER OF FUNCTIONS               **
C               ********************************************
C
CCCCC MAXFUN=100
      MAXFUN=MAXFN2
      NUMFUN=0
C
C               **********************************************
C               **  INITIALIZE THE MAXIMUM TOTAL NUMBER OF  **
C               **  CHARACTERS (THAT WILL BE PRINTED)       **
C               **  (IN THE    STATUS    COMMAND OUTPUT)    **
C               **  FOR THE LAST MODEL FITTED.              **
C               **********************************************
C
CCCCC MAXCHM=200
      MAXCHM=MAXF3
      NUMCHM=0
C
C               **********************************************
C               **  INITIALIZE                              **
C               **  THE MAXIMUM NUMBER OF CONSTRAINTS, AND  **
C               **  THE NUMBER OF CONSTRAINTS               **
C               **********************************************
C
      MAXCON=100
      NUMCON=0
C
CCCCC FOLLOWING SECTION ADDED JANUARY 1998.
C               **********************************************
C               **  INITIALIZE                              **
C               **  THE MAXIMUM NUMBER OF ROWS AND COLUMNS  **
C               **  IN A MATRIX                             **
C               **********************************************
C
      MAXCOM=100
      MAXROM=INT((46.0*REAL(MAXOBV)/3.0)/100.0)
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9911)
 9911 FORMAT('***** AT THE END       OF INITDA--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)MAXN,N
 9012 FORMAT('MAXN,N = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)MAXCOL,NUMCOL
 9013 FORMAT('MAXCOL,NUMCOL = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)MAXNK,NK
 9014 FORMAT('MAXNK,NK      = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)MAXCHF,NUMCHF
 9015 FORMAT('MAXCHF,NUMCHF = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9016)MAXCHM,NUMCHM
 9016 FORMAT('MAXCHM,NUMCHM = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)MAXCON,NUMCON
 9017 FORMAT('MAXCON,NUMCON = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)MAXOBV,MAXOBW
 9021 FORMAT('MAXOBV,MAXOBW = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITDB
C
C     PURPOSE--THIS IS SUBROUTING INITDB.
C              (THE   DB    AT THE END OF    INITDB   STANDS FOR   DEBUGGI
C              THIS SUBROUTINE INITIALIZES DEBUGGING VARIABLES AND PARAMETERS
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCODB.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INITDB--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)
   52 FORMAT('      NOTE--SINCE    IBUGIN   WILL BE SET TO    OFF ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)
   53 FORMAT('      WITHIN THIS SUBROUTINE, THERE WILL BE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)
   54 FORMAT('      NO MESSAGE AT THE END OF THIS SUBROUTINE.')
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ***********************************************
C               **  INITIALIZE THE BUG VECTOR                **
C               **  (THE VECTOR WHERE THE BUG PARAMETERS     **
C               **  ARE PLACED)                              **
C               ***********************************************
C
      MAXBUG=100
      NUMBUG=0
C
      DO100I=1,MAXBUG
      IH1BUG(I)='OFF'
CCCCC IH1BUG(I)='ON'
  100 CONTINUE
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INITDB--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITDE(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITDE.
C              (THE   DE    AT THE END OF    INITDE
C              STANDS FOR DESIGN OF EXPERIMENTS
C              THIS SUBROUTINE INITIALIZES DESIGN-OF-EXPERIMENT
C              PARAMETERS
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89/6
C     ORIGINAL VERSION--MAY 1989.
C     UPDATED         --AUGUST    1993. BUG FIX
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
CCCCC AUGUST 1993.  COMPILE ERROR ON RS-6000, ADD FOLLOWING LINE
      CHARACTER*4 ITEXT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCODE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INITDE--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
C               ***********************************************
C               **  SET THE DESIGN OF EXPERIMENT SETTINGS    **
C               **     IDEXDE = DEPTH INTO INTERACTION TERMS **
C               **              1 = MAIN EFFECTS ONLY        **
C               **              2 = UP TO 2-TERM INTERACTIONS**
C               **              ETC.                         **
C               **     DEXWID = WIDTH ON THE PLOT ACROSS     **
C               **              ALL LEVELS WITHIN A FACTOR   **
C               **     IDEXHA = HORIZONTAL AXIS VARIABLE     **
C               **              DEFAULT = 'FACT'             **
C               **              CAN ALSO HAVE 'TERM'         **
C               ***********************************************
C
      IDEDED=1
      DEFDEW=0.4
      IDEFHA='FACT'
C
      IDEXDE=1
      DEXWID=0.4
      IDEXHA='FACT'
C
C               **************************************************
C               **  INITIALIZE EXPERIMENTAL SIMULATION SETTINGS **
C               **************************************************

C               **************************************************
C               **  INITIALIZE EXPERIMENTAL SIMULATION SETTINGS **
C               **     GMEAN     = GRAND MEAN                   **
C               **     NUMB      = TOTAL NUMBER OF COEFFICIENTS **(EXCLUDING GRA
C               **     INDEXB(.) = INDEX FOR COEFFICIENTS (EXCLU**DING GRAND MEA
C               **     B(.)      = COEFFICIENTS (EXCLUDING GRAND** MEAN)
C               **     GSD       = GENERAL STANDARD DEVIATION   **
C               **               = SD OF ERROR IN Y = GRAND MEAN** + ERROR
C               **     NUMS      = XX                           **
C               **     BMINT     = INTERCEPT FOR GRAND MEAN DRIF**T IN TIME
C               **     BMSLOP    = SLOPE     FOR GRAND MEAN DRIF**T IN TIME
C               **     DSINT     = INTERCEPT FOR SD         DRIF**T IN TIME
C               **     DSSLOP    = SLOPE     FOR SD         DRIF**T IN TIME
C               **************************************************
C
      ISIMID=0
      IAUTH='BOXB'
      ITEXT='TECH'
      IPAGE=17
C
      GMEAN=71.25
      NUMB=7
      INDEXB(1)=1
      INDEXB(2)=2
      INDEXB(3)=3
      INDEXB(4)=12
      INDEXB(5)=13
      INDEXB(6)=23
      INDEXB(7)=123
      B(1)=23.0
      B(2)=(-5.0)
      B(3)=1.5
      B(4)=1.5
      B(5)=10.0
      B(6)=0.0
      B(7)=0.5
C
CCCCC GSD=0.1
      GSD=0.0
      NUMS=0
C
      BMINT=0.0
      BMSLOP=0.0
C
      DSINT=0.0
      DSSLOP=0.0
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INITDE--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      FUNCTION INITDS (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITDS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITDS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     double precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  INITDS
      DOUBLE PRECISION OS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C***FIRST EXECUTABLE STATEMENT  INITDS
      IF (NOS .LT. 1) THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR FROM INITDS.  THE NUMBER OF ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      COEFFICIENTS IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        INITDS = 0
        RETURN
      ENDIF
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(REAL(OS(I)))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) THEN
      WRITE(ICOUT,21)
 21   FORMAT('***** ERROR FROM INITDS.  CHEBYSHEV SERIES TOO ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,22)
 22   FORMAT('      SHORT FOR SPECIFIED ACCURACY.             *****')
      CALL DPWRST('XXX','BUG ')
      ENDIF
      INITDS = I
C
      RETURN
      END
      BLOCK DATA INITD1
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (ISUB(I),I=1,MAXOBV) /MAXOBV*0/
CCCCC DATA (I1DATA(I),I=1,100) /100*0/
C
CCCCC DATA (PARLIM(I),I=1,100) /100*0./
C
      DATA ISUB /MAXOBV*0/
      DATA I1DATA /100*0/
C
      DATA PARLIM /100*0./
C
      END
      BLOCK DATA INITD2
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (PRED(I),I=1,MAXOBV) /MAXOBV*0./
CCCCC DATA (RES(I),I=1,MAXOBV) /MAXOBV*0./
C
      DATA PRED /MAXOBV*0./
      DATA RES /MAXOBV*0./
C
      END
      BLOCK DATA INITD3
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (X(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X /MAXPOP*0./
C
      END
      BLOCK DATA INITD4
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (YPLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA YPLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITD5
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD23
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA ((AMATR1(I,J),I=1,100),J=1,100) /10000*0./
      DATA AMATR1 /10000*0./
C
      END
      BLOCK DATA INITD6
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (X3D(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X3D /MAXPOP*0./
C
      END
      BLOCK DATA INID7A
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7A
C              THIS INITIALIZES THE REAL DATA ARRAY D(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (D(I),I=1,MAXPOP) /MAXPOP*0./
      DATA D /MAXPOP*0./
C
      END
      BLOCK DATA INID7B
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7B
C              THIS INITIALIZES THE REAL DATA ARRAY DSIZE(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DSIZE(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DSIZE /MAXPOP*0./
C
      END
      BLOCK DATA INID7C
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7C
C              THIS INITIALIZES THE REAL DATA ARRAY DSYMB(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DSYMB(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DSYMB /MAXPOP*0./
C
      END
      BLOCK DATA INID7D
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7D
C              THIS INITIALIZES THE REAL DATA ARRAY DCOLOR(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DCOLOR(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DCOLOR /MAXPOP*0./
C
      END
      BLOCK DATA INID7E
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INID7E
C              THIS INITIALIZES THE REAL DATA ARRAY DFILL(.).
C              BLOCK DATA IS USED FOR SPEED
C              SINCE DONE AT LOAD TIME--NOT AT RUN TIME.
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     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--92/10
C     ORIGINAL VERSION--SEPTEMBER 1992.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC DATA (DFILL(I),I=1,MAXPOP) /MAXPOP*0./
      DATA DFILL /MAXPOP*0./
C
      END
      BLOCK DATA INITD8
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (X2PLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA X2PLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITD9
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (XPLOT(I),I=1,MAXPOP) /MAXPOP*0./
      DATA XPLOT /MAXPOP*0./
C
      END
      BLOCK DATA INITDZ
C
C     PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22
C              THIS INITIALIZES THE REAL DATA ARRAYS (ONCE).  USE BLOCK
C              DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME)
C              THIS SUBROUTINE INITIALIZES DATA VARIABLES
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--OCTOBER   1991.
C     UPDATED         --OCTOBER   1993.  DIFFERENT SYNTAX (SGI VERSION
C                                        BOMBS ON OLD SYNTAX)
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCODA.INC'
C
C-----START POINT-----------------------------------------------------
C
C
CCCCC DATA (TAGPLO(I),I=1,MAXPOP) /MAXPOP*0./
      DATA TAGPLO /MAXPOP*0./
C
      END
      SUBROUTINE INITH2(IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
     1IVALUE,VALUE,NUMNAM,MAXN,MAXCOL,IBUGIN)
C
C     PURPOSE--ENTER INFORMATION ABOUT THE
C              PRED (= PREDICTED VALUES) VECTOR AND
C              RES  (= RESIDUALS       ) VECTOR
C              INTO THE HOUEKEEPING TABLES.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82/7
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IHNAME
      CHARACTER*4 IHNAM2
      CHARACTER*4 IUSE
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
      DIMENSION IHNAME(*)
      DIMENSION IHNAM2(*)
      DIMENSION IUSE(*)
      DIMENSION IN(*)
      DIMENSION IVSTAR(*)
      DIMENSION IVSTOP(*)
      DIMENSION IVALUE(*)
      DIMENSION VALUE(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INITH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NUMNAM,MAXCOL,MAXN,CPUMAX
   52 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='PRED'
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+1
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='RES'
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+2
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='INFI'
      IHNAM2(NUMNAM)='NITY'
      IUSE(NUMNAM)='P'
      VALUE(NUMNAM)=CPUMAX
CCCCC ITEMP=2**(NUMBPW-2)
CCCCC ITEMP2=ITEMP-1
CCCCC IVALUE(NUMNAM)=ITEMP2+ITEMP
      IVALUE(NUMNAM)=999999
      IN(NUMNAM)=1
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='PI  '
      IHNAM2(NUMNAM)='    '
      IUSE(NUMNAM)='P'
      VALUE(NUMNAM)=3.1415926535898
      IVALUE(NUMNAM)=INT(VALUE(NUMNAM))
      IN(NUMNAM)=1
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='YPLO'
      IHNAM2(NUMNAM)='T   '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+3
      VALUE(NUMNAM)=INT(IVALUE(NUMNAM))
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='XPLO'
      IHNAM2(NUMNAM)='T   '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+4
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='X2PL'
      IHNAM2(NUMNAM)='OT  '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+5
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
      NUMNAM=NUMNAM+1
      IHNAME(NUMNAM)='TAGP'
      IHNAM2(NUMNAM)='LOT '
      IUSE(NUMNAM)='V'
      IVALUE(NUMNAM)=MAXCOL+6
      VALUE(NUMNAM)=IVALUE(NUMNAM)
      IN(NUMNAM)=MAXN
      N=IN(NUMNAM)
      ICOLVJ=IVALUE(NUMNAM)
      IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1
      IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
      IF(IBUGIN.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INITH2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)NUMNAM,MAXCOL,MAXN,CPUMAX
 9012 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INITL (P, X, N0, N, MU, SIGMA,
     1                  FUNC, DEVIAT, IFAULT)
C
C       ALGORITHM AS 95.1 APPL. STATIST. (1976) VOL.25, NO.1
C
C       COMPUTES ROUGH LEAST SQUARES ESTIMATES OF MU AND SIGMA
C       ( FOR DEFINITION OF MU AND SIGMA SEE SUBROUTINE CURVE ).
C
C       THIS IS JUST USED TO FIND STARTING VALUES FOR "CURVE"
C       ROUTINE (WHICH IS USED TO ESTIMATE LOCATION/SCALE FOR
C       GROUPED DATA WHEN THE DISTRIBUTION HAS NO SHAPE
C       PARAMETERS).
C
      INTEGER P
      REAL MU, ONE, ZERO
      DIMENSION X(P), N(P)
C
      EXTERNAL FUNC
      EXTERNAL DEVIAT
C
      DATA ONE/1.0/
      DATA ZERO/0.0/
C
C       ERROR EXIT IF P TOO SMALL
C
      IF (P.LT.2) THEN
         IFAULT = 1
         GOTO9000
      ENDIF
      IFAULT = 0
C
C       COMPUTE AND FLOAT SUM OF FREQUENCIES
C
      NSUM = N0
      DO 10 I = 1, P
        NSUM = NSUM + N(I)
 10   CONTINUE
      XNSUM = FLOAT(NSUM)
C
C       ZERO ACCUMULATORS
C
      NPAR = N0
      XBAR = ZERO
      YBAR = ZERO
      SXX = ZERO
      SXY = ZERO
      SW = ZERO
C
C       COMPUTE WEIGHTED MEANS XAR, YBAR, AND CORRECTED SUMS
C       OF X*X AND X*Y.
C
      DO 30 I = 1, P
C
C       NULL FREQUENCIES AT EITHER END OF THE RANGE ARE
C       ZERO WEIGHTED
C
        IF (NPAR.EQ.0 .OR. NPAR.EQ.NSUM) GO TO 20
        PROB = REAL(NPAR)/XNSUM
        Y = DEVIAT(PROB)
        CALL FUNC (Y, DUMMY, DFY)
        DX = X(I) - XBAR
        DY = Y - YBAR
        W = DFY*DFY/(PROB*(ONE - PROB))
        SW = SW + W
        FAC = W/SW
        XBAR = XBAR + FAC*DX
        YBAR = YBAR + FAC*DY
        FAC = W*DX*(ONE - FAC)
        SXX = SXX + FAC*DX
        SXY = SXY + FAC*DY
 20     NPAR = NPAR + N(I)
 30   CONTINUE
      SIGMA = SXX/SXY
      MU = XBAR - SIGMA*YBAR
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE INITOD(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITOD.
C              (THE   OD    AT THE END OF    INITOD   STANDS FOR   OUTPUT
C              THIS SUBROUTINE INITIALIZES OUTPUT DEVICE VARIABLES AND PARAMETER
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--SEPTEMBER 1980.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --FEBRUARY  1989.  SOFT-CODE SETTINGS (ALAN)
C     UPDATED         --FEBRUARY  1989.  DEVICE ... OFFSET (ALAN)
C     UPDATED         --FEBRUARY  1989.  DEVICE-DEPENDENT COMMON (ALAN)
C     UPDATED         --MARCH     1990.  X11 DEVICE COMMON
C     UPDATED         --MAY       1990.  DEVICE DEPENDENT COMMON UPDATES
C     UPDATED         --NOVEMBER  1990.  POSTSCRIPT MARGINS (ALAN)
C     UPDATED         --JANUARY   1991.  DEFINE REGIS COLOR TABLES (ALAN)
C     UPDATED         --MAY       1991.  TURBO-C SETTINGS (JJF)
C     UPDATED         --MAY       1991.  COSMETIC BLOCKING (JJF)
C     UPDATED         --OCTOBER   1991.  ADDED POSTSCRIPT SPACE (ALAN)
C     UPDATED         --MAY       1992.  POSTCRIPT INITIAL BLANK PAGE
C     UPDATED         --MAY       1992.  ADD IBM/TURBOC COMMENT LINES
C     UPDATED         --MAY       1992.  (RE)ADD ICOMLI AND NCOMLI
C     UPDATED         --MAY       1992.  IDCODE(.) TO AVOID UNDEF. IN PLOTG2
C     UPDATED         --JUNE      1992.ICOMLI/NCOMLI => PLOTFC/NPLOTF
C     UPDATED         --JULY      1992.TCPLFI & TCTEFI: OFF => CLOS
C     UPDATED         --SEPTEMBER 1993. DECLARE DUMMY ISUBRO
C     UPDATED         --JUNE      1994. HARDWARE FILL SWITCHES
C     UPDATED         --FEBRUARY  1996. MOVE CALL TCINCO BACK TO MAIN
C     UPDATED         --JULY      1996. LAHEY DEVICE DRIVER
C     UPDATED         --JULY      1996. DEVICE ... FONT
C     UPDATED         --NOVEMBER  1996. MICROSOFT QWIN DEVICE DRIVER
C     UPDATED         --APRIL     1997. CHANGE IX11PM DEFAULT
C     UPDATED         --APRIL     1997. ADD DPCOPM
C     UPDATED         --OCTOBER   1997. IX11W2
C     UPDATED         --DECEMBER  1997. IGENFA
C     UPDATED         --FEBRUARY  1998. IPRNTR
C     UPDATED         --MARCH     2002. SVG DEVICE
C     UPDATED         --SEPTEMBER 2007. AQUATERM VALUES
C     UPDATED         --MARCH     2008. GD VALUES
C     UPDATED         --APRIL     2009. UNIX LIBPLOT VALUES
C     UPDATED         --JANUARY   2014. CAIRO VALUES
C     UPDATED         --JULY      2015. ISVGBU
C     UPDATED         --OCTOBER   2015. IQWNFL
C     UPDATED         --DECEMBER  2015. ICNTD2, ICNTD3
C     UPDATED         --DECEMBER  2018. PDSCAL
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
C
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
      CHARACTER*4 ISUBRO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCODV.INC'
      INCLUDE 'DPCOST.INC'
CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED FEBRUARY 1989
      INCLUDE 'DPCOGR.INC'
CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED APRIL 1997
      INCLUDE 'DPCOPM.INC'
C
      COMMON/QUICKW5/IQWNFL
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC THE FOLLOWING LINE WAS ADDED    SEPTEMBER 1993
CCCCC TO ALLOW AN ARGUMENT MATCH      SEPTEMBER 1993
CCCCC IN THE CALL TO TCINCO(ISUBRO)   SEPTEMBER 1993
      ISUBRO='DUMM'
C
      IF(IBUGIN.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INITOD--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ****************************************
C               **  TREAT THE NUMBER OF DEVICES CASE  **
C               ****************************************
C
CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989
CCCCC MAXDEV=10
      MAXDEV=MAXDV
      NUMDEV=1
C
C               **********************************************
C               **  TREAT THE DEVICE ... MANUFACTURER CASE  **
C               **********************************************
C
      IDEFMA='TEKT'
      IDEFMO='4014'
      IDEFM2='    '
      IDEFM3='    '
C
      DO1110I=1,MAXDEV
        IDMANU(I)='    '
        IDMODE(I)='    '
        IDMOD2(I)='    '
        IDMOD3(I)='    '
 1110 CONTINUE
C
      IDMANU(1)=IDEFMA
      IDMODE(1)=IDEFMO
      IDMOD2(1)=IDEFM2
      IDMOD3(1)=IDEFM3
C
C               **************************************
C               **  TREAT THE DEVICE ... POWER CASE **
C               **************************************
C
      IDEFPO='ON'
C
      DO1210I=1,MAXDEV
        IDPOWE(I)='OFF'
 1210 CONTINUE
C
      IDPOWE(1)=IDEFPO
C
C     2015/12: INITIALIZE DEVICE COUNTERS
C
      ICNTD2=0
      ICNTD3=0
C
C               ********************************************
C               **  TREAT THE DEVICE ... CONTINUOUS CASE  **
C               ********************************************
C
      IDEFCN='ON'
C
      DO1310I=1,MAXDEV
        IDCONT(I)='ON'
 1310 CONTINUE
C
      IDCONT(1)=IDEFCN
C
C               ********************************************
C               **  TREAT THE DEVICE ... COLOR      CASE  **
C               ********************************************
C
      IDEFDC='OFF'
C
      DO1410I=1,MAXDEV
        IDCOLO(I)='OFF'
 1410 CONTINUE
C
      IDCOLO(1)=IDEFDC
C
C               *************************************************
C               **  TREAT THE DEVICE ... PICTURE POINTS CASE   **
C               *************************************************
C
      IDEFVP=3124
      IDEFHP=4096
CCCCC IDEFVP=781
CCCCC IDEFHP=1024
C
      DO1510I=1,MAXDEV
        IDNVPP(I)=(-999)
        IDNHPP(I)=(-999)
 1510 CONTINUE
C
      IDNVPP(1)=IDEFVP
      IDNHPP(1)=IDEFHP
C
C               ********************************************
C               **  TREAT THE DEVICE ... UNIT NUMBER CASE **
C               ********************************************
C
CCCCC IDEFUN=6
CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989
CCCCC IDEFUN=IPR
      IDEFUN=IPRGR
C
      DO1610I=1,MAXDEV
        IDUNIT(I)=IDEFUN
CCCCC THE FOLLOWING LINE WAS ADDED TO AVOID PLOTG2 UNDEFINED ERROR MAY 1992
CCCCC THE FOLLOWING LINE WAS CHANGED FROM CHAR TO INT   OCTOBER 1992
CCCCC IDCODE(I)='JUNK'
      IDCODE(I)=0
 1610 CONTINUE
C
C               **************************************************************
C               **  TREAT THE DEVICE ... OFFSET      CASE    FEBRUARY 1989  **
C               **************************************************************
C
CCCCC IDEFUN=6
      IDEFOV=0
      IDEFOH=0
C
      DO1620I=1,MAXDEV
        IDNVOF(I)=IDEFOV
        IDNHOF(I)=IDEFOH
 1620 CONTINUE
C
C               ********************************************
C               **  TREAT THE DEVICE ... BAUD RATE CASE   **
C               ********************************************
C
      IDEFBA=1200
C
      DO1710I=1,MAXDEV
      IDBAUD(I)=IDEFBA
 1710 CONTINUE
CCCCC ADD FOLLOWING SECTION JULY 1996.
C
C               ********************************************
C               **  TREAT THE DEVICE ... FONT       CASE  **
C               ********************************************
C
      IDEFFN='OFF'
C
      DO1810I=1,MAXDEV
        IDFONT(I)=IDEFFN
        PDSCAL(I)=1.0
 1810 CONTINUE
C
C               ********************************************
C               **  TREAT THE HARDCOPY             CASE   **
C               ********************************************
C
      ICOPSW='OFF'
      NUMCOP=1
C
C               ********************************************
C               **  TREAT THE SET PRINTER          CASE   **
C               ********************************************
C
      IPRNTR=' '
      NCPRNT=0
C
C               *********************************************
C               **  TREAT THE FILE CASE                    **
C               **  (FILE, CALCOMP, VERSATEC, ZETA, ETC.)  **
C               *********************************************
C
C               *******************************
C               **  TREAT THE METAFILE CASE  **
C               *******************************
C
C               **************************************************************
C               **  TREAT THE DEVICE-DEPENDENT COMMON CASE    FEBRUARY 1989 **
C               **************************************************************
C
C----------CALCOMP----------
C
      ICALSW='OFF'
      ICALCL=4
      ICALCC=-999
      PCALTH=0.05
C  FOLLOWING LINES ADDED FOR CALCOMP MAY, 1990.
      ICALPF='OFF'
      ICALPM(1)='BLAC'
      ICALPM(2)='RED'
      ICALPM(3)='BLUE'
      ICALPM(4)='GREE'
      ICALPM(5)='BLAC'
      ICALPM(6)='RED'
      ICALPM(7)='BLUE'
      ICALPM(8)='GREE'
      ICALPM(9)='BLAC'
      ICALPM(10)='RED'
      ICALPM(11)='BLUE'
      ICALPM(12)='GREE'
      ICALPM(13)='BLAC'
      ICALPM(14)='RED'
      ICALPM(15)='BLUE'
      ICALPM(16)='GREE'
C
CCCCC ADD LAHEY DEVICE INITIALIZATION JULY 1996.
C----------CALCOMP----------
C
      ILAHSW='OFF'
      ILAHPA='OFF'
      ILAHGR='DIRE'
      ILAHCL='OFF'
      ILAHSW='OFF'
      ILAHNC=8
      ILAHCC=-999
      PLAHTH=0.05
C  FOLLOWING LINES ADDED FOR LAHCOMP MAY, 1990.
      ILAHPF='OFF'
      ILAHPM(1)='BLAC'
      ILAHPM(2)='RED'
      ILAHPM(3)='BLUE'
      ILAHPM(4)='GREE'
      ILAHPM(5)='BLAC'
      ILAHPM(6)='RED'
      ILAHPM(7)='BLUE'
      ILAHPM(8)='GREE'
      ILAHPM(9)='BLAC'
      ILAHPM(10)='RED'
      ILAHPM(11)='BLUE'
      ILAHPM(12)='GREE'
      ILAHPM(13)='BLAC'
      ILAHPM(14)='RED'
      ILAHPM(15)='BLUE'
      ILAHPM(16)='GREE'
C
CCCCC ADD MICROSOFT QWIN DEVICE INITIALIZATION NOVEMBER 1996.
C----------QUICK-WIN----------
C
      IQWNF2=15
      IQWNBC=0
      IQWNFC='TEXT'
CCCCC MARCH 2002: SET COLOR MODE IN MSFORT.F (ALLOW TO BE SET
CCCCC VIA COMMAND LINE ARGUMENT
CCCCC IQWNCL='VGA'
      IQWNFZ='COURIER'
      IQWNPF='OFF'
      IQWNPM(1)='BLAC'
      IQWNPM(2)='RED'
      IQWNPM(3)='BLUE'
      IQWNPM(4)='GREE'
      IQWNPM(5)='BLAC'
      IQWNPM(6)='RED'
      IQWNPM(7)='BLUE'
      IQWNPM(8)='GREE'
      IQWNPM(9)='BLAC'
      IQWNPM(10)='RED'
      IQWNPM(11)='BLUE'
      IQWNPM(12)='GREE'
      IQWNPM(13)='BLAC'
      IQWNPM(14)='RED'
      IQWNPM(15)='BLUE'
      IQWNPM(16)='GREE'
C
      IQWNFL=0
C
CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996.
C----------QUICK-WIN----------
C
      IWINFN='FIXE'
      IWINCL='RGB'
      IWINHP=600
      IWINVP=450
C
C----------ZETA----------
C
      IZETSW='OFF'
      IZETCL=4
      IZETCC=-999
      PZETTH=0.05
C  FOLLOWING LINES ADDED FOR ZETA MAY, 1990.
      IZETPF='OFF'
      IZETPM(1)='BLAC'
      IZETPM(2)='RED'
      IZETPM(3)='BLUE'
      IZETPM(4)='GREE'
      IZETPM(5)='BLAC'
      IZETPM(6)='RED'
      IZETPM(7)='BLUE'
      IZETPM(8)='GREE'
      IZETPM(9)='BLAC'
      IZETPM(10)='RED'
      IZETPM(11)='BLUE'
      IZETPM(12)='GREE'
      IZETPM(13)='BLAC'
      IZETPM(14)='RED'
      IZETPM(15)='BLUE'
      IZETPM(16)='GREE'
C
C----------HP PCL----------
C
      IPCLLM=60
      IPCLRM=60
      IPCLTM=50
      IPCLBM=100
      IPC2LM=50
      IPC2RM=100
      IPC2TM=60
      IPC2BM=60
      PCLPPI=300.
      IPCLFN='COUR'
      IPCLFC='COUR'
C
C----------QUIC----------
C
      IQUILM=85
      IQUIRM=25
      IQUITM=100
      IQUIBM=25
      IQU2LM=70
      IQU2RM=25
      IQU2TM=60
      IQU2BM=25
      QUIPPI=300.
      IQUIFN=10
      IQUIFC=10
C
C----------POSTSCRIPT----------
C
      PSTPPI=300.
C  NOVEMBER, 1990.  MARGIN DEFAULTS CHANGED (PREVIOUSLY HARDCODED TO 75, SET
C  TO 1/4 INCH PLUS A SMALL FUDGE FACTOR).
      IDEFMG=INT(PSTPPI/4.0)+10
      IPSTLM=IDEFMG
      IPSTRM=IDEFMG
      IPSTTM=IDEFMG
      IPSTBM=IDEFMG
      IPS2LM=IDEFMG
      IPS2RM=IDEFMG
      IPS2TM=IDEFMG
      IPS2BM=IDEFMG
CCCCC IPSTFN='TROM'
CCCCC IPSTFC='TROM'
CCCCC ABOVE TWO LINES FIXED JULY 1989
      IPSTFN='HELB'
      IPSTFC='HELB'
      IPSTPS=12
      IPSTPC=12
CCCCC JUNE 1994.  FOLLOWING LINE ADDED.
      IPSTFS='ON'
C  FOLLOWING LINES ADDED OCTOBER 1991
C  MAKE POSTSCRIPT FONTS TABLE DRIVEN FOR EASIER UPDATING
      IPSTSP='OFF'
      IPSTMF=34
      IPSTT1( 1)='TROM'
      IPSTT2( 1)='Times-Roman'
      IPSTT1( 2)='TITA'
      IPSTT2( 2)='Times-Italic'
      IPSTT1( 3)='TBOL'
      IPSTT2( 3)='Times-Bold'
      IPSTT1( 4)='TBIT'
      IPSTT2( 4)='Times-BoldItalic'
      IPSTT1( 5)='HELV'
      IPSTT2( 5)='Helvetica'
      IPSTT1( 6)='HELO'
      IPSTT2( 6)='Helvetica-Oblique'
      IPSTT1( 7)='HELB'
      IPSTT2( 7)='Helvetica-Bold'
      IPSTT1( 8)='HEBO'
      IPSTT2( 8)='Helvetica-BoldOblique'
      IPSTT1( 9)='COUR'
      IPSTT2( 9)='Courier'
      IPSTT1(10)='COBL'
      IPSTT2(10)='Courier-Oblique'
      IPSTT1(11)='CBOL'
      IPSTT2(11)='Courier-Bold'
      IPSTT1(12)='CBOB'
      IPSTT2(12)='Courier-BoldOblique'
      IPSTT1(13)='AGBK'
      IPSTT2(13)='AvantGarde-Book'
      IPSTT1(14)='AGBO'
      IPSTT2(14)='AvantGarde-BookOblique'
      IPSTT1(15)='AGDE'
      IPSTT2(15)='AvantGarde-Demi'
      IPSTT1(16)='AGDO'
      IPSTT2(16)='AvantGarde-DemiOblique'
      IPSTT1(17)='BKDE'
      IPSTT2(17)='Bookman-Demi'
      IPSTT1(18)='BKDI'
      IPSTT2(18)='Bookman-DemiItalic'
      IPSTT1(19)='BKLT'
      IPSTT2(19)='Bookman-Light'
      IPSTT1(20)='BKLI'
      IPSTT2(20)='Bookman-LightItalic'
      IPSTT1(21)='HELN'
      IPSTT2(21)='Helvetica-Narrow'
      IPSTT1(22)='HENB'
      IPSTT2(22)='Helvetica-Narrow-Bold'
      IPSTT1(23)='HNBO'
      IPSTT2(23)='Helvetica-Narrow-BoldOblique'
      IPSTT1(24)='HENO'
      IPSTT2(24)='Helvetica-Narrow-Oblique'
      IPSTT1(25)='NCSR'
      IPSTT2(25)='NewCenturySchlbk-Roman'
      IPSTT1(26)='NCSB'
      IPSTT2(26)='NewCenturySchlbk-Bold'
      IPSTT1(27)='NCSI'
      IPSTT2(27)='NewCenturySchlbk-Italic'
      IPSTT1(28)='CSBI'
      IPSTT2(28)='NewCenturySchlbk-BoldItalic'
      IPSTT1(29)='PALR'
      IPSTT2(29)='Palatino-Roman'
      IPSTT1(30)='PALB'
      IPSTT2(30)='Palatino-Bold'
      IPSTT1(31)='PALI'
      IPSTT2(31)='Palatino-Italic'
      IPSTT1(32)='PABI'
      IPSTT2(32)='Palatino-BoldItalic'
      IPSTT1(33)='ZAPF'
      IPSTT2(33)='ZapfChancery-MediumItalic'
      IPSTT1(34)='SYMB'
      IPSTT2(34)='Symbol'
      DO910I=IPSTMF+1,100
      IPSTT1(I)=' '
      IPSTT2(I)=' '
 910  CONTINUE
C  END OF CHANGE
CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF)
CCCCC SEE ALSO DPCODV.INC          MAY 1992
      IPSTBP='OFF'
C
C----------SUN----------
C
CCCCC IVSNAM=0
      ISUNCL=0
      PSUNTH=0.1
C
C----------CGM----------
C
      ICGMSW='OFF'
C
C----------GENERAL----------
C
      IGENFA=1
C
C
C----------DEC REGIS----------
C
      PREGTH=0.1
CCCCC ABOVE COLOR DEFINITIONS FOR REGIS ADDED JANUARY, 1991.
      IRGHUE(1)= 260
      IRGHUE(2)= 280
      IRGHUE(3)=   0
      IRGHUE(4)=   0
      IRGHUE(5)= 300
      IRGHUE(6)=   0
      IRGHUE(7)=  40
      IRGHUE(8)= 300
      IRGHUE(9)=   0
      IRGHUE(10)=  0
      IRGHUE(11)= 30
      IRGHUE(12)=  0
      IRGHUE(13)=  0
      IRGHUE(14)=320
      IRGHUE(15)=330
      IRGHUE(16)=320
      IRGHUE(17)=150
      IRGHUE(18)=300
      IRGHUE(19)=120
      IRGHUE(20)=160
      IRGHUE(21)=180
      IRGHUE(22)=180
      IRGHUE(23)=240
      IRGHUE(24)=240
      IRGHUE(25)=180
      IRGHUE(26)=240
      IRGHUE(27)=240
      IRGHUE(28)=200
      IRGHUE(29)=240
      IRGHUE(30)=210
      IRGHUE(31)=240
      IRGHUE(32)=280
      IRGHUE(33)=270
      IRGHUE(34)=200
      IRGHUE(35)=300
      IRGHUE(36)=  0
      IRGHUE(37)=  0
      IRGHUE(38)=180
      IRGHUE(39)= 60
      IRGHUE(40)= 80
      IRGHUE(41)=120
      IRGHUE(42)= 60
      IRGHUE(43)= 40
      IRGHUE(44)= 20
      IRGHUE(45)=120
      IRGHUE(46)= 60
      IRGHUE(47)=120
      IRGHUE(48)=120
      IRGHUE(49)=100
      IRGHUE(50)= 90
      IRGHUE(51)= 80
      IRGHUE(52)=120
      IRGHUE(53)=160
      IRGHUE(54)=140
      IRGHUE(55)= 60
      IRGHUE(56)=300
      IRGHUE(57)=340
      IRGHUE(58)=300
      IRGHUE(59)= 60
      IRGHUE(60)= 60
      IRGHUE(61)=180
      IRGHUE(62)=  0
      IRGHUE(63)=180
      IRGHUE(64)=220
      IRGLGT(1)=  65
      IRGLGT(2)=  50
      IRGLGT(3)=   0
      IRGLGT(4)=  50
      IRGLGT(5)=  50
      IRGLGT(6)=  35
      IRGLGT(7)=  35
      IRGLGT(8)=  80
      IRGLGT(9)=  65
      IRGLGT(10)= 50
      IRGLGT(11)= 50
      IRGLGT(12)= 25
      IRGLGT(13)= 35
      IRGLGT(14)= 50
      IRGLGT(15)= 50
      IRGLGT(16)= 35
      IRGLGT(17)= 50
      IRGLGT(18)= 50
      IRGLGT(19)= 35
      IRGLGT(20)= 50
      IRGLGT(21)= 65
      IRGLGT(22)= 80
      IRGLGT(23)= 50
      IRGLGT(24)= 25
      IRGLGT(25)= 25
      IRGLGT(26)= 35
      IRGLGT(27)= 50
      IRGLGT(28)= 35
      IRGLGT(29)= 35
      IRGLGT(30)= 50
      IRGLGT(31)= 65
      IRGLGT(32)= 35
      IRGLGT(33)= 50
      IRGLGT(34)= 50
      IRGLGT(35)= 25
      IRGLGT(36)= 33
      IRGLGT(37)= 66
      IRGLGT(38)= 50
      IRGLGT(39)= 50
      IRGLGT(40)= 35
      IRGLGT(41)= 50
      IRGLGT(42)= 65
      IRGLGT(43)= 50
      IRGLGT(44)= 65
      IRGLGT(45)= 65
      IRGLGT(46)= 80
      IRGLGT(47)= 50
      IRGLGT(48)= 25
      IRGLGT(49)= 65
      IRGLGT(50)= 50
      IRGLGT(51)= 50
      IRGLGT(52)= 35
      IRGLGT(53)= 35
      IRGLGT(54)= 65
      IRGLGT(55)= 80
      IRGLGT(56)= 80
      IRGLGT(57)= 65
      IRGLGT(58)= 65
      IRGLGT(59)= 25
      IRGLGT(60)= 50
      IRGLGT(61)= 80
      IRGLGT(62)= 99
      IRGLGT(63)= 50
      IRGLGT(64)= 65
      IRGSAT(1)=  60
      IRGSAT(2)=  60
      IRGSAT(3)=   0
      IRGSAT(4)= 100
      IRGSAT(5)=  25
      IRGSAT(6)=  25
      IRGSAT(7)=  60
      IRGSAT(8)=  25
      IRGSAT(9)=  25
      IRGSAT(10)= 60
      IRGSAT(11)=100
      IRGSAT(12)= 25
      IRGSAT(13)= 60
      IRGSAT(14)= 60
      IRGSAT(15)=100
      IRGSAT(16)= 60
      IRGSAT(17)=100
      IRGSAT(18)=100
      IRGSAT(19)= 60
      IRGSAT(20)= 60
      IRGSAT(21)= 60
      IRGSAT(22)= 60
      IRGSAT(23)=100
      IRGSAT(24)= 25
      IRGSAT(25)= 25
      IRGSAT(26)= 60
      IRGSAT(27)= 60
      IRGSAT(28)= 60
      IRGSAT(29)= 25
      IRGSAT(30)=100
      IRGSAT(31)= 25
      IRGSAT(32)= 60
      IRGSAT(33)=100
      IRGSAT(34)= 60
      IRGSAT(35)= 25
      IRGSAT(36)=  0
      IRGSAT(37)=  0
      IRGSAT(38)= 25
      IRGSAT(39)=100
      IRGSAT(40)= 60
      IRGSAT(41)= 60
      IRGSAT(42)= 60
      IRGSAT(43)= 60
      IRGSAT(44)= 60
      IRGSAT(45)= 25
      IRGSAT(46)= 60
      IRGSAT(47)=100
      IRGSAT(48)= 25
      IRGSAT(49)= 60
      IRGSAT(50)=100
      IRGSAT(51)= 60
      IRGSAT(52)= 25
      IRGSAT(53)= 60
      IRGSAT(54)= 60
      IRGSAT(55)= 25
      IRGSAT(56)= 60
      IRGSAT(57)= 60
      IRGSAT(58)= 60
      IRGSAT(59)= 25
      IRGSAT(60)= 25
      IRGSAT(61)= 25
      IRGSAT(62)=  0
      IRGSAT(63)=100
      IRGSAT(64)= 60
C
C  VT-240 ALLOWS 4 ACTIVE COLOR MAPS.  RESERVE 0 FOR THE BACKGROUND COLOR
C  AND 1-3 FOR THE FOREGROUND COLORS.  I DON'T HAVE ANY VT-340 DOCUMENTATION
C  SO NOT SURE IF VT-340 ALLOWS MORE.  FOR NOW, SET MAXIMUM FOREGROUND COLORS
C  TO 3 (AND SET DEFAULT TO WHITE, YELLOW, AND RED (BACKGROUND IS BLUE).
C  NOTE: 340 ALLOWS 16 COLORS (BUT ONE RESERVED FOR BACKGROUND).
C
      IREGMC=3
      IREGPM(1)=62
      IREGPM(2)=63
      IREGPM(3)=47
      IREGPM(4)=3
      IREGPM(5)=23
      IREGPM(6)=18
      IREGPM(7)=4
      IREGPM(8)=41
      IREGPM(9)=59
      IREGPM(10)=39
      IREGPM(11)=64
      IREGPM(12)=54
      IREGPM(13)=20
      IREGPM(14)=51
      IREGPM(15)=37
      IREGPM(16)=35
C  END CHANGE
C
C----------HP 2622------------
C
      P262TH=0.1
C
C----------HP 7221------------
C
      P722TH=0.1
C
C----------HP-GL--------------
C
      PHPGTH=0.1
C ADDED FOLLOWING LINES FOR HP MAY, 1990.
      IHPGSW='OFF'
      IHPGPF='OFF'
      IHPGCL=4
      IHPGPM(1)='BLAC'
      IHPGPM(2)='RED'
      IHPGPM(3)='BLUE'
      IHPGPM(4)='GREE'
      IHPGPM(5)='BLAC'
      IHPGPM(6)='RED'
      IHPGPM(7)='BLUE'
      IHPGPM(8)='GREE'
      IHPGPM(9)='BLAC'
      IHPGPM(10)='RED'
      IHPGPM(11)='BLUE'
      IHPGPM(12)='GREE'
      IHPGPM(13)='BLAC'
      IHPGPM(14)='RED'
      IHPGPM(15)='BLUE'
      IHPGPM(16)='GREE'
C
C----------TEKTRONIX----------
C
      PTEKTH=0.1
C
C----------GENERAL------------
C
C  ADDED FOLLOWING LINES JANUARY, 1990 (PREVIOUSLY DONE IN MAIN)
CCCCC JANUARY 1995.  MODIFY DEFAULT FOR FRONTEND
CCCCC IJUSSW='OFF'
      IJUSSW='ON'
      IRFLSW='OFF'
      IFNTSW='OFF'
      IPTHSW='OFF'
      PPENSW=0.1
C
C----------X11 CASE-----------
C
C  ADDED FOLLOWING LINES MARCH, 1990 FOR X11
      IX11CS='BUTT'
      IX11JS='MITER'
CCCCC CHANGE DEFAULT.  APRIL 1997
CCCCC IX11PM='OFF'
      IX11PM='ON'
      IX11FN='8X13'
      IX11OF='OFF'
      IX11PA='OFF '
      IX11DN='DEFAULT'
CCCCC JUNE 1994.  FOLLOWING LINE ADDED.
      IX11FS='ON'
C
CCCCC ADD FOLLOWING SECTION.  APRIL 1997
      NUMPXM=0
      ICURPM=0
      IPXMFL='OFF'
      IPXMFB='pixmap.'
      IPXMNC=7
      DO1010I=1,MAXPM
      IPXMFN(I)=' '
      IPXMCM(I)=' '
 1010 CONTINUE
CCCCC ADD FOLLOWING SECTION.  OCTOBER 1997
      IX11W2=' '
C
C----------TURBO-C FOR IBM-PC-------------
C
CCCCC THE INITIALIZATION OF THE TURBO-C DRIVER FOR IBM-PC  MAY 1993
CCCCC WAS MOVED TO    TCINCO.FOR    WITHIN    TCDRIV.FOR   MAY 1993
CCCCC THE CALL TO TCINCO WAS MOVED BACK TO MAIN      FEBRUARY 1996
CCCCC CALL TCINCO(ISUBRO)
C
CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996.
C
C----------SVG (SCALABLE VECTOR GRAPHICS)------
C
      ISVGOS='OFF'
      ISVGCS='PIXE'
      ISVGCA='BUTT'
      ISVGJS='MITE'
      ISVGFS='EVEN'
      ISVGSS='INTE'
      ISVGST='norm'
      ISVGFW='bold'
CCCCC ISVGFN='sans-serif'
      ISVGFN='Arial,sans-serif'
      ISVGSS='INTE'
      ISVGSN='dataplot.css'
      ISVGCN=0
      ISVGLN=0
      ISVGUR='NULL'
      ISVGBU='NONE'
C
C----------CAIRO LIBRARY----------------------
C
      ICAICA='BUTT'
      ICAIJS='MITE'
      ICAIFS='ON'
C
      ICAIFN='Sans'
      ICAISL='NORM'
      ICAIFW='BOLD'
      ICAIBP='OFF'
C
      CAIPPI=600.
C
C----------LATEX-------------------------------
C
      ILATOS='OFF'
      ILATCO='OFF'
      ILATFS='OFF'
      ILATLT='HARD'
C
C----------AQUATERM CASE-----------
C
C  ADDED FOLLOWING LINES SEPTEMBER, 2007 FOR AQUATERM
C
      IAQUCS='BUTT'
      IAQUJS='MITER'
      IAQUFN='Helvetica'
      IAQUOF='OFF'
      IAQUFS='ON'
C
C----------GD (JPEG/PNG/GIF) CASE-----------
C
C  ADDED FOLLOWING LINES MARCH, 2008 FOR GD
C
      IGDFN='Null'
      IGDCO='FIXE'
C
C----------LIBPLOT CASE-----------
C
C  ADDED FOLLOWING LINES APRIL, 2009 FOR UNIX LIBPLOT LIBRARY
C
      ILPLCS='BUTT'
      ILPLJS='MITER'
      ILPLFN='Helvetica'
      ILPLPA='OFF'
      ILPLFS='OFF'
      ILPLXS=570
      ILPLYS=570
      PLPLRO=0.0
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INITOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)MAXDEV,NUMDEV
 9012   FORMAT('MAXDEV,NUMDEV = ',2I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IDEFMA,IDEFMO,IDEFM2,IDEFM3
 9013   FORMAT('IDEFMA,IDEFMO,IDEFM2,IDEFM3 = ',3(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)IDEFPO,IDEFCN,IDEFDC
 9014   FORMAT('IDEFPO,IDEFCN,IDEFDC = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)IDEFVP,IDEFHP,IDEFUN
 9015   FORMAT('IDEFVP,IDEFHP,IDEFUN = ',3I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9016)ICOPSW,NUMCOP
 9016   FORMAT('ICOPSW,NUMCOP = ',A4,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9017)IDMANU(1)
 9017   FORMAT('IDMANU(1) = ',A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE INITSU(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INITSU.
C              (THE   SU    AT THE END OF    INITSU   STANDS FOR   SUPPORT
C              THIS SUBROUTINE INITIALIZES SUPPORT VARIABLES AND PARAMETERS
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1980.
C     UPDATED         --MARCH     1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --MAY       1990.  COMMENT CHARACTER
C     UPDATED         --AUGUST    1992.  VECTOR PLOT PARAMETERS
C     UPDATED         --OCTOBER   1992.  CHANGE ICOMFL TO ICOMSW
C     UPDATED         --NOVEMBER  1992.  ANDREWS PLOT PARAM. (ALAN)
C     UPDATED         --MAY       1993.  MINMAX FOR EV1/EV2/WEIB DIST.
C     UPDATED         --JULY      1993.  FRACTAL ITERATIONS, FRACTAL
C                                        TYPE, PRINCIPLE COMPONENT TYPE
C     UPDATED         --JANUARY   1994.  WEIB MINMAX TO DPCOS2.INC
C     UPDATED         --FEBRUARY  1994.  DEFAULT FOR FITSD
C     UPDATED         --JUNE      1994.  OPTIMIZATION TOLERANCE
C     UPDATED         --FEBRUARY  1995.  OPTIMIZATION METHOD
C     UPDATED         --JULY      1995.  FIT ADDITIVE CONSTANT
C     UPDATED         --APRIL     1997.  SET NETSCAPE <OLD/NEW>
C     UPDATED         --APRIL     1997.  SET CONTROL CHART <DATA/PRIOR>
C     UPDATED         --APRIL     1997.  SET CONTROL CHART WEIGHT <CENTER/RIGHT>
C     UPDATED         --AUGUST    1997.  3 SWITCHES FOR RECIPE
C     UPDATED         --APRIL     1998.  RECIPE FIT FACTORS
C     UPDATED         --MAY       1998.  KAPLAN-MEIER <RELI/CDF>
C     UPDATED         --MAY       1998.  CENSORING TYPE <1/2>
C     UPDATED         --JUNE      1998.  MATRIX SCALE <NONE/SD/RANGE/Z-SC>
C     UPDATED         --SEPTEMBER 1998.  PERCENT POINT PLOT BINNED/UNBINNED
C     UPDATED         --SEPTEMBER 1998.  QUANTILE-QUANTILE PLOT BINNED/UNBINNED
C     UPDATED         --MARCH     1999.  SET WEB HANDBOOK
C     UPDATED         --SEPTEMBER 1999.  SET SCATTER PLOT MATRIX OPTIONS
C     UPDATED         --NOVEMBER  1999.  SET PARAMETER EXPANSION OPTION
C     UPDATED         --JANUARY   2000.  SET SORT DIRECTION
C     UPDATED         --OCTOBER   2000.  SET MANDEL PAULE
C     UPDATED         --MARCH     2001.  SET SUPERSCRIPT HORI SCALE
C     UPDATED         --MARCH     2001.  SET SUPERSCRIPT VERT SCALE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            TRUST REGION RADIUS
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            STOP TOLERANCE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            PARAMETER TOLERANCE
C     UPDATED         --APRIL     2001.  SET ORTHOGONAL DISTANCE
C                                            PRINT OPTION
C     UPDATED         --JULY      2001.  SET KERNEL DENSITY OPTIONS
C     UPDATED         --MARCH     2002.  SET BOX PLOT WIDTH
C     UPDATED         --MAY       2002.  SET RANDOM NUMBER GENERATOR
C     UPDATED         --JUNE      2002.  SET NUMBER OF CP
C     UPDATED         --JUNE      2002.  ICAPTY
C     UPDATED         --JULY      2002.  SET COVARIANCE TYPE
C     UPDATED         --JULY      2002.  SET CORRELATION TYPE
C     UPDATED         --JULY      2002.  SET FILE TYPE QUOTE
C     UPDATED         --JULY      2002.  SET BOOTSTRAP FIT METHOD
C     UPDATED         --NOVEMBER  2002.  SET QWIN SYSTEM
C     UPDATED         --NOVEMBER  2002.  SET GHOSTVIEW PRINTER ON
C     UPDATED         --NOVEMBER  2002.  SET GHOSTVIEW PATH
C     UPDATED         --JANUARY   2003.  SET GHOSTSCRIPT PATH
C     UPDATED         --JANUARY   2003.  SET POSTSCRIPT BOUNDING BOX
C     UPDATED         --JANUARY   2003.  SET POSTSCRIPT CONVERT
C     UPDATED         --JANUARY   2003.  SET HTML HEADER FILE
C     UPDATED         --JANUARY   2003.  SET HTML FOOTER FILE
C     UPDATED         --FEBRUARY  2003.  SET MAXIMUM RECORD LENGTH
C     UPDATED         --FEBRUARY  2003.  SET AUTOCOREELATION LAG ZERO
C     UPDATED         --MARCH     2003.  SET PARALLEL COORDINATES
C                                        STANDARDIZE
C     UPDATED         --MARCH     2003.  SET BOOTSTRAP GROUPS
C     UPDATED         --SEPTEMBER 2003.  SET TABLE TITLE
C     UPDATED         --SEPTEMBER 2003.  SET TABLE BORDER
C     UPDATED         --SEPTEMBER 2003.  SET TABLE SPACING
C     UPDATED         --SEPTEMBER 2003.  SET TABLE WIDTH
C     UPDATED         --SEPTEMBER 2003.  SET TABLE HEIGHT
C     UPDATED         --JANUARY   2004.  SET READ VARIABLE LABEL
C     UPDATED         --JANUARY   2004.  SET CONVERT CHARACTER
C     UPDATED         --JANUARY   2004.  SET READ DELIMITER
C     UPDATED         --JANUARY   2004.  SET READ MISSING VALUE
C     UPDATED         --JUNE      2004.  SET DEFAULT POSTSCRIPT COLOR
C     UPDATED         --JUNE      2004.  SET ASYMMETRIC LAPLACE
C                                        DEFINITION
C     UPDATED         --JULY      2004.  SET GOMPERTZ-MAKEHAM
C                                        DEFINITION
C     UPDATED         --AUGUST    2004.  GIVE MINMAX DEFAULT VALUE
C     UPDATED         --AUGUST    2004.  SET BESSEL I FUNCTION
C                                        DEFINITION
C     UPDATED         --AUGUST    2004.  SET BESSEL K FUNCTION
C                                        DEFINITION
C     UPDATED         --SEPTEMBER 2004.  SET PROBABILITY PLOT DATA
C                                        POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT DATA POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT AXIS POINTS
C     UPDATED         --SEPTEMBER 2004.  SET PPCC PLOT AXIS ORDER
C     UPDATED         --SEPTEMBER 2004.  SET HISTOGRAM CLASS WIDTH
C     UPDATED         --SEPTEMBER 2004.  SET ASH WEIGHTING
C     UPDATED         --OCTOBER   2004.  SET READ PAD MISSING COLUMNS
C     UPDATED         --OCTOBER   2004.  SET READ SUBSET
C     UPDATED         --OCTOBER   2004.  SET CENSORED PROBABILITY PLOT
C     UPDATED         --OCTOBER   2004.  SET CENSORED PPCC PLOT
C     UPDATED         --OCTOBER   2004.  SET MAXIMUM LIKELIHOOD PERCENTILES
C     UPDATED         --OCTOBER   2004.  SET EXPONENTIAL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET WEIBULL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET GUMBELL BIAS CORRECTED
C     UPDATED         --NOVEMBER  2004.  SET MATRIX CORRELATION DIRECTION
C     UPDATED         --NOVEMBER  2004.  SET MATRIX COVARIANCE DIRECTION
C     UPDATED         --DECEMBER  2004.  SET GUI
C     UPDATED         --DECEMBER  2004.  SET MAXIMUM LIKELIHOOD RELIABILITY
C     UPDATED         --FEBRUARY  2005.  SET DISTRIBUTIONAL BOOTSTRAP
C     UPDATED         --FEBRUARY  2005.  SET RTF POINT SIZE
C     UPDATED         --FEBRUARY  2005.  SET RTF FIXED FONT
C     UPDATED         --FEBRUARY  2005.  SET RTF PROPORTIONAL FONT
C     UPDATED         --MARCH     2005.  SET LINE PRINTER COLUMNS
C     UPDATED         --APRIL     2005.  SET DECIMAL POINT
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            METHOD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            DISTRIBUTION
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            ITERATIONS
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            NUMBER POINTS
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            INITIAL THRESHOLD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            INCREMENT
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            PERIOD
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            TOLERANCE
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            LOAD FACTOR
C     UPDATED         --APRIL     2005.  SET PEAKS OVER THRESHOLD
C                                            X AXIS
C     UPDATED         --MAY       2005.  SET FRECHET BIAS CORRECTION
C     UPDATED         --JULY      2005.  SET LOG GAMMA DEFINITION
C     UPDATED         --JULY      2005.  SET SKEW NORMAL DEFINITION
C     UPDATED         --SEPTEMBER 2005.  IMACSC
C     UPDATED         --SEPTEMBER 2005.  NMACAG
C     UPDATED         --SEPTEMBER 2005.  IMACAR
C     UPDATED         --JANUARY   2006.  ICAPSC
C     UPDATED         --FEBRUARY  2006.  IGLDDF
C     UPDATED         --MAY       2006.  IPPCBW
C     UPDATED         --MAY       2006.  IBGEDF
C     UPDATED         --JUNE      2006.  IFORFM
C     UPDATED         --JUNE      2006.  10 SWITCHES FOR CONSENSUS
C                                        MEAN (IMPACM - IFAICM)
C     UPDATED         --JULY      2006.  IGETDF
C     UPDATED         --JULY      2006.  PCHSLM
C     UPDATED         --AUGUST    2006.  ICONDF
C     UPDATED         --OCTOBER   2006.  I4PLDI
C     UPDATED         --OCTOBER   2006.  PMAXLO
C     UPDATED         --JANUARY   2007.  IGOMDF
C     UPDATED         --JANUARY   2007.  IKATDF
C     UPDATED         --FEBRUARY  2007.  IBINCC, PBINTH
C     UPDATED         --MARCH     2007.  PFISEX
C     UPDATED         --MARCH     2007.  PFISPC
C     UPDATED         --MARCH     2007.  PFISEM
C     UPDATED         --APRIL     2007.  IERRFA
C     UPDATED         --APRIL     2007.  PSTAMV
C     UPDATED         --MAY       2007.  IBTAGN
C     UPDATED         --MAY       2007.  IPOILV
C     UPDATED         --SEPTEMBER 2007.  IERRST
C     UPDATED         --APRIL     2008.  PCTAMV
C     UPDATED         --APRIL     2008.  ICTAMV
C     UPDATED         --APRIL     2008.  IBINTA
C     UPDATED         --MAY       2008.  PFLUFL
C     UPDATED         --MAY       2008.  PFLUCL
C     UPDATED         --MAY       2008.  IFLUWI
C     UPDATED         --JULY      2008.  IGIGDF
C     UPDATED         --AUGUST    2008.  IMERMA
C     UPDATED         --AUGUST    2008.  IMERCA
C     UPDATED         --SEPTEMBER 2008.  ICTAFO
C     UPDATED         --OCTOBER   2008.  PSTRIN
C     UPDATED         --NOVEMBER  2008.  ISTRPL
C     UPDATED         --JANUARY   2009.  FEEDBACK SAVE SWITCH
C     UPDATED         --FEBRUARY  2009.  ICTALT
C     UPDATED         --FEBRUARY  2009.  ISTRSP
C     UPDATED         --MARCH     2009.  ICONDH, ICONDV
C     UPDATED         --MARCH     2009.  ISTAFO
C     UPDATED         --MARCH     2009.  ISTASM
C     UPDATED         --MARCH     2009.  IFORWI, IFORWR, MAXNWI
C     UPDATED         --APRIL     2009.  IBPLSC
C     UPDATED         --APRIL     2009.  PBPLCO
C     UPDATED         --APRIL     2009.  ILATPS
C     UPDATED         --APRIL     2009.  IDATMV
C     UPDATED         --APRIL     2009.  IREALI
C     UPDATED         --JUNE      2009.  IMERC2
C     UPDATED         --JUNE      2009.  ICCTOF
C     UPDATED         --JUNE      2009.  ICCTG1 - ICCTG6
C     UPDATED         --JULY      2009.  ILODCV
C     UPDATED         --JULY      2009.  IPROAD
C     UPDATED         --JULY      2009.  IHTMCW, IHTMFT
C     UPDATED         --SEPTEMBER 2009.  IKSCVM, IADCVM
C     UPDATED         --SEPTEMBER 2009.  IFLUUN
C     UPDATED         --SEPTEMBER 2009.  ICONWC
C     UPDATED         --SEPTEMBER 2009.  PTPLXI
C     UPDATED         --SEPTEMBER 2009.  PTPLYI
C     UPDATED         --SEPTEMBER 2009.  ITPLDI
C     UPDATED         --SEPTEMBER 2009.  IFLUDI
C     UPDATED         --OCTOBER   2009.  IGOFFS
C     UPDATED         --DECEMBER  2009.  ITPLUN, ITPLNI
C     UPDATED         --JANUARY   2010.  IFLUCD, ITPLCD
C     UPDATED         --JANUARY   2010.  IHSTEB, IHSTOU
C     UPDATED         --APRIL     2010.  IFLUBP
C     UPDATED         --APRIL     2010.  IDATNN
C     UPDATED         --MAY       2010.  IDS2CM, IDS3CM, IFA2CM,
C                                        IFA3CM, ILPLCM
C     UPDATED         --JUNE      2010.  ITPLSO, ITPLSR, ITPLSC
C     UPDATED         --JUNE      2010.  ITPLRM, ITPLCM
C     UPDATED         --JUNE      2010.  IFLUSO, IFLUSR, IFLUSC
C     UPDATED         --JULY      2010.  IDFTTY
C     UPDATED         --SEPTEMBER 2010.  IBFWTY
C     UPDATED         --SEPTEMBER 2010.  IBOOPE
C     UPDATED         --OCTOBER   2010.  IMOVDI, IMOVEP
C     UPDATED         --OCTOBER   2010.  IBFWLI, IEEWLI
C     UPDATED         --NOVEMBER  2010.  IMATVA, IVARMA
C     UPDATED         --DECEMBER  2010.  IHOMLO, IHOMSC, IHOMCT
C     UPDATED         --JANUARY   2011.  IBFICR, IBFIME
C     UPDATED         --FEBRUARY  2011.  IKRUGS, ILEVGS
C     UPDATED         --APRIL     2011.  ITTEVA
C     UPDATED         --JUNE      2011.  PMTEQU
C     UPDATED         --AUGUST    2011.  IBOODP
C     UPDATED         --AUGUST    2011.  IBOOCI
C     UPDATED         --AUGUST    2011.  IPSTVW
C     UPDATED         --OCTOBER   2011.  ICMPSO, ICMPDA
C     UPDATED         --OCTOBER   2011.  IBOOSM, PBOOSM
C     UPDATED         --DECEMBER  2011.  ICHAOF
C     UPDATED         --FEBRUARY  2012.  IPIEBI
C     UPDATED         --FEBRUARY  2012.  IKRUMC
C     UPDATED         --FEBRUARY  2012.  IISOLA
C     UPDATED         --FEBRUARY  2012.  IRLPLA
C     UPDATED         --APRIL     2012.  IBPLFI
C     UPDATED         --APRIL     2012.  PBPLWI
C     UPDATED         --APRIL     2012.  IBPLLA
C     UPDATED         --APRIL     2012.  ICAPFE
C     UPDATED         --JUNE      2012.  ICHADY
C     UPDATED         --JUNE      2012.  ICHARO
C     UPDATED         --JULY      2012.  ILODST
C     UPDATED         --JULY      2012.  ILODTA
C     UPDATED         --AUGUST    2012.  ILODPC
C     UPDATED         --SEPTEMBER 2012.  IFIETY
C     UPDATED         --OCTOBER   2012.  IMEMCM, ITRMCM
C     UPDATED         --DECEMBER  2012.  IBPLBG
C     UPDATED         --DECEMBER  2012.  PTOLDF
C     UPDATED         --JANUARY   2013.  IBFIFO
C     UPDATED         --MARCH     2013.  IKTATA
C     UPDATED         --MARCH     2013.  IRCRTA
C     UPDATED         --MARCH     2013.  PCMTYB
C     UPDATED         --MARCH     2013.  IWEIGL
C     UPDATED         --MARCH     2013.  ICSTSV
C     UPDATED         --APRIL     2013.  ISKWDF
C     UPDATED         --APRIL     2013.  IWEIML, IWEIMO, IWEIMM
C     UPDATED         --APRIL     2013.  IPERDI
C     UPDATED         --APRIL     2013.  IFLUBD
C     UPDATED         --JUNE      2013.  ICMET1, ICMET2, ICMET3
C                                        ICMET4, ICMET5
C     UPDATED         --JUNE      2013.  PBFILL, PBFIUL
C     UPDATED         --JULY      2013.  PBFIXV, IBFITY, IDTYPR
C     UPDATED         --AUGUST    2013.  IRGBMX
C     UPDATED         --AUGUST    2013.  IMCCR1
C     UPDATED         --DECEMBER  2013.  IGSTVR
C     UPDATED         --MARCH     2014.  IBINME, I3WEME, P3WEMI
C     UPDATED         --MARCH     2014.  ICMETB
C     UPDATED         --APRIL     2014.  I3LNME, P3LNMI
C     UPDATED         --APRIL     2014.  I3GAME, P3GAMI
C     UPDATED         --APRIL     2014.  IGAUDF
C     UPDATED         --JUNE      2014.  IFITAU
C     UPDATED         --JULY      2014.  INPLAX
C     UPDATED         --AUGUST    2014.  ILATRS
C     UPDATED         --SEPTEMBER 2014.  ICIRCR
C     UPDATED         --SEPTEMBER 2014.  IWEIEP
C     UPDATED         --SEPTEMBER 2014.  IWEILM
C     UPDATED         --OCTOBER   2014.  IGEVML
C     UPDATED         --OCTOBER   2014.  IAVABN
C     UPDATED         --OCTOBER   2014.  IAVANM
C     UPDATED         --OCTOBER   2014.  ISEADI
C     UPDATED         --NOVEMBER  2014.  ICLISK, ICLILL, PCLIDE
C     UPDATED         --DECEMBER  2014.  IX11CB
C     UPDATED         --FEBRUARY  2015.  I691TR, I691HC, I691KC, I691PS
C     UPDATED         --MARCH     2015.  ISPX1L
C     UPDATED         --MARCH     2015.  ISPMDS
C     UPDATED         --APRIL     2015.  ICNKPD
C     UPDATED         --APRIL     2015.  I691DS, I691GL, ISPLRL
C     UPDATED         --MAY       2015.  IHKCPT, IHKCLM
C     UPDATED         --MAY       2015.  IHKCGP
C     UPDATED         --MAY       2015.  IHKCM1, IHKCM2, IHKCL1, IHKCL2
C     UPDATED         --MAY       2015.  IMOVGR
C     UPDATED         --JUNE      2015.  ITWOYA, ITWOFI, ITWOAV, ITWOAN
C     UPDATED         --JUNE      2015.  ITWOAD, ITWODE
C     UPDATED         --JUNE      2015.  ITWFPT, ITWFLM
C     UPDATED         --JUNE      2015.  ITWFGP
C     UPDATED         --JUNE      2015.  ITWFM1, ITWFM2, ITWFL1, ITWFL2
C     UPDATED         --SEPTEMBER 2015.  IOPTMM
C     UPDATED         --OCTOBER   2015.  IERRWA, IJSREP, ILOOSU
C     UPDATED         --NOVEMBER  2015.  IWEBSE, IDEVO3
C     UPDATED         --DECEMBER  2015.  IFRALI
C     UPDATED         --DECEMBER  2015.  IDV2SP
C     UPDATED         --DECEMBER  2015.  IDV3NC
C     UPDATED         --DECEMBER  2015.  ICAPSP, ICAPCU
C     UPDATED         --DECEMBER  2015.  ISTDIN, PSTDSL, ISTDCN
C     UPDATED         --MAY       2016.  IQUOST
C     UPDATED         --JUNE      2016.  IVNMEX
C     UPDATED         --JUNE      2016.  ISTADS
C     UPDATED         --JUNE      2016.  IHSTMC
C     UPDATED         --JUNE      2016.  IHSTOP
C     UPDATED         --JUNE      2016.  IBXPDI
C     UPDATED         --JUNE      2016.  ISRESI
C     UPDATED         --JUNE      2016.  IDATDL
C     UPDATED         --JUNE      2016.  ITIMDL
C     UPDATED         --JUNE      2016.  IRDIPA
C     UPDATED         --JUNE      2016.  IQQNPR
C     UPDATED         --JUNE      2016.  I2SNPR
C     UPDATED         --JUNE      2016.  ICTAGR
C     UPDATED         --JUNE      2016.  IQQBOO
C     UPDATED         --JULY      2016.  ISREVN
C     UPDATED         --JULY      2016.  IWRIHE
C     UPDATED         --JULY      2016.  ISRER1, ISRER2, ISRER3
C     UPDATED         --SEPTEMBER 2016.  IRESN1,IRESN2, NUMNRE
C     UPDATED         --SEPTEMBER 2016.  ICORAV, ICORPV, ICORDG
C     UPDATED         --OCTOBER   2016.  IPSVCL
C     UPDATED         --NOVEMBER  2016.  PBPLJI
C     UPDATED         --NOVEMBER  2016.  ICSCSB
C     UPDATED         --DECEMBER  2016.  ICVACI
C     UPDATED         --JANUARY   2017.  ICMTYB
C     UPDATED         --JANUARY   2017.  IHYPSW
C     UPDATED         --JANUARY   2017.  IWSAUN
C     UPDATED         --FEBRUARY  2017.  "TAB" SETTINGS
C     UPDATED         --MARCH     2017.  IHUBCM
C     UPDATED         --MARCH     2017.  IKMEIN, IKMESI, IKMESC
C                                        IKMERL
C     UPDATED         --APRIL     2017.  ICMPM1, ICMPM2, ICMPM3
C     UPDATED         --APRIL     2017.  INMCRL, INMCTI, INMCSC
C     UPDATED         --APRIL     2017.  IREACD, IREADS, IREACM
C                                        IREAPM, IREAMC
C     UPDATED         --JUNE      2017.  ICVTTE
C     UPDATED         --JULY      2017.  IBAPPE, IBAPST
C     UPDATED         --JULY      2017.  PPPLLA
C     UPDATED         --JULY      2017.  PNKDEF
C     UPDATED         --AUGUST    2017.  ISRPDI
C     UPDATED         --AUGUST    2017.  IKMDSC, IKMDDI, IKMDPR
C     UPDATED         --AUGUST    2017.  IKMDNS, IKMDNS, IKMDRN
C     UPDATED         --AUGUST    2017.  IKMDTY, IKMDPN
C     UPDATED         --AUGUST    2017.  IAGNTY, IAGNME, IAGNMS
C     UPDATED         --AUGUST    2017.  IAGNSC, IAGNDI, IAGNPR
C     UPDATED         --AUGUST    2017.  IAGNBA
C     UPDATED         --AUGUST    2017.  IFANTY, IFANMS
C     UPDATED         --AUGUST    2017.  IFANSC, IFANDI, IFANPR
C     UPDATED         --NOVEMBER  2017.  IBI2ME
C     UPDATED         --DECEMBER  2017.  IBONSD, IBONAD
C     UPDATED         --JANUARY   2018.  IBONSD, IDPADI, IDPAID
C     UPDATED         --FEBRUARY  2018.  IDPAUN
C     UPDATED         --FEBRUARY  2018.  ICHKLE
C     UPDATED         --FEBRUARY  2018.  ISPMXT, ISPMXL, ISPMYT, ISPMYL
C     UPDATED         --APRIL     2018.  IWBSDP, ICLEWT, ILINSY
C     UPDATED         --APRIL     2018.  IHYPCL, ICOMCL
C     UPDATED         --MAY       2018.  IMACCL, NMACCL
C     UPDATED         --MAY       2018.  ITOLGC, PTOLDF, ITOLME, ITOLM2
C     UPDATED         --JUNE      2018.  IRWLCO
C     UPDATED         --JULY      2018.  ISREC1, ISREC2, ISREC3, ISREC4
C     UPDATED         --JULY      2018.  IKDEPF, IKDERN
C     UPDATED         --JULY      2018.  ISREGL
C     UPDATED         --JULY      2018.  ISREVT
C     UPDATED         --AUGUST    2018.  CHANGE DEFAULT VALUE FOR
C                                        READ DELIMITER TO A SPACE
C                                        RATHER THAN A COMMA
C     UPDATED         --AUGUST    2018.  ISRENP
C     UPDATED         --SEPTEMBER 2018.  IFEEWR, IWRDDL, ISUBSK
C     UPDATED         --NOVEMBER  2018.  CHANGE DEFAULTS FOR
C                                        IBPLSC, PBPLCO
C     UPDATED         --JANUARY   2019.  IPYTPA, NCPYTH, IPYTVR
C     UPDATED         --JANUARY   2019.  ISUBFM
C     UPDATED         --JANUARY   2019.  ISJUCH
C     UPDATED         --FEBRUARY  2019.  ITABNC
C     UPDATED         --FEBRUARY  2019.  PWRTGA
C     UPDATED         --FEBRUARY  2019.  ICLIRC
C     UPDATED         --FEBRUARY  2019.  IDEXIN
C     UPDATED         --MARCH     2019.  ISYSPR
C     UPDATED         --MARCH     2019.  ISYSHI
C     UPDATED         --MARCH     2019.  IEDITR
C     UPDATED         --APRIL     2019.  IAUXDP
C     UPDATED         --APRIL     2019.  IREAAS
C     UPDATED         --JULY      2019.  IBXPSK
C     UPDATED         --AUGUST    2019.  I1PTOC
C     UPDATED         --SEPTEMBER 2019.  IGRPCA, IGRPRE, IGRPLN
C     UPDATED         --SEPTEMBER 2019.  IGRPNM, IGRPFN, IGRPEM
C     UPDATED         --SEPTEMBER 2019.  ICATMO
C     UPDATED         --SEPTEMBER 2019.  IDIRRE, IDIRPA, IDIRLL
C     UPDATED         --SEPTEMBER 2019.  IDIRSO
C     UPDATED         --SEPTEMBER 2019.  ISTRVA, ISTRCS, IRATME
C     UPDATED         --OCTOBER   2019.  IDAVTA, ISKOTA, IKUOTA
C     UPDATED         --OCTOBER   2019.  IREAPC, IHEALI, ITAILI
C     UPDATED         --OCTOBER   2019.  PGRUSD, PGRUDF, IGRUTA
C     UPDATED         --NOVEMBER  2019.  IRLXLE, IOUTLN
C     UPDATED         --NOVEMBER  2019.  IRRRPA
C     UPDATED         --NOVEMBER  2019.  IBROHE, IBROWI
C     UPDATED         --NOVEMBER  2019.  ILSTVW, ILSTNW, ILSTLA,
C                                        IHELNW, IEXCVW, IWORVW
C     UPDATED         --DECEMBER  2019.  IPDFVW
C     UPDATED         --DECEMBER  2019.  IHOMPA
C     UPDATED         --JANUARY   2020.  IIPLJI
C     UPDATED         --FEBRUARY  2020.  ICSVWR
C     UPDATED         --FEBRUARY  2020.  IINSOW
C     UPDATED         --FEBRUARY  2020.  IEXCSH
C     UPDATED         --MARCH     2020.  ISEAD2
C     UPDATED         --MARCH     2020.  ISEAD3
C     UPDATED         --APRIL     2020.  BEST FIT <DIST> <ON/OFF>
C     UPDATED         --APRIL     2020.  ISEAD4, ISEAD5, ISEAD6
C     UPDATED         --APRIL     2020.  IEXCR1, IEXCR2,
C                                        IEXCC1, IEXCC2
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGIN
C
C---------------------------------------------------------------------
C
C-----COMMON----------------------------------------------------------
C
      CHARACTER*1 IBASLC
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODG.INC'
      INCLUDE 'DPCOSU.INC'
CCCCC THE FOLLOWING LINE (FOR WEIBULL MINMAX) WAS ADDED JANUARY 1994
      INCLUDE 'DPCOS2.INC'
      INCLUDE 'DPCOGR.INC'
CCCCC THE FOLLOWING LINE (FOR SET NETSCAPE) WAS ADDED APRIL 1997
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOHO.INC'
C
      CHARACTER*4 IFEESV
      COMMON/IFEED/IFEESV
C
      CHARACTER*40 IHTMFZ
      COMMON/HTMC1/IHTMFZ,NCFON1
C
      INTEGER ILNCNT
      COMMON/LINNUM/ILNCNT
C
      CHARACTER*80 PROFIL
      CHARACTER*80 P86FIL
      CHARACTER*80 APPDAT
      CHARACTER*80 COMNAM
      CHARACTER*80 UPROFI
      CHARACTER*80 DEFPRI
      CHARACTER*20 USRNAM
      CHARACTER*20 ISHELL
      CHARACTER*4  WINBIT
      COMMON/SYSVAR/PROFIL,P86FIL,APPDAT,COMNAM,UPROFI,USRNAM,DEFPRI,
     1              WINBIT,ISHELL
      COMMON/SYSVA2/NCPROF,NCP86F,NCAPPD,NCCOMP,NCUPRO,NCUSER,NCPRIN,
     1              NCSHEL
C
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,55)
   55 FORMAT('***** AT THE BEGINNING OF INITSU--')
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ******************************
C               **  TREAT THE ADD     CASE  **
C               **  TREAT THE CALL    CASE  **
C               **  TREAT THE EXECUTE CASE  **
C               **  TREAT THE RUN     CASE  **
C               ******************************
C
C
C               ****************************
C               **  TREAT THE ANGLE CASE  **
C               ****************************
C     THESE HAVE BEEN COMMENTED OUT BECAUSE
C     THE ANGLE WILL BE SET IN SUBROUTINE INITDG
C
CCCCC DEFANG=0.0
CCCCC ANGLE=DEFANG
C
C               **********************************
C               **  TREAT THE ANGLE UNITS CASE  **
C               **********************************
C     THESE HAVE BEEN COMMENTED OUT BECAUSE
C     THE ANGLE UNITS WILL BE SET IN SUBROUTINE INITDG
C
CCCCC IDEANU='RADI'
CCCCC IANGLU=IDEANU
C
C               ***************************
C               **  TREAT THE BAUD CASE  **
C               ***************************
C
CCCCC IDEFBA=1200
C     IDEFBA IS SET IN SUBROUTINE INITOD
C     BECAUSE MAININ CALLS INITOD BEFORE CALLING INITSU
      IBAUD=IDEFBA
      IGBAUD=IBAUD
C
C               **************************************
C               **  TREAT THE CLASS ... LOWER CASE  **
C               **************************************
C
      CLLIMI(1)=CPUMIN
      CLLIMI(3)=CPUMIN
C
C               **************************************
C               **  TREAT THE CLASS ... UPPER CASE  **
C               **************************************
C
      CLLIMI(2)=CPUMAX
      CLLIMI(4)=CPUMAX
C
C               **************************************
C               **  TREAT THE CLASS ... WIDTH CASE  **
C               **************************************
C
      CLWIDT(1)=CPUMIN
      CLWIDT(2)=CPUMIN
C
C               ********************************************
C               **  TREAT THE MAXIMUM RECORD LENGTH CASE  **
C               **  NOTE: THIS SHOULD COME BEFORE COLUMN  **
C               **        LIMITS CASE                     **
C               ********************************************
C
      IDEFRL=255
      NUMRCM=IDEFRL
C
C               ************************************
C               **  TREAT THE COLUMN LIMITS CASE  **
C               ************************************
C
      IDEFC1=1
CCCCC IDEFC2=132
      IDEFC2=IDEFRL
      IFCOL1=IDEFC1
      IFCOL2=IDEFC2
      DO3010I=1,50
        IFCOLL(I)=-1
        IFCOLU(I)=-1
 3010 CONTINUE
C
C               ******************************
C               **  TREAT THE COMMENT CASE  **
C               ******************************
C
C               ***************************
C               **  TREAT THE COPY CASE  **
C               ***************************
C
C
C               **********************************
C               **  TREAT THE CURSOR SIZE CASE  **
C               **********************************
C
      DEFCSZ=1.0
      ACURSZ=DEFCSZ
C
C               ******************************
C               **  TREAT THE DEGREES CASE  **
C               ******************************
C
C
C               ********************************
C               **  TREAT THE DIMENSION CASE  **
C               ********************************
C
C               **********************************
C               **  TREAT THE ERASE DELAY CASE  **
C               **********************************
C
      DEFERD=1.0
      ERASDE=DEFERD
      AGERDE=ERASDE
C
C               **************************************
C               **  TREAT THE HARDCOPY DELAY CASE   **
C               **************************************
C
      DEFHAD=1.0
      HARDDE=DEFERD
      AGCODE=HARDDE
C
C               *****************************
C               **  TREAT THE DELETE CASE  **
C               *****************************
C
C
C               ***************************************
C               **  TREAT THE DOUBLE PRECISION CASE  **
C               ***************************************
C
C
C               ***************************
C               **  TREAT THE ECHO CASE  **
C               ***************************
C
      IECHO='OFF'
C
C               ****************************
C               **  TRE***** AT THE END   CASE  **
C               **  TREAT THE EXIT  CASE  **
C               **  TREAT THE HALT  CASE  **
C               **  TREAT THE STOP  CASE  **
C               ****************************
C
C
C               *******************************
C               **  TREAT THE ERASE CASE     **
C               **  TREAT THE PAGE CASE      **
C               **  TREAT THE NEW PAGE CASE  **
C               *******************************
C
C
C               *********************************************
C               **  TREAT THE DEMODULATION FREQUENCY CASE  **
C               *********************************************
C
      DEFDMF=-1.0
      DEMOFR=DEFDMF
C
C               ****************************
C               **  TREAT THE GRADS CASE  **
C               ****************************
C
C
C               ***************************
C               **  TREAT THE HELP CASE  **
C               ***************************
C
C
C               ***************************
C               **  TREAT THE HOST CASE  **
C               ***************************
C
      DO300I=1,10
      IDEFHO(I)='    '
  300 CONTINUE
C     NOTE--THE SPECIFICATION OF THE HOST
C           HAS BEEN MOVED TO THE MAIN ROUTINE.
C           SEARCH FOR    IHOST1=      AND IHOST2=
C           IN THE MAIN ROUTINE AND CHANGE IT TO YOUR HOST.
CCCCC IDEFHO(1)='VAX '
CCCCC IDEFHO(2)='11/7'
CCCCC IDEFHO(3)='80  '
CCCCC IDEFHO(4)='VMS '
CCCCC IDEFHO(5)='    '
C
      DO500I=1,10
      IHOST(I)=IDEFHO(I)
  500 CONTINUE
C
C               **************************************
C               **  TREAT THE FIT CONSTRAINTS CASE  **
C               **************************************
C
C               *********************************************
C               **  TREAT THE FIT STANDARD DEVIATION CASE  **
C               *********************************************
C
CCCCC CHANGE DEFAULT TO MATCH DPFIT2.  FEBRUARY 1994.
CCCCC DEFFSD=0.000005
      DEFFSD=0.0000001
      FITSD=DEFFSD
C
C               *************************************
C               **  TREAT THE FIT ITERATIONS CASE  **
C               *************************************
C
      IDEFNI=50
      IFITIT=IDEFNI
C
C               ********************************
C               **  TREAT THE FIT POWER CASE  **
C               ********************************
C
      DEFFPW=2.0
      FITPOW=DEFFPW
C
CCCCC THE FOLLOWING SECTION WAS ADDED       JULY 1995
C               **********************************************
C               **  TREAT THE FIT ADDITIVE CONSTANT CASE    **
C               **********************************************
C
      IFITAC='ON'
C
C
C               ****************************
C               **  TREAT THE KNOTS CASE  **
C               ****************************
C
      IKNOTS='OFF'
      IDEFK1='    '
      IDEFK2='    '
      IKNOT1=IDEFK1
      IKNOT2=IDEFK2
C
C               *******************************
C               **  TREAT THE MESSAGE  CASE  **
C               **  TREAT THE CONSOLE  CASE  **
C               **  TREAT THE OPERAT0R CASE  **
C               *******************************
C
C
C               ****************************
C               **  TREAT THE MACRO CASE  **
C               ****************************
C
C
C               ***************************
C               **  TREAT THE NAME CASE  **
C               ***************************
C
C
C               ****************************************
C               **  TREAT THE POLYNOMIAL DEGREE CASE  **
C               ****************************************
C
      IDEFDG=1
      IDEG=IDEFDG
C
C               ********************************
C               **  TREAT THE PRECISION CASE  **
C               ********************************
C
      IDEFPR='SING'
      IHMXPR='SING'
      IPREC=IDEFPR
C
C               ********************************
C               **  TREAT THE PRE-ERASE CASE  **
C               ********************************
C
      IPREER='ON'
C
C               *******************************
C               **  TREAT THE PRINTING CASE  **
C               *******************************
C
      IPRINT='ON'
      IPRIN2=IPRINT
C
C               ******************************************
C               **  TREAT THE QUADRUPLE PRECISION CASE  **
C               ******************************************
C
C
C               ******************************
C               **  TREAT THE RADIANS CASE  **
C               ******************************
C
C
C               ***************************
C               **  TREAT THE READ CASE  **
C               ***************************
C
C
C               ****************************
C               **  TREAT THE RESET CASE  **
C               ****************************
C
C
C               ******************************
C               **  TREAT THE RESTORE CASE  **
C               ******************************
C
C
C               *****************************
C               **  TREAT THE RETAIN CASE  **
C               **  TREAT THE PACK   CASE  **
C               *****************************
C
C               ********************************
C               **  TREAT THE RING BELL CASE  **
C               ********************************
C
C
C               *********************************
C               **  TREAT THE ROW LIMITS CASE  **
C               *********************************
C
      IDEFR1=1
      IDEFR2=I1MACH(9)
      IFROW1=IDEFR1
      IFROW2=IDEFR2
C
C               ***************************
C               **  TREAT THE SAVE CASE  **
C               ***************************
C
C
C               ******************************************
C               **  TREAT THE SEPARATOR CHARACTOR CASE  **
C               ******************************************
C
      IDEFTC=';'
      ITERCH=IDEFTC
C
C               ******************************************
C               **  TREAT THE CONTINUE  CHARACTER CASE  **
C               ******************************************
C
      IDEFCC='... '
      ICONCH=IDEFCC
C
C               ******************************************
C               **  TREAT THE COMMENT   CHARACTER CASE  **
C               ******************************************
C
      IDEFCZ='.   '
      ICOMCH=IDEFCZ
CCCCC THE FOLLOWING LINE WAS CHANGED OCTOBER 1992
CCCCC ICOMFL='OFF '
      ICOMSW='OFF '
CCCCC FOLLOWING BLOCK OF CODE ADDED AUGUST 1992.
C
C               ******************************************
C               **  TREAT THE VECTOR FORMAT       CASE  **
C               **  TREAT THE VECTOR ARROW        CASE  **
C               ******************************************
C
      IDEFVF='ANGL'
      IVCFMT=IDEFVF
      IDEFVA='FIXE'
      IVCARR=IDEFVA
      IDEFVO='CLOS'
      IVCOPN=IDEFVO
C
CCCCC FOLLOWING BLOCK OF CODE ADDED NOVEMBER 1992.
C
C               ******************************************
C               **  TREAT THE ANDREW INCREMENT    CASE  **
C               ******************************************
C
      DEFAIN=0.1
      ANDINC=DEFAIN
C
CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993
C               ******************************************
C               **  TREAT THE FRACTAL ITERATIONS  CASE  **
C               **  TREAT THE FRACTAL TYPE        CASE  **
C               ******************************************
C
      IDEFFT='BARN'
      IFRATY=IDEFVF
      IDEFFI=MAXPOP
      IFRAIT=IDEFFI
C
CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993
C               ***********************************************
C               **  TREAT THE PRINCIPLE COMPONENTS TYPE CASE **
C               ***********************************************
C
      IDEFPT='DACR'
      IPCMTY=IDEFPT
C
C               **********************************
C               **  TREAT THE SERIAL READ CASE  **
C               **********************************
C
C
C               ***************************************
C               **  TREAT THE SINGLE PRECISION CASE  **
C               ***************************************
C
C
C               ***************************
C               **  TREAT THE SKIP CASE  **
C               ***************************
C
      IDEFSK=0
      ISKIP=IDEFSK
C
C               *****************************
C               **  TREAT THE STATUS CASE  **
C               *****************************
C
C
C               **************************************
C               **  TREAT THE SUBSET MESSAGES CASE  **
C               **************************************
C
      ISUBMS='ON'
C
C               ****************************
C               **  TREAT THE TIME  CASE  **
C               **  TREAT THE CLOCK CASE  **
C               ****************************
C
      DO700I=1,10
      ICLOCK(I)=0
  700 CONTINUE
C
C               ***************************************
C               **  TREAT THE TRIPLE PRECISION CASE  **
C               ***************************************
C
C
C               ******************************
C               **  TREAT THE WEIGHTS CASE  **
C               ******************************
C
      IWEIGH='OFF'
      IDEFW1='    '
      IDEFW2='    '
      IWEIG1=IDEFW1
      IWEIG2=IDEFW2
C
C               ****************************
C               **  TREAT THE WRITE CASE  **
C               **  TREAT THE PRINT CASE  **
C               ****************************
C
C
C               ************************
C               **  TREAT THE . CASE  **
C               ************************
C
C               ***********************************
C               **  TREAT THE FILTER WIDTH CASE  **
C               ***********************************
C
      DEFFW=3.0
      FILWID=DEFFW
C
C               *******************************
C               **  TREAT THE FEEDBACK CASE  **
C               *******************************
C
      IFEEDB='ON'
      IFEED2=IFEEDB
C
C               ************************************
C               **  TREAT THE ROOT ACCURACY CASE  **
C               ************************************
C
      DEFRAC=0.000001
      ROOTAC=DEFRAC
C
C               *********************************************
C               **  TREAT THE OPTIMIZATION TOLERANCE CASE  **
C               *********************************************
C
      DEFOAC=0.00001
      OPTACC=DEFOAC
C
C               *********************************************
C               **  TREAT THE OPTIMIZATION METHOD    CASE  **
C               *********************************************
C
      IDEFOM='LINE'
      IOPTME=IDEFOM
      IDEFHS='FINI'
      IOPTHE=IDEFHS
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1993
CCCCC AUGUST 2004: SET DEFAULT TO 1 (THIS IS THE MORE COMMON
CCCCC              CASE FOR THE WEIBULL DISTRIBUTION)
C
C               ***************************************
C               **  TREAT THE EV1/EV2/WEIBULL        **
C               **  DISTRIBUTION SPECIFICATION CASE  **
C               ***************************************
C
      MINMAX=0
CCCCC MINMAX=1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               ***************************************
C               **  TREAT THE SET NETSCAPE <OLD/NEW> **
C               **  CASE                             **
C               ***************************************
C
      INETSW='NEW'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               ***************************************
C               **  TREAT THE SET CONTROL CHART      **
C               **  <DATA/PRIOR> CASE                **
C               ***************************************
C
      ICCHPR='DATA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1997
C
C               *******************************************
C               **  TREAT THE SET CONTROL CHART WEIGHTING *
C               **  <CENTER/RIGHT> CASE                  **
C               *******************************************
C
      ICCHWT='RIGH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SATTERWAITE APPROXIMATION **
C               **  <ON/OFF> CASE                              **
C               *************************************************
C
      IDEFSA='ON'
      IRECSA=IDEFSA
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE OUTPUT                    **
C               **  <ON/OFF> CASE                              **
C               *************************************************
C
      IDEFTN='TOL'
      IRECTN=IDEFTN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE PROBABILITY CONTENT <VAL> **
C               *************************************************
C
      DEFRPC=0.90
      RECIPC=DEFRPC
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE CONFIDENCE          <VAL> **
C               *************************************************
C
      DEFRCO=0.95
      RECICO=DEFRCO
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE DEGREE              <VAL> **
C               *************************************************
C
      DEFRDG=1.0
      RECIDG=DEFRDG
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 1997
C
C               *************************************************
C               **  TREAT THE RECIPE FACTORS             <VAL> **
C               *************************************************
C
      DEFRFA=0.
      RECIFA=DEFRFA
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 1998
C
C               *************************************************
C               **  TREAT THE RECIPE FACTORS             <VAL> **
C               *************************************************
C
      DEFRFF=0.
      RECIFF=DEFRFF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SIMCOV REPLICATES   <VAL> **
C               *************************************************
C
      IDEFR7=10000
      IRECR1=IDEFR7
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE SIMPVT REPLICATES   <VAL> **
C               *************************************************
C
      IDEFR8=10000
      IRECR2=IDEFR8
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1997
C
C               *************************************************
C               **  TREAT THE RECIPE CORRELATIONS        <VAL> **
C               *************************************************
C
      IDEFR9=11
      IRECC1=IDEFR9
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1998
C
C               *******************************************
C               **  TREAT THE SET KAPLAN-MEIER           **
C               **  <RELI/CDF >    CASE                  **
C               *******************************************
C
      IKAPSW='RELI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 1998
C
C               *******************************************
C               **  TREAT THE SET CENSORING TYPE         **
C               **  <1/2 >    CASE                       **
C               *******************************************
C
      ICENTY='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 1998
C
C               *******************************************
C               **  TREAT THE SET MATRIX SCALE           **
C               **  <NONE/SD/RANGE/Z-SCORE>  CASE        **
C               *******************************************
C
      IMATSC='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1998
C
C               *******************************************
C               **  TREAT THE SET PERCENT POINT PLOT     **
C               **  <BINNED/UNBINNED/INTERPOLATED> CASE  **
C               *******************************************
C
      IPPTBI='BINN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2012
C
C               *******************************************
C               **  TREAT THE SET PIE CHART              **
C               **  <BINNED/UNBINNED/INTERPOLATED> CASE  **
C               *******************************************
C
      IPIEBI='BINN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1998
C
C               *******************************************
C               **  TREAT THE SET QUANTILE-QUANTILE PLOT **
C               **  <BINNED/UNBINNED/INTERPOLATED> CASE  **
C               *******************************************
C
      IQQPBI='BINN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 1999
C
C               *******************************************
C               **  TREAT THE SET HANDBOOK URL           **
C               *******************************************
C
      NCHURL=41
      IHBURL(1:41)='https://www.itl.nist.gov/div898/handbook/'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 1999
C
C               *******************************************
C               **  TREAT THE SET AUTOCORRELATION BAND   **
C               **  <WHITE NOISE/BOX-JENKINS>      CASE  **
C               *******************************************
C
      IAUTCP='WHIT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2003
C
C               *******************************************
C               **  TREAT THE SET AUTOCORRELATION LAG    **
C               **  ZERO <ON/OFF>                  CASE  **
C               *******************************************
C
      IAUTL0='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2003
C
C               *******************************************
C               **  TREAT THE SET PARALLEL COORDINATES   **
C               **  STANDARDIZE <NONE/USCORE/ZSCORE> CASE**
C               *******************************************
C
      IPCCST='USCO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2003
C
C               *******************************************
C               **  TREAT THE SET BOOTSTRAP GROUPS       **
C               **  <INDEPENDENT/DEPENDENT>   CASE       **
C               *******************************************
C
      IBOOGR='INDE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2003
C
C               *******************************************
C               **  TREAT THE SET MULTIVARIATE NORMAL    **
C               **  <SADMVN/RANMVN/KROMVN/SPHMVN>  CASE  **
C               *******************************************
C
      IMVNTY='SADM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET BOX PLOT WIDTH         **
C               **  <VARIABLE/FIXED>               CASE  **
C               *******************************************
C
      IBXPWI='VARI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET 4-PLOT MULTIPLOT       **
C               **  <ON/OFF>                       CASE  **
C               *******************************************
C
      I4PLMC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2002
C
C               *******************************************
C               **  TREAT THE SET 6-PLOT MULTIPLOT       **
C               **  <ON/OFF>                       CASE  **
C               *******************************************
C
      I6PLMC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2002
C
C               *******************************************
C               **  TREAT THE SET RANDOM NUMBER GENERATOR**
C               **  <DATAPLOT/BLUE/RUNIF>          CASE  **
C               *******************************************
C
C     2018/05: CHANGE THE DEFAULT GENERATOR TO FIBONACCI-CONGRUENTIAL
CCCCC IRANAL='FIBO'
      IRANAL='FIBC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2000
C
C               **************************************************
C               **  TREAT THE SET CROSS TABULATE PLOT DIMENSION **
C               **  <1/2>                          CASE         **
C               **************************************************
C
      ICTBDI='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               **************************************************
C               **  TREAT THE SET VARIABLE LABEL EXPAND         **
C               **                <ON/OFF>         CASE         **
C               **************************************************
C
      IVNMEX='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 1999
C
C               *******************************************
C               **  TREAT THE SET PARAMETER EXPANSION    **
C               **  <NUMERIC/EXPONENTIAL>          CASE  **
C               *******************************************
C
      IEXPPA='NUME'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2000
C
C               *******************************************
C               **  TREAT THE SET SORT DIRECTION         **
C               **  <ASCENDING/DESCENDING>         CASE  **
C               *******************************************
C
      ISORDI='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2000
C
C               ************************************************
C               **  TREAT THE SET DEX CONTOUR PLOT DIRECTION  **
C               **  <MINIMUMUN/MAXIMUM>             CASE      **
C               ************************************************
C
      IDCPDI='MAXI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2000
C
C               ****************************************************
C               **  TREAT THE SET MANDEL PAULE <MODIFIED/REGULAR> **
C               ****************************************************
C
      IMANPA='REGU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ********************************************************
C               **  TREAT THE SET LOCATION STATISTIC                  **
C               **                <MEAN/MEDIAN/ MIDMEAN/TRIMMED MEAN> **
C               ********************************************************
C
      ISTALO='MEAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SCALE    STATISTIC <SD/AAD/MAD> **
C               ****************************************************
C
      ISTASC='SD  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SUPERSCRIPT HORI SCALE <SIZE>   **
C               ****************************************************
C
      PSUPXS=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2001
C
C               ****************************************************
C               **  TREAT THE SET SUPERSCRIPT VERT SCALE <SIZE>   **
C               ****************************************************
C
      PSUPYS=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE TRUST       **
C               **        REGION RADIUS  <VAL>                    **
C               ****************************************************
C
      PODRTF=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE STOP        **
C               **        TOLERANCE  <VAL>                        **
C               ****************************************************
C
      PODRST=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE             **
C               **        PARAMETER TOLERANCE  <VAL>              **
C               ****************************************************
C
      PODRPT=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE SET ORTHOGONAL DISTANCE             **
C               **        PRINT OPTION <DEFAULT/FULL>             **
C               ****************************************************
C
      IODRPO='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2001
C
C               ****************************************************
C               **  TREAT THE ORTHOGONAL DISTANCE DELTA VARIABLES **
C               ****************************************************
C
      DO7993I=1,20
        IODRD1(I)='OFF '
        IODRD2(I)='    '
        IODRD3(I)='OFF '
        IODRD4(I)='    '
        IODRE1(I)='ON  '
        IODRE2(I)='    '
        IWEIN1(I)='OFF '
        IWEIN2(I)='    '
 7993 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2001
C
C               ****************************************************
C               **  TREAT THE KERNEL DENSITY OPTIONS:             **
C               **        KERNEL DENSITY WINDOW  <VALUE>          **
C               **        KERNEL DENSITY POINTS  <VALUE>          **
C               **        KERNEL DENSITY TYPE    <FUNC>           **
C               ****************************************************
C
      IDEFKF='GAUS'
      IKDETY=IDEFKF
      IDEFKN=256
      IKDENP=IDEFKN
      DEFKWI=CPUMIN
      PKDEWI=DEFKWI
      IKDEPF='PDF'
      IKDERN=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2000
C
C               ************************************************
C               **  TREAT THE SET DEX CONTOUR PLOT MODEL      **
C               **  <LINEAR/QUADRATIC>              CASE      **
C               ************************************************
C
      IDCPFI='LINE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ************************************************
C               **  TREAT THE ICAPTY SWITCH                   **
C               ************************************************
C
      ICAPTY='TEXT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LABELS **
C               **  <ON/OFF>                           CASE  **
C               ***********************************************
C
      ISPMLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX DIAGONAL*
C               **        <ON/OFF>                     CASE  **
C               ***********************************************
C
      ISPMDI='BLAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2015
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX SHADED **
C               **        DIAGONAL <ON/OFF>     CASE         **
C               ***********************************************
C
      ISPMDS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX FIT    **
C               **  <NONE/LOWESS/LINEAR/QUADRATIC>     CASE  **
C               ***********************************************
C
      ISPMFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LOWER DIAGONAL **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMLD='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX TAG            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX PLOT TYPE      **
C               **  <PLOT/QQPLOT/BIHIST>               CASE          **
C               *******************************************************
C
      ISPMPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX FRAME          **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      ISPMFR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX X AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ISPMXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX Y AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ISPMYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2018
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX XTIC           **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMXT='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2018
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX XTIC LABEL     **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMXL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2018
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX YTIC           **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMYT='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2018
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX YTIC LABEL     **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ISPMYL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX STATISTIC TYPE **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      ISPMST='MEAN'
      ISPMS2='    '
      ISPMS3='    '
      ISPMS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX LIMITS         **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8001I=1,25
        PSPLLL(I)=CPUMIN
        PSPLUL(I)=CPUMIN
        PSPLSL(I)=CPUMIN
        PSPLSU(I)=CPUMIN
 8001 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET MATRIX PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PSPMTD=CPUMIN
      ISPMTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX CORRELAT*
C               **  <ON/OFF>                           CASE  **
C               ***********************************************
C
      ISPMCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX X2LABEL *
C               **  CASE  <CORR/....>                        **
C               ***********************************************
C
      ISPX2L='OFF'
      ISPX2P='DEFAULT'
      ISPX2S='DEFAULT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2015
C
C               ***********************************************
C               **  TREAT THE SET SCATTER PLOT MATRIX X1LABEL**
C               **  CASE <DEFAULT/FILLIBEN>                  **
C               ***********************************************
C
      ISPX1L='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT LABEL            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT TAG              **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT PLOT TYPE        **
C               **  <PLOT/HIST/PERC/RUNS/BOXN>         CASE          **
C               *******************************************************
C
      ICPLPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT FIT              **
C               **  <NONE/LOWESS/LINEAR/SMOOTH>        CASE          **
C               *******************************************************
C
      ICPLFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT FRAME            **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      ICPLFR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT MATRIX X AXIS    **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ICPLXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING  PLOT MATRIX Y AXIS   **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      ICPLYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT PRE-SORT         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
CCCCC THIS OPTION WAS REMOVED.
CCCCC ICPLPS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITIONING PLOT  STATISTIC TYPE  **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      ICPLST='MEAN'
      ICPLS2='    '
      ICPLS3='    '
      ICPLS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION    PLOT  NAME OF         **
C               **  PROBABILITY PLOT                   CASE          **
C               *******************************************************
C
      ICPLP1='    '
      ICPLP2='    '
      ICPLP3='    '
      ICPLP4='    '
      ICPLP5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION    PLOT  NAME OF         **
C               **  PPCC        PLOT                   CASE          **
C               *******************************************************
C
      ICPLC1='    '
      IcPLC2='    '
      ICPLC3='    '
      ICPLC4='    '
      ICPLC5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT CORRELATION         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      ICPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET CONDITION PLOT X2LABEL     **
C               **  <CORR/....>                        CASE  **
C               ***********************************************
C
      ICPX2L='OFF'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  RESPONSE VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLRV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDIT PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLTD=CPUMIN
      ICPLTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  TAG      VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PCPLTV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET CONDITION PLOT  LIMITS             **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8013I=1,25
        PCPXLL(I)=CPUMIN
        PCPXUL(I)=CPUMIN
        PCPYLL(I)=CPUMIN
        PCPYUL(I)=CPUMIN
 8013 CONTINUE
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT LABEL            **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLLA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT CORRELATION           **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT TAG              **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLTA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT PLOT TYPE        **
C               **  <PLOT/HIST/PERC/RUNS/BOXN>         CASE          **
C               *******************************************************
C
      IFPLPT='PLOT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT FIT              **
C               **  <NONE/LOWESS/LINEAR/SMOOTH>        CASE          **
C               *******************************************************
C
      IFPLFI='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT FRAME            **
C               **  <DEFAULT/USER>                     CASE          **
C               *******************************************************
C
      IFPLFR='USER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT MATRIX X AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      IFPLXA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR  PLOT MATRIX Y AXIS         **
C               **  <LEFT/RIGHT/ALTERNATE>             CASE          **
C               *******************************************************
C
      IFPLYA='ALTE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT PRE-SORT         **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
CCCCC THIS OPTION WAS REMOVED.
CCCCC IFPLPS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  STATISTIC TYPE  **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      IFPLST='MEAN'
      IFPLS2='    '
      IFPLS3='    '
      IFPLS4='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR    PLOT  RESPONSE VARIABLES **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PFPLRV=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR PLOT  TIC LABEL DISPLACEMENT**
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      PFPLTD=CPUMIN
      IFPLTD='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR    PLOT  LIMITS             **
C               **  <XXXX>                             CASE          **
C               *******************************************************
C
      DO8003I=1,25
        PFPXLL(I)=CPUMIN
        PFPXUL(I)=CPUMIN
        PFPYLL(I)=CPUMIN
        PFPYUL(I)=CPUMIN
 8003 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  CORRELATION     **
C               **  <ON/OFF>                           CASE          **
C               *******************************************************
C
      IFPLCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               ***********************************************
C               **  TREAT THE SET FACTOR    PLOT X2LABEL     **
C               **  <CORR/....>                        CASE  **
C               ***********************************************
C
      IFPX2L='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  NAME OF         **
C               **  PROBABILITY PLOT                   CASE          **
C               *******************************************************
C
      IFPLP1='    '
      IFPLP2='    '
      IFPLP3='    '
      IFPLP4='    '
      IFPLP5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 1999
C
C               *******************************************************
C               **  TREAT THE SET FACTOR       PLOT  NAME OF         **
C               **  PPCC        PLOT                   CASE          **
C               *******************************************************
C
      IFPLC1='    '
      IFPLC2='    '
      IFPLC3='    '
      IFPLC4='    '
      IFPLC5='    '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET NUMBER OF CP <VALUE>  CASE **
C               ***********************************************
C
      INUMCP=10
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET CAPTURE LINES <VALUE> CASE **
C               ***********************************************
C
      DO8110I=1,MAXCLI
      ICAPLI(1)=25
 8110 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               ***********************************************
C               **  TREAT THE SET CAPTURE BOX <ON/OFF>  CASE **
C               ***********************************************
C
      ICAPBX='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2002
C
C               **************************************************
C               **  TREAT THE SET CAPTURE NUMBER <ON/OFF>  CASE **
C               **************************************************
C
      ICAPNM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET QUANTILE METHOD <ORDER/HD/R8> **
C               **  CASE                                        **
C               **************************************************
C
      IQUAME='ORDE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET QUANTILE STANDARD ERROR METHOD *
C               **  <MJ/KDEN>                                    *
C               **************************************************
C
      IQUASE='MJ'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               ********************************************************
C               **  TREAT THE SET COVARIANCE TYPE                      *
C               **  <DEFAULT/BIWEIGHT/WINSORIZED/RANK/PERCENTAGE BEND> *
C               ********************************************************
C
      ICOVTY='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET CORRELATION TYPE               *
C               **  <DEFAULT/WINSORIZED/RANK>                    *
C               **************************************************
C
      ICORTY='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2016
C
C               **************************************************
C               **  TREAT THE SET CORRELATION ABSOLUTE VALUE     *
C               **  <ON/OFF>                                     *
C               **************************************************
C
      ICORAV='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2016
C
C               **************************************************
C               **  TREAT THE SET CORRELATION PERCENTAGE VALUE   *
C               **  <ON/OFF>                                     *
C               **************************************************
C
      ICORPV='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2016
C
C               **************************************************
C               **  TREAT THE SET CORRELATION DIGITS <VALUE>     *
C               **************************************************
C
      ICORDG=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2016
C
C               **************************************************
C               **  TREAT THE SET PSVIEW FILE CLOSE <ON/OFF>     *
C               **************************************************
C
      IPSVCL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2016
C
C               *****************************************************
C               **  TREAT THE SET CAPTURE SCRIPT LOOP SUBSTITUTION  *
C               **                <ON/OFF>                          *
C               *****************************************************
C
      ICSCSB='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2016
C
C               *******************************************************
C               **  TREAT THE SET COEFFICENT OF VARIATION CONFIDENCE  *
C               **                LIMIT METHOD                        *
C               **                <VANGEL/MCKAY/MAXIMUM LIKELIHOOD>   *
C               *******************************************************
C
      ICVACI='VANG'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2017
C
C               *******************************************************
C               **  TREAT THE SET HYPHEN WORD SEPARATOR <ON/OFF>      *
C               *******************************************************
C
      IHYPSW='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               *******************************************************
C               **  TREAT THE SET HYPHEN COMMAND LINE   <ON/OFF>      *
C               *******************************************************
C
      IHYPCL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               *******************************************************
C               **  TREAT THE SET COMMA COMMAND LINE   <ON/OFF>       *
C               *******************************************************
C
      ICOMCL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               *******************************************************
C               **  TREAT THE SET EQUAL COMMAND LINE   <ON/OFF>       *
C               *******************************************************
C
      IEQUCL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET GUENTHER CORRECTION  <ON/OFF>       *
C               *******************************************************
C
      ITOLGC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET TOLERANCE LIMITS METHOD            **
C               **                <HOWE/WALD>                        **
C               *******************************************************
C
      ITOLME='HOWE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET TOLERANCE LIMITS ONE SIDED METHOD  **
C               **                <HOWE/WALD>                        **
C               *******************************************************
C
      ITOLM2='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET TOLERANCE DEGREES OF FREEDOM       **
C               **                <VALUE>                            **
C               *******************************************************
C
      PTOLDF=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET DISTRIBUTIONAL FIT TYPE            **
C               **                <TABLE/SCATTER>                    **
C               *******************************************************
C
      IDFITY='TABL'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2018
C
C               *******************************************************
C               **  TREAT THE SET DISTRIBUTIONAL FIT SORT            **
C               **                <OFF/AVERAGE RANK>                 **
C               *******************************************************
C
      IDFISO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2018
C
C               *******************************************************
C               **  TREAT THE SET WORD DELIMITER        <VALUE>       *
C               *******************************************************
C
      IWRDDL=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2018
C
C               *******************************************************
C               **  TREAT THE SET COMMAND SUBSTITUTION  <ON/OFF>      *
C               *******************************************************
C
      ISUBSK='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2019
C
C               *******************************************************
C               **  TREAT THE SET SUBSTITUTE FORMAT  <STRING>         *
C               *******************************************************
C
      ISUBFM='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2019
C
C               *******************************************************
C               **  TREAT THE SET CLIPBOARD RUN CLEAR   <ON/OFF>      *
C               *******************************************************
C
      ICLIRC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2019
C
C               ****************************************************
C               **  TREAT THE SET TAB EXPAND <IVAL>   CASE        **
C               ****************************************************
C
      ITABNC=1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2017
C
C               *******************************************************
C               **  TREAT THE SET WELCH SATTERTHWAITE                 *
C               **                <VARIANCES/STANDARD DEVIATIONS>     *
C               *******************************************************
C
      IWSAUN='VARI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEANS INITIAL <RANDOM/DISTANCE>   *
C               *******************************************************
C
      IKMEIN='RAND'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEANS SILHOUETTES <ON/OFF>        *
C               *******************************************************
C
      IKMESI='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEANS SCALE       <ON/OFF>        *
C               *******************************************************
C
CCCCC IKMESC='OFF'
      IKMESC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEANS  ROW LABELS <ON/OFF>       **
C               *******************************************************
C
      IKMERL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               *******************************************************
C               **  TREAT THE SET NORMAL MIXTURE CLUSTER SCALE       **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      INMCSC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               *******************************************************
C               **  TREAT THE SET NORMAL MIXTURE CLUSTER ROW LABELS  **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      INMCRL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               *******************************************************
C               **  TREAT THE SET NORMAL MIXTURE CLUSTER TITLE       **
C               **                <STRING>                           **
C               *******************************************************
C
      INMCTI='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID CLUSTER SCALE <ON/OFF>   **
C               *******************************************************
C
      IKMDSC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID CLUSTER DISTANCE         **
C               **                <EUCLIDEAN/MANHATTAN>              **
C               *******************************************************
C
      IKMDDI='MANH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               ********************************************************
C               **  TREAT THE SET K MEDIOID CLUSTER PRINT <ALL/FINAL> **
C               ********************************************************
C
      IKMDPR='ALL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID CLUSTER RANDOM NUMBER    **
C               **                GENERATOR <DATAPLOT/ROUSSEUW>      **
C               *******************************************************
C
      IKMDRN='DATA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID CLUSTER TYPE             **
C               **                <MEASUREMENTS/DISSIMILARITY>       **
C               *******************************************************
C
      IKMDTY='DISS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID NUMBER OF SAMPLES <VALUE> *
C               *******************************************************
C
      IKMDNS=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID SAMPLE SIZE <VALUE>      **
C               *******************************************************
C
      IKMDSS=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET K MEDIOID PAM MAXIMUM SIZE <VALUE> **
C               *******************************************************
C
      IKMDPN=100
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET AGNES     CLUSTER SCALE <ON/OFF>   **
C               *******************************************************
C
      IAGNSC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET AGNES     CLUSTER DISTANCE         **
C               **                <EUCLIDEAN/MANHATTAN>              **
C               *******************************************************
C
      IAGNDI='MANH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               ********************************************************
C               **  TREAT THE SET AGNES     CLUSTER PRINT <ALL/FINAL> **
C               ********************************************************
C
      IAGNPR='ALL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET AGNES CLUSTER TYPE                 **
C               **                <MEASUREMENT/DISSIMILARITY>        **
C               *******************************************************
C
      IAGNTY='DISS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE                                        **
C               **  SET AGNES CLUSTER METHOD  AVERAGE LINKAGE/       **
C               **      SINGLE LINKAGE/COMPLETE LINKAGE/WARD/        **
C               **      CENTROID/GOWER/WEIGHTED AVERAGE LINKAGE      **
C               *******************************************************
C
      IAGNME='AVER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET AGNES CLUSTER MAXIMUM SIZE <VALUE> **
C               *******************************************************
C
      IAGNMS=100
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET AGNES CLUSTER BANNER PLOT <ON/OFF> **
C               *******************************************************
C
      IAGNBA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET FANNY     CLUSTER SCALE <ON/OFF>   **
C               *******************************************************
C
      IFANSC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET FANNY     CLUSTER DISTANCE         **
C               **                <EUCLIDEAN/MANHATTAN>              **
C               *******************************************************
C
      IFANDI='MANH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               ********************************************************
C               **  TREAT THE SET FANNY     CLUSTER PRINT <ALL/FINAL> **
C               ********************************************************
C
      IFANPR='ALL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET FANNY CLUSTER TYPE                 **
C               **                <MEASUREMENT/DISSIMILARITY>        **
C               *******************************************************
C
      IFANTY='DISS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               *******************************************************
C               **  TREAT THE SET FANNY CLUSTER MAXIMUM SIZE <VALUE> **
C               *******************************************************
C
      IFANMS=100
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2017
C
C               *******************************************************
C               **  TREAT THE SET TAB ...                             *
C               *******************************************************
C
      DO3100II=1,10
        ITABCO(II)='NULL'
        ITABJU(II)='NULL'
        ITABFO(II)='NULL'
        ITABUN(II)='SCRE'
        ITABUV(II)='SCRE'
        PTABHP(II)=CPUMIN
        PTABVP(II)=CPUMIN
        PTABHE(II)=CPUMIN
        PTABWI(II)=CPUMIN
 3100 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET FILE NAME QUOTE                *
C               **  <ON/OFF>                                     *
C               **************************************************
C
      IFILQU='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2002
C
C               **************************************************
C               **  TREAT THE SET BOOTSTRAP FIT METHOD           *
C               **  <RESIDUALS/DATA>                             *
C               **************************************************
C
      IBOOME='RESI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET QWIN SYSTEM <SYSTEMQQ/WINEXEC> *
C               **************************************************
C
      IQWNSY='SYST'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               *******************************************************
C               **  TREAT THE SET LINUX SYSTEM <SYSTEM/               *
C               **                              COMMAND LINE EXECUTE> *
C               *******************************************************
C
      ILINSY='SYST'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET GHOSTVIEW PRINTER <ON/OFF>     *
C               **************************************************
C
      IPRNGS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET POSTSCRIPT BOUNDING BOX        *
C               **  <FIXED/FLOAT>                                *
C               **************************************************
C
      IPSTBB='FLOA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET POSTSCRIPT CONVERT             *
C               **  <GHOSTSCRIPT/CONVERT>                        *
C               **  <JPEG/PDF/TIFF/PBM/PNG/PNM/PPM>              *
C               **************************************************
C
      IPSTD2='GHOS'
      IPSTDV='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2002
C
C               **************************************************
C               **  TREAT THE SET GHOSTVIEW PATH  <PATH>         *
C               **************************************************
C  FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER
C  DIRECTLY (CAN GET COMPILE ERRORS).
C
C  2015/11: GHOSTVIEW NOW IN PROGRAM FILES DIRECTORY
C
      IF(IHOST1.EQ.'IBM-')THEN
        CALL DPCONA(92,IBASLC)
        NCGSPA=39
        IGSVPA=' '
        IGSVPA(1:39)='C: Program Files (x86) GHOSTGUM GSVIEW '
        IGSVPA(3:3)=IBASLC
        IGSVPA(23:23)=IBASLC
        IGSVPA(32:32)=IBASLC
        IGSVPA(39:39)=IBASLC
      ELSE
        NCGSPA=0
        IGSVPA=' '
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET GHOSTSCRIPT PATH  <PATH>       *
C               **************************************************
C
C  FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER
C  DIRECTLY (CAN GET COMPILE ERRORS).
C
C  2015/11: CHANGE DEFAULT TO VERSION 9.10
C
      CALL DPCONA(92,IBASLC)
      IF(IHOST1.EQ.'IBM-')THEN
        NCGHPA=31
        IGSTPA='C: Program Files GS GS9.10 BIN '
        IGSTPA(3:3)=IBASLC
        IGSTPA(17:17)=IBASLC
        IGSTPA(20:20)=IBASLC
        IGSTPA(27:27)=IBASLC
        IGSTPA(31:31)=IBASLC
      ELSE
        IGSTPA=' '
        NCGHPA=0
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2019
C
C               **************************************************
C               **  TREAT THE SET PYTHON PATH <PATH>             *
C               **  TREAT THE SET PYTHON VERSION <2/3/DEFAULT>   *
C               **************************************************
C
      IPYTPA=' '
      NCPYTH=0
      IPYTVR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2019
C
C               **************************************************
C               **  TREAT THE SET R      PATH <PATH>             *
C               **************************************************
C
      IRRRPA=' '
      NCRPAT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2019
C
C               **************************************************
C               **  TREAT THE SET EDITOR      <PATH>             *
C               **************************************************
C
      IEDITR='FED'
      NCEDIT=3
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2019
C
C               **************************************************
C               **  TREAT THE SET STRING JUSTIFICATION CHARACTER *
C               **                <CHAR>                         *
C               **************************************************
C
      ISJUCH='SPAC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET HTML HEADER FILE <FILE>        *
C               **************************************************
C
      IHTMHE='NULL'
      NCHTMH=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2016
C
C               **************************************************
C               **  TREAT THE SET WRITE HEADER FILE <FILE>      **
C               **************************************************
C
      IWRIHE='NULL'
      NCWRIH=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2003
C
C               **************************************************
C               **  TREAT THE SET HTML FOOTER FILE <FILE>        *
C               **************************************************
C
      IHTMFO='NULL'
      NCHTMF=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET LATEX HEADER FILE <FILE>       *
C               **************************************************
C
      ILATHE='NULL'
      NCLATH=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET LATEX FOOTER FILE <FILE>       *
C               **************************************************
C
      ILATFO='NULL'
      NCLATF=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE BORDER <ON/OFF/RULE/COLS>*
C               **************************************************
C
      ITABBR='RULE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE SPACING <VALUE>          *
C               **************************************************
C
      ITABSP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE WIDTH   <VALUE>          *
C               **************************************************
C
      ITABWD=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE HEIGHT   <VALUE>         *
C               **************************************************
C
      ITABHT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2003
C
C               **************************************************
C               **  TREAT THE SET TABLE TITLE <VALUE>            *
C               **************************************************
C
      ITABTI=' '
      NCTABT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2010
C
C               **************************************************
C               **  TREAT THE SET TABLE HEADER <ON/OFF>          *
C               **************************************************
C
      ITABHD='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ VARIABLE LABEL <ON/OFF/ROW> **
C               *****************************************************
C
      IVARLA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET CONVERT CHARACTER                **
C               **         <NUMERIC/GROUP/IGNORE/CATEGORICAL>      **
C               *****************************************************
C
      IGRPAU='ERRO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2018
C
C               *****************************************************
C               **  TREAT THE SET ROW LABEL COLUMN <VALUE>         **
C               *****************************************************
C
      IRWLCO=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2018
C
C               *****************************************************************
C               **  TREAT THE                                                  **
C               **        SET STREAM READ CROSS TABULATE VARIABLE ONE <NAME>   **
C               **        SET STREAM READ CROSS TABULATE VARIABLE TWO <NAME>   **
C               **        SET STREAM READ CROSS TABULATE VARIABLE THREE <NAME> **
C               **        SET STREAM READ CROSS TABULATE VARIABLE FOUR <NAME>  **
C               *****************************************************************
C
      ISREC1='        '
      ISREC2='        '
      ISREC3='        '
      ISREC4='        '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2018
C
C               *****************************************************************
C               **  TREAT THE SET STREAM READ GROUP LABEL <ON/OFF>   CASE      **
C               *****************************************************************
C
      ISREGL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2018
C
C               *****************************************************************
C               **  TREAT THE SET STREAM READ VARIABLE TYPE <NAME>   CASE      **
C               *****************************************************************
C
      ISREVT='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2018
C
C               *****************************************************************
C               **  TREAT THE SET STREAM READ NUMBER OF PERCENTILES            **
C               **                <VALUE>   CASE                               **
C               *****************************************************************
C
      ISRENP=999
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ DELIMITER <VALUE>           **
C               *****************************************************
C
CCCCC 2018/08: DO NOT AUTOMATICALLY SET THE READ DELIMITER TO A COMMA.
CCCCC          CHANGES WERE MADE TO DPREAL SUCH THAT IF A NON-SPACE
CCCCC          READ DELIMITER IS SPECIFIED, SPACES WILL NOT BE TREATED
CCCCC          AS DELIMITERS FOR CHARACTER FIELDS.  THIS WAS DONE SINCE
CCCCC          MANY COMMA DELIMITED FILES ALLOW SPACES IN CHARACTER
CCCCC          FIELDS.  HOWEVER, THIS MEANS THAT SETTING THE COMMA AS
CCCCC          A DEFAULT DELIMITER CREATES PROBLEMS FOR FILES THAT ARE
CCCCC          NOT ACTUALLY COMMA DELIMITED (E.G., CHARACTER FIELDS ARE
CCCCC          DELIMITED WITH SPACES OR TABS).
CCCCC IREADL=','
      IREADL=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *****************************************************
C               **  TREAT THE SET DATE DELIMITER <VALUE>           **
C               *****************************************************
C
      IDATDL='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *****************************************************
C               **  TREAT THE SET TIME DELIMITER <VALUE>           **
C               *****************************************************
C
      ITIMDL='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *****************************************************
C               **  TREAT THE SET READ IP ADDRESSES <ON/OFF>       **
C               *****************************************************
C
      IRDIPA='OFF'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2004
C
C               *****************************************************
C               **  TREAT THE SET READ MISSING VALUE <VALUE>       **
C               *****************************************************
C
      PREAMV=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2010
C
C               *****************************************************
C               **  TREAT THE SET READ NON-PRINTING CHARACTERS     **
C               **                <SPACE/DELETE>                   **
C               *****************************************************
C
      IREANP='DELE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2018
C
C               *****************************************************************
C               **  TREAT THE SET WRITE FEEDBACK <ON/OFF>            CASE      **
C               *****************************************************************
C
CCCCC 2019/11: CHANGE THE DEFAULT.  THIS SETTING WILL PRINT MOST
CCCCC          ERROR MESSAGES EVEN IF FEEDBACK SWITCH IS SET TO OFF.
C
CCCCC IFEEWR='OFF'
      IFEEWR='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET GEOMETRIC DEFINITION             **
C               **        <JOHNSON AND KOTZ/DLMF>                  **
C               *****************************************************
C
      IGEODF='KOTZ'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT                        **
C               **        <LINEAR/BIWEIGHT/RANK>                   **
C               *****************************************************
C
      IPPCCC='LINE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC FORMAT                      **
C               **        <3D/TRACE>                               **
C               *****************************************************
C
      IPPCFO='TRAC'
C
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2004
C
C               *****************************************************
C               **  TREAT THE SET HYPERGEOMETRIC MAXIMUM LIKELIHOOD**
C               **        <ACCEPTANCE SAMPLING/CAPTURE RECAPTURE>  **
C               *****************************************************
C
      IHYPTY='ACCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET POSTSCRIPT DEFAULT COLOR         **
C               **        <ON/OFF>                                 **
C               *****************************************************
C
      IPSTDC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET ASYMMETRIC LAPLACE DEFINITION    **
C               **        <K/MU>                                   **
C               *****************************************************
C
      IADEDF='K'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2004
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED PARETO DEFINITION    **
C               **        <JOHNSON AND KOTZ/SIMIU>                 **
C               *****************************************************
C
      IGEPDF='SIMI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2005
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED PARETO MLE STARTING  **
C               **        VALUES  MOMENT/L MOMENTS/                **
C               **        ELEMENTAL PERCENTILES/USER SPECIFIED     **
C               *****************************************************
C
      IGEPSV='EPER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2004
C
C               *****************************************************
C               **  TREAT THE SET GOMPERTZ-MAKEM   O DEFINITION    **
C               **        <DLMF/MEEKER/REPARAMETERIZED MEEKER>     **
C               *****************************************************
C
      IMAKDF='REPA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET BESSEL I FUNCTION  DEFINITION    **
C               **        <1/2>                                    **
C               *****************************************************
C
      IBEIDF='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET BESSEL K FUNCTION  DEFINITION    **
C               **        <1/2>                                    **
C               *****************************************************
C
      IBEKDF='1'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PROBABILITY PLOT DATA POINTS     **
C               **        <VALUE>                                  **
C               *****************************************************
C
      IPPLDP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC        PLOT DATA POINTS     **
C               **        <VALUE>                                  **
C               *****************************************************
C
      IPPCDP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT AXIS POINTS            **
C               **        <VALUE1> <VALUE2>                        **
C               *****************************************************
C
      IPPCAP(1)=0
      IPPCAP(2)=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT AXIS ORDER             **
C               **        <DEFAULT/REVERSE>                        **
C               *****************************************************
C
      IPPCAO='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET HISTOGRAM CLASS WIDTH            **
C               **         DEFAULT/NORMAL/NORMAL CORRECTED/SD/     **
C               **        STANDARD DEVIATION/IQ/INTERQUARTILE RANG **
C               *****************************************************
C
      IHSTCW='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET ASH WEIGHTING                    **
C               **        <TRIANGULAR/BIWEIGHT>                    **
C               *****************************************************
C
      IASHWT='TRIA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET READ PAD MISSING COLUMNS         **
C               **        <ON/OFF>                                 **
C               *****************************************************
C
      IREAPD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET READ SUBSET                      **
C               **        <PACK/DISPERSE>  <PACK/DISPERSE>         **
C               *****************************************************
C
      IREASB='P-D'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PROBABILITY PLOT                 **
C               **  <KAPLAN-MEIER/UNIFORM ORDER STATISTC MEDIANS>  **
C               *****************************************************
C
      IPPLCN='UNIM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT                        **
C               **  <KAPLAN-MEIER/UNIFORM ORDER STATISTC MEDIANS>  **
C               *****************************************************
C
      IPPCCN='UNIM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MAXIMUM LIKELIHOOD QUANTILE      **
C               **  <NONE/DEFUALT/VARIABLE NAME>                   **
C               *****************************************************
C
      IQUAVR='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MAXIMUM LIKELIHOOD RELIABILITY   **
C               **  <NONE/DEFUALT/VARIABLE NAME>                   **
C               *****************************************************
C
      IRELVR='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2004
C
C               *****************************************************
C               **  TREAT THE SET EXPONENTIAL BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IEXPBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET WEIBULL     BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IWEIBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET GUMBEL      BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IGUMBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MATRIX CORRELATION DIRECTION     **
C               **  <ROW/COLUMN>                                   **
C               *****************************************************
C
      ICORDI='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET MATRIX COVARIANCE  DIRECTION     **
C               **  <ROW/COLUMN>                                   **
C               *****************************************************
C
      ICOVDI='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2008
C
C               *****************************************************
C               **  TREAT THE SET GUI FEEDBACK <ON/OFF>            **
C               *****************************************************
C
      IGUIFB='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2004
C
C               *****************************************************
C               **  TREAT THE SET GUI <ON/OFF>                     **
C               *****************************************************
C
      IGUIFL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2009
C
C               *****************************************************
C               **  TREAT THE SET PROMPT ADVANCE <ON/OFF>          **
C               *****************************************************
C
      IPROAD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2009
C
C               *****************************************************
C               **  TREAT THE SET HTML TABLE FONT <FONT-NAME>      **
C               *****************************************************
C
      IHTMFT='NONE'
      NCHTM1=4
      IHTMFZ=IHTMFT
      NCFON1=NCHTM1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2009
C
C               *****************************************************
C               **  TREAT THE SET HTML CELL WIDTH <VALUE>          **
C               *****************************************************
C
      IHTMCW=150
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET DISTRIBUTIONAL BOOTSTRAP         **
C               **            <NONPARAMETRIC/PARAMETRIC>           **
C               *****************************************************
C
      IBOOPA='NONP'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF POINT SIZE <VALUE>           **
C               *****************************************************
C
      IRTFPS=20
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF FIXED FONT <FONT NAME>       **
C               *****************************************************
C
      IRTFFF='Courier New'
      NCRTF1=11
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET RTF PROPORTIONAL FONT <FONT NAME>**
C               *****************************************************
C
      IRTFFP='Times New Roman'
      NCRTF1=15
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2005
C
C               *****************************************************
C               **  TREAT THE SET PARAMETER EXPAND DIGIT <VALUE>   **
C               *****************************************************
C
      IEXPDI=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2005
C
C               *****************************************************
C               **  TREAT THE SET LINE PRINTER COLUMNS <80/130>    **
C               *****************************************************
C
      ILPRCO=80
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET DECIMAL POINT <value>            **
C               *****************************************************
C
      IDECPT='.'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD METHOD <val> *
C               *****************************************************
C
      IPOTME='DEHA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD LOAD FACTOR **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IPOTLF='OFF '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD X AXIS      **
C               **                <POINTS/THRESHOLD>               **
C               *****************************************************
C
      IPOTAX='POIN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD DISTRIBUTION *
C               **  <GENERALIZED PARETO/WEIBULL/FRECHET/GUMBEL>     *
C               *****************************************************
C
      IPOTDI='GPAR'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD ITERATIONS   *
C               **  <value>                                         *
C               *****************************************************
C
      IPOTIT=30
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INITIAL      *
C               **  POINTS <value>                                  *
C               *****************************************************
C
      IPOTNP=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INITIAL      *
C               **  THRESHOLD <value>                               *
C               *****************************************************
C
      PPOTTH=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD INCREMENT    *
C               **            <value>                               *
C               *****************************************************
C
      PPOTIN=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD PERIOD       *
C               **            <value>                               *
C               *****************************************************
C
      PPOTPE=-1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2005
C
C               *****************************************************
C               **  TREAT THE SET PEAKS OVER THRESHOLD TOLERANCE    *
C               **            <value>                               *
C               *****************************************************
C
      PPOTTO=0.05
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2005
C
C               *****************************************************
C               **  TREAT THE SET FRECHET     BIAS CORRECTED       **
C               **  <ON/OFF>                                       **
C               *****************************************************
C
      IFREBC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2005
C
C               *****************************************************
C               **  TREAT THE SET GRUBBS ONE SIDED <ON/OFF>        **
C               *****************************************************
C
      IGRU1S='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2005
C
C               *****************************************************
C               **  TREAT THE SET LOG GAMMA          DEFINITION    **
C               **        <DEFAULT/REPARAMETERIZED>                **
C               *****************************************************
C
      ILGADF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2005
C
C               *****************************************************
C               **  TREAT THE SET SKEW NORMAL        DEFINITION    **
C               **        <DEFAULT/REPARAMETERIZED>                **
C               *****************************************************
C
      ISKNDF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2006
C
C               *****************************************************
C               **  TREAT THE CAPTURE SCREEN <ON/OFF>              **
C               *****************************************************
C
      ICAPSC='OFF '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2005
C
C               *****************************************************
C               **  INITIATILE MACCRO ARGUMENTS                    **
C               *****************************************************
C
      NMACAG=0
      NMACCL=0
      IDEFMS='$'
      IMACSC=IDEFMS
      DO2011II=1,50
        IMACAR(II)=' '
 2011 CONTINUE
      IMACCL=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2006
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED TUKEY-LAMBDA         **
C               **  DEFINITION:   <FMKL/RAMB>                      **
C               *****************************************************
C
      IGLDDF='FMKL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH    2006
C
C               *****************************************************
C               **  TREAT THE SET LOCAL FILES <PID/IGNORE>         **
C               *****************************************************
C
      ITMPFI='PID'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2006
C
C               *****************************************************
C               **  TREAT THE SET PPCC PLOT LOCATION SCALE         **
C               **                <BIWEIGHT/DEFAULT>               **
C               *****************************************************
C
      IPPCBW='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY      2006
C
C               *****************************************************
C               **  TREAT THE SET BETA GEOMETRIC DEFINITION        **
C               **                <UNSHIFTED/SHIFTED>              **
C               *****************************************************
C
      IBGEDF='UNSH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE      2006
C
C               *****************************************************
C               **  TREAT THE SET FORTRAN FORMAT CONTROL           **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IFORFM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE      2006
C
C               *****************************************************
C               **  TREAT THE SET MANDEL PAULE                     **
C               **            SET MODIFIED MANDEL PAULE            **
C               **            SET VANGEL RUHKIN                    **
C               **            SET DERSIMONIAN LAIRD                **
C               **            SET DERSIMONIAN LAIRD HHD            **
C               **            SET DERSIMONIAN LAIRD MINMAX         **
C               **            SET GRAYBILL DEAL                    **
C               **            SET GENERALIZED CONFIDENCE INTERVALS **
C               **            SET FAIRWEATHER                      **
C               **            SET FAIRWEATHER COX                  **
C               **            SET FAIRWEATHER MINMAX               **
C               **            SET MEAN OF MEANS                    **
C               **            SET GRAND MEANS                      **
C               **            SET BOB                              **
C               **            SET SCHILLER EBERHARDT               **
C               **            SET LP LOCATION                      **
C               **            SET MEDIAN OF MEANS                  **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IMPACM='ON'
      IMMPCM='ON'
      IVRUCM='ON'
      IVRBCM='OFF'
      IBOBCM='ON'
      ISCECM='OFF'
      IMOMCM='ON'
      IMEMCM='OFF'
      ITRMCM='OFF'
      IGRDCM='ON'
      IGMECM='ON'
      IGCICM='ON'
      IDSLCM='ON'
      IDS2CM='ON'
      IDS3CM='OFF'
      IDS4CM='OFF'
      IFAICM='OFF'
      IFA2CM=IFAICM
      IFA3CM=IFAICM
      IBCPCM='OFF'
      ILPLCM='OFF'
      IHUBCM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY     2006
C
C               *****************************************************
C               **  TREAT THE SET GEETA          DEFINITION        **
C               **                <THETA/MU>                       **
C               *****************************************************
C
      IGETDF='MU  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY     2006
C
C               *****************************************************
C               **  TREAT THE SET CHISQUARE LIMIT <VALUE>          **
C               *****************************************************
C
      PCHSLM=1000000.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER     2006
C
C               *****************************************************
C               **  TREAT THE SET MAXWELL LOCATION  <VALUE>        **
C               *****************************************************
C
      PMAXLO=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST   2006
C
C               *****************************************************
C               **  TREAT THE SET CONSUL         DEFINITION        **
C               **                <THETA/MU>                       **
C               *****************************************************
C
      ICONDF='MU  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER   2006
C
C               *****************************************************
C               **  TREAT THE SET 4PLOT DISTRIBUTION               **
C               **                <NORMAL/EXPONENTIAL>             **
C               *****************************************************
C
      I4PLDI='NORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY   2007
C
C               *****************************************************
C               **  TREAT THE SET GOMPERTZ       DEFINITION        **
C               **                <JOHN/GARG>                      **
C               *****************************************************
C
      IGOMDF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY   2007
C
C               *****************************************************
C               **  TREAT THE SET KATZ           DEFINITION        **
C               **                <DEFAULT/MOMENTS>                **
C               *****************************************************
C
      IKATDF='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY  2007
C
C               *****************************************************
C               **  TREAT THE SET BINOMIAL CONTINUITY CORRECTION   **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IBINCC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY  2007
C
C               *****************************************************
C               **  TREAT THE SET BINOMIAL NORMAL APPROXIMATION    **
C               **                THRESHOLD <VALUE>                **
C               *****************************************************
C
      PBINTH=30.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2008
C
C               *****************************************************
C               **  TREAT THE SET BINOMIAL TAIL                    **
C               **                <LOWER/UPPER/TWO-SIDED>          **
C               *****************************************************
C
      IBINTA='TWOS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2007
C
C               *****************************************************
C               **  TREAT THE SET FISHER EXACT TEST EXPECTED       **
C               **                <VALUE>                          **
C               *****************************************************
C
      PFISEX=5.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2007
C
C               *****************************************************
C               **  TREAT THE SET FISHER EXACT TEST EXPECTED       **
C               **                MINIMUM <VALUE>                  **
C               *****************************************************
C
      PFISEM=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2007
C
C               *****************************************************
C               **  TREAT THE SET FISHER EXACT TEST PERCENTAGE     **
C               **                <VALUE>                          **
C               *****************************************************
C
      PFISPC=80.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL     2007
C
C               *****************************************************
C               **  TREAT THE SET FATAL ERROR                      **
C               **                <IGNORE/TERMINATE/PROMPT>        **
C               *****************************************************
C
      IERRFA='IGNO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER   2015
C
C               *****************************************************
C               **  TREAT THE SET WARNING ERROR                    **
C               **                <IGNORE/TERMINATE/PROMPT>        **
C               *****************************************************
C
      IERRWA='IGNO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL     2007
C
C               *****************************************************
C               **  TREAT THE SET STATISTIC MISSING VALUE          **
C               **                <VALUE>                          **
C               *****************************************************
C
CCCCC PSTAMV=-9999.0
      PSTAMV=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY     2007
C
C               *****************************************************
C               **  TREAT THE SET BINARY TABULATION PLOT GROUP NAME**
C               **                <VARIABLE NAME>                  **
C               *****************************************************
C
      IBTAGN=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY     2007
C
C               *****************************************************
C               **  TREAT THE SET POISSON PLOT LEVEL <ON/OFF>      **
C               *****************************************************
C
      IPOILV='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2007
C
C               ******************************************
C               **  TREAT THE PROBE ERROR               **
C               ******************************************
C
      IERRST='NO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2008
C
C               *****************************************************
C               **  TREAT THE SET COLOR MAXIMUM     VALUE          **
C               **                <VALUE>                          **
C               *****************************************************
C
      PCOLMX=255.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL     2008
C
C               *****************************************************
C               **  TREAT THE SET CROSS TABULATE MISSING           **
C               **                <SKIP/ZERO/MV>                   **
C               *****************************************************
C
      ICTAMV='SKIP'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL     2008
C
C               *****************************************************
C               **  TREAT THE SET CROSS TABULATE MISSING VALUE     **
C               **                <VALUE>                          **
C               *****************************************************
C
      PCTAMV=-9999.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2008
C
C               *****************************************************
C               **  TREAT THE SET FIT METHOD                       **
C               **                <SVD/GRAM-SCHMIDT>               **
C               *****************************************************
C
      IFITME='GRAM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE  2014
C
C               *****************************************************
C               **  TREAT THE SET FIT AUXILLARY FILES <ON/OFF>     **
C               *****************************************************
C
      IFITAU='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY  2014
C
C               *******************************************************
C               **  TREAT THE SET NORMAL PLOT AXES <DEFAULT/REVERSE> **
C               *******************************************************
C
      INPLAX='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST  2014
C
C               *******************************************************
C               **  TREAT THE SET LATEX RESIZE     <ON/OFF>          **
C               *******************************************************
C
      ILATRS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER  2014
C
C               *******************************************************
C               **  TREAT THE SET CIRCLE CORRECTION  <ON/OFF>        **
C               *******************************************************
C
      ICIRCR='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY     2008
C
C               *****************************************************
C               **  TREAT THE SET FLUCUATION PLOT FLOOR <VALUE>    **
C               *****************************************************
C
      PFLUFL=-9999.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY     2008
C
C               *****************************************************
C               **  TREAT THE SET FLUCUATION PLOT CEILING          **
C               **                <VALUE>                          **
C               *****************************************************
C
      PFLUCL=-9999.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY     2008
C
C               *****************************************************
C               **  TREAT THE SET FLUCUATION PLOT WIDTH            **
C               **                <FIXED/PROPORTIONAL>             **
C               *****************************************************
C
      IFLUWI='FIXE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER     2009
C
C               *****************************************************
C               **  TREAT THE SET FLUCUATION PLOT UNCERTAINTY      **
C               **                INTERVAL <ON/OFF>                **
C               *****************************************************
C
      IFLUUN='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY       2010
C
C               *****************************************************
C               **  TREAT THE SET FLUCUATION PLOT CODED <ON/OFF>   **
C               *****************************************************
C
      IFLUCD='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL         2010
C
C               *******************************************************
C               **  TREAT THE SET FLUCUATION CONTOUR BINOMIAL        **
C               **        PROPORTION <POINT/LOWER LIMIT/UPPER LIMIT> **
C               *******************************************************
C
      IFLUBP='POIN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY       2010
C
C               *****************************************************
C               **  TREAT THE SET TABULATION PLOT CODED <ON/OFF>   **
C               *****************************************************
C
      ITPLCD='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *****************************************************
C               **  TREAT THE SET TABULATION PLOT SORTED <ON/OFF>  **
C               *****************************************************
C
      ITPLSO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *******************************************************
C               **  TREAT THE SET TABULATION PLOT ROW SORT           **
C               **                DIRECTION <ASCENDING/DESCENDING>   **
C               *******************************************************
C
      ITPLSR='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *******************************************************
C               **  TREAT THE SET TABULATION PLOT COLUMN SORT        **
C               **                DIRECTION <ASCENDING/DESCENDING>   **
C               *******************************************************
C
      ITPLSC='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               ********************************************************
C               **  TREAT THE SET TABULATION PLOT ROW MINMAX <ON/OFF> **
C               ********************************************************
C
      ITPLRM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               ********************************************************
C               **  TREAT THE SET TABULATION PLOT COLUMN MINMAX       **
C               **                <ON/OFF>                            **
C               ********************************************************
C
      ITPLCM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *****************************************************
C               **  TREAT THE SET FLUCTUATION PLOT SORTED <ON/OFF> **
C               *****************************************************
C
      IFLUSO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *******************************************************
C               **  TREAT THE SET FLUCTUATION PLOT ROW SORT          **
C               **                DIRECTION <ASCENDING/DESCENDING>   **
C               *******************************************************
C
      IFLUSR='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE          2010
C
C               *******************************************************
C               **  TREAT THE SET FLUCTUATION PLOT COLUMN SORT       **
C               **                DIRECTION <ASCENDING/DESCENDING>   **
C               *******************************************************
C
      IFLUSC='ASCE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2008
C
C               *****************************************************
C               **  TREAT THE SET GENERALIZED INVERSE GAUSSIAN     **
C               **            DEFINITION <2-PARAMETER/3-PARAMETER> **
C               *****************************************************
C
      IGIGDF='3PAR'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2008
C
C               *****************************************************
C               **  TREAT THE SET MERGE MATCH VARIABLES <VALUE>    **
C               *****************************************************
C
      IMERMA=1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2008
C
C               *****************************************************
C               **  TREAT THE SET MERGE CARRY VARIABLES <VALUE>    **
C               *****************************************************
C
      IMERCA=1
      IMERC2=IMERCA
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2008
C
C               *****************************************************
C               **  TREAT THE SET CROSS TABULATE FORMAT            **
C               **            <VALUE>                              **
C               *****************************************************
C
      ICTAFO=' '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2008
C
C               *****************************************************
C               **  TREAT THE SET STRIP PLOT INCREMENT             **
C               **                <VALUE>                          **
C               *****************************************************
C
      PSTRIN=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2008
C
C               *****************************************************
C               **  TREAT THE SET STRIP PLOT STYLE <STACK/JITTER>  **
C               *****************************************************
C
      ISTRPL='STAC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY 2009
C
C               *****************************************************
C               **  FEEDBACK SAVE PARAMETER                        **
C               *****************************************************
C
      IFEESV='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2009
C
C               *****************************************************
C               **  TREAT THE SET LET CROSS TABULATE               **
C               **                <EXPAND/COLLAPSE>                **
C               *****************************************************
C
      ICTALT='EXPA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2011
C
C               *****************************************************
C               **  TREAT THE SET LET CROSS TABULATE EMPTY         **
C               **                <EXCLUDE/INCLUDE>                **
C               *****************************************************
C
      ICTAEM='EXCL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2011
C
C               *****************************************************
C               **  TREAT THE SET LET CROSS TABULATE COMPLEMENT    **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      ICTACO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *****************************************************
C               **  TREAT THE SET LET CROSS TABULATE GROUPS        **
C               **                <CONTIGUOUS/NONCONTIGUOUS>       **
C               *****************************************************
C
      ICTAGR='NONC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2009
C
C               *****************************************************
C               **  TREAT THE SET STRING SPACE <EXPAND/IGNORE>     **
C               *****************************************************
C
      ISTRSP='EXPA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2009
C
C               ********************************************************
C               **  TREAT THE SET CONVERT DENSITY HORIZONTAL <VALUE>  **
C               ********************************************************
C
      ICONDH=72
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2009
C
C               ******************************************************
C               **  TREAT THE SET CONVERT DENSITY VERTICAL <VALUE>  **
C               ******************************************************
C
      ICONDV=72
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2009
C
C               ******************************************************
C               **  TREAT THE SET STATISTIC PLOT FORMAT             **
C               **                <OVERLAY/DEX>                     **
C               ******************************************************
C
      ISTAFO='DEX'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2009
C
C               ******************************************************
C               **  TREAT THE SET STATISTIC PLOT SUMMARY            **
C               **                <VARIABLE/GROUP>                  **
C               ******************************************************
C
      ISTASM='GROU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2009
C
C               ******************************************************
C               **  INITIALIZE IFORWI, IFORRI (SET TO -99, WHICH    **
C               **  BASICALLY MEANS IGNORE THESE SETTINGS           **
C               ******************************************************
C

      MAXNWI=200
      DO8210I=1,MAXNWI
        IFORWI(I)=-99
        IFORWR(I)=-99
 8210 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2009
C
C               ******************************************************
C               **  TREAT THE SET BIPLOT SCALE                      **
C               **                <COLUMN MEAN/GRAND MEAN/NONE>     **
C               ******************************************************
C
      IBPLSC='CMEA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2009
C
C               ******************************************************
C               **  TREAT THE SET BIPLOT COEFFICIENT <VALUE>        **
C               ******************************************************
C
      PBPLCO=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2009
C
C               ******************************************************
C               **  TREAT THE SET LATEX POINT SIZE <VALUE>          **
C               ******************************************************
C
      ILATPS=12
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2009
C
C               ******************************************************
C               **  TREAT THE SET DATA MISSING VALUE                **
C               **                <VALUE>                           **
C               ******************************************************
C
      IDATMV='MV'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2010
C
C               ******************************************************
C               **  TREAT THE SET DATA NAN <VALUE>                  **
C               ******************************************************
C
      IDATNN='NAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2009
C
C               ******************************************************
C               **  TREAT THE SET READ LINE <ON/OF>                 **
C               ******************************************************
C
      IREALI='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               ******************************************************
C               **  TREAT THE SET CHARACTER FIELD COMMA DELIMITER   **
C               **                 <ON/OF>                          **
C               ******************************************************
C
      IREACD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               ******************************************************
C               **  TREAT THE SET READ COMMA IGNORE <ON/OFF>        **
C               ******************************************************
C
      IREACM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               ******************************************************
C               **  TREAT THE SET READ DOLLAR SIGN IGNORE <ON/OFF>  **
C               ******************************************************
C
      IREADS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               ******************************************************
C               **  TREAT THE SET READ PERCENT SIGN IGNORE <ON/OFF> **
C               ******************************************************
C
      IREAPC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET OUTPUT LINE NUMBERS      <ON/OFF> **
C               ******************************************************
C
      IOUTLN='OFF'
      ILNCNT=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               ******************************************************
C               **  TREAT THE SET READ TRAILING PLUS MINUS  IGNORE  **
C               **                <ON/OFF>                          **
C               ******************************************************
C
      IREAPM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2019
C
C               ******************************************************
C               **  TREAT THE SET READ ASTERISK IGNORE <ON/OFF>     **
C               ******************************************************
C
      IREAAS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2019
C
C               ******************************************************
C               **  TREAT THE SET BOXPLOT FENCE SKEWNESS            **
C               **                <GALTON/OFF>                      **
C               ******************************************************
C
      IBXPSK='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2019
C
C               ******************************************************
C               **  TREAT THE SET ONE SAMPLE PROFICIENCY TEST       **
C               **                IDENTIFY LAB <DEFAULT/UNUSUAL/    **
C               **                EXTREMELY UNUSUAL>                **
C               ******************************************************
C
      I1PTOC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET GREP CASE <IGNORE/NOIGNORE>       **
C               **  TREAT THE SET GREP RECURSIVE <ON/OFF>           **
C               **  TREAT THE SET GREP LINE NUMBERS <ON/OFF>        **
C               **  TREAT THE SET GREP EXACT MATCH <ON/OFF>         **
C               **  TREAT THE SET GREP NO MATCH <ON/OFF>            **
C               **  TREAT THE SET GREP FILE NAME ONLY <ON/OFF>      **
C               ******************************************************
C
      IGRPCA='IGNO'
      IGRPRE='OFF'
      IGRPLN='ON'
      IGRPEM='OFF'
      IGRPNM='OFF'
      IGRPFN='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET DIR RECURSIVE <ON/OFF>            **
C               **  TREAT THE SET DIR PAUSE <ON/OFF>                **
C               **  TREAT THE SET DIR LONG LISTING <ON/OFF>         **
C               **  TREAT THE SET DIR SORT <ALPHA/SIZE/DATE>        **
C               ******************************************************
C
      IDIRRE='OFF'
      IDIRPA='OFF'
      IDIRLL='OFF'
      IDIRSO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET CAT MORE  <ON/OFF>                **
C               ******************************************************
C
      ICATMO='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET CAT MORE  <ON/OFF>                **
C               ******************************************************
C
      ICATMO='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET STRING VARIABLE <APPEND/OVERWRITE> *
C               ******************************************************
C
      ISTRVA='OVER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET STRING COMBINE SEPARATOR <VAL>     *
C               ******************************************************
C
      ISTRCS='SP()'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET RATIO OF MEANS METHOD              *
C               **                <FIELLER/LOG RATIO/LARGE SAMPLE>   *
C               ******************************************************
C
      IRATME='FIEL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               ******************************************************
C               **  TREAT THE SET DAVID TEST CRITICAL VALUE         **
C               **                <ASTM/DAVID/OFF>                  **
C               ******************************************************
C
      IDAVTA='ASTM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               ******************************************************
C               **  TREAT THE SET SKEW OUTLIER TEST CRITICAL VALUE  **
C               **                <ASTM/SIMULATION>                 **
C               ******************************************************
C
      ISKOTA='ASTM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               *********************************************************
C               **  TREAT THE SET KURTOSIS OUTLIER TEST CRITICAL VALUE **
C               **                <ASTM/SIMULATION>                    **
C               *********************************************************
C
      IKUOTA='ASTM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2017
C
C               ******************************************************
C               **  TREAT THE SET READ CHARACTER MISSING VALUE      **
C               **                <STRING>                          **
C               ******************************************************
C
      IREAMC='ZZZZNULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2017
C
C               ******************************************************
C               **  TREAT THE SET TWO SAMPLE COEFFICIENT OF         **
C               **                VARIATION TEST <FORKMAN/MILLER>   **
C               ******************************************************
C
      ICVTTE='FORK'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ******************************************************
C               **  TREAT THE SET BLAND ALTMAN PLOT                 **
C               **                <RAW/PERCENTAGE>                  **
C               ******************************************************
C
      IBAPPE='RAW'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ******************************************************
C               **  TREAT THE SET BLAND ALTMAN PLOT STATISTIC       **
C               **                <MEAN/MEDIAN>                     **
C               ******************************************************
C
      IBAPST='MEAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ******************************************************
C               **  TREAT THE SET BLAND ALTMAN PLOT BOOTSTRAP       **
C               **                <RAW/SUMMARY>                     **
C               ******************************************************
C
      IBAPBO='SUMM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ******************************************************
C               **  TREAT THE SET BLAND ALTMAN PLOT CONFIDENCE LIMI **
C               **                <ANALYTIC/BOOTSTRAP>              **
C               ******************************************************
C
      IBAPCL='ANAL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2017
C
C               ********************************************************
C               **  TREAT THE SET SAMPLE RANDOM PERMUTATION DISTINCT  **
C               **                <ON/OFF>                            **
C               ********************************************************
C
      ISRPDI='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2009
C
C               ******************************************************
C               **  TREAT THE SET CODE CROSS TABULATE OFFSET        **
C               **                     <VALUE>                      **
C               **            SET CODE CROSS TABULATE GROUP SIZE    **
C               **                     <VALUE1>  ... <VALUE6>       **
C               ******************************************************
C
      ICCTOF=0
      ICCTG1=0
      ICCTG2=0
      ICCTG3=0
      ICCTG4=0
      ICCTG5=0
      ICCTG6=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2009
C
C               *********************************************************
C               **  TREAT THE SET LOD CRITICAL VALUE <QUANTILE/NORMAL> **
C               *********************************************************
C
      ILODCV='QUAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2012
C
C               *********************************************************
C               **  TREAT THE SET LOD SUMMARY TABLE <ON/OFF>           **
C               *********************************************************
C
      ILODST='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2012
C
C               *********************************************************
C               **  TREAT THE SET LOD TABLE <ON/OFF>                   **
C               *********************************************************
C
      ILODTA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST 2012
C
C               *********************************************************
C               **  TREAT THE SET LOD PRINT CRITICAL VALUE <ON/OFF>    **
C               *********************************************************
C
      ILODPC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               *********************************************************
C               **  TREAT THE SET KOLMOGOROV SMIRNOV CRITICAL VALUE    **
C               **                <TABLE/SIMULATION>                   **
C               *********************************************************
C
      IKSCVM='SIMU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               *********************************************************
C               **  TREAT THE SET ANDERSON DARLING CRITICAL VALUE      **
C               **                <TABLE/SIMULATION>                   **
C               *********************************************************
C
      IADCVM='SIMU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               *********************************************************
C               **  TREAT THE SET CONTROL CHART LIMITS                 **
C               **                <DEFAULT/WECO/ISO 13528>             **
C               *********************************************************
C
      ICONWC='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               ********************************************************
C               **  TREAT THE SET TABULATION PLOT X INCREMENT <VALUE> **
C               ********************************************************
C
      PTPLXI=0.05
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               ********************************************************
C               **  TREAT THE SET TABULATION PLOT Y INCREMENT <VALUE> **
C               ********************************************************
C
      PTPLYI=0.05
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2011
C
C               ********************************************************
C               **  TREAT THE SET MEDIAN TEST QUANTILE        <VALUE> **
C               ********************************************************
C
      PMTEQU=0.5
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2009
C
C               ********************************************************
C               **  TREAT THE SET TABULATION PLOT DIRECTION   <X/Y>   **
C               ********************************************************
C
      ITPLDI='Y'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2010
C
C               ********************************************************
C               **  TREAT THE SET FLUCTUATION PLOT DIRECTION   <X/Y>  **
C               ********************************************************
C
      IFLUDI='Y'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2009
C
C               ********************************************************
C               **  TREAT THE SET GOODNESS OF FIT FULLY SPECIFIED     **
C               **                <ON/OFF>                            **
C               ********************************************************
C
      IGOFFS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2011
C
C               ********************************************************
C               **  TREAT THE SET GOODNESS OF FIT FIT METHOD          **
C               **                <ML/PPCC/DEFAULT>                   **
C               ********************************************************
C
      IGOFFM='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2009
C
C               *****************************************************
C               **  TREAT THE SET TABULATION PLOT UNCERTAINTY      **
C               **                INTERVAL <ON/OFF>                **
C               *****************************************************
C
      ITPLUN='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2009
C
C               *****************************************************
C               **  TREAT THE SET TABULATION PLOT NUMBER OF        **
C               **        UNCERTAINTY INTERVALS <VALUE>            **
C               *****************************************************
C
      ITPLNI=50
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY       2010
C
C               *****************************************************
C               **  TREAT THE SET HISTOGRAM EMPTY BINS <ON/OFF>    **
C               *****************************************************
C
      IHSTEB='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY       2010
C
C               *****************************************************
C               **  TREAT THE SET HISTOGRAM OUTLIERS   <ON/OFF>    **
C               *****************************************************
C
      IHSTOU='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL         2010
C
C               *****************************************************
C               **  TREAT THE SET LOD OUTPUT FILES   <ON/OFF>      **
C               *****************************************************
C
      ILODOF='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY    2010
C
C               *****************************************************
C               **  TREAT THE SET DISTRIBUTIONAL FIT TYPE          **
C               **        <ML/MOMENT/LMOMENT/ELEMENAL PERCENTILE>  **
C               *****************************************************
C
      IDFTTY='ML'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET BRITTLE FIBER WEIBULL LENGTH     **
C               **        <ON/OFF>                                 **
C               *****************************************************
C
      IBFWTY='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2010
C
C               *****************************************************
C               **  TREAT THE SET BRITTLE FIBER WEIBULL L          **
C               **        <CONSTANT/VARIABLE>                      **
C               *****************************************************
C
      IBFWLI='CONS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2010
C
C               ****************************************************
C               **  TREAT THE SET END EFFECTS WEIBULL L           **
C               **        <CONSTANT/VARIABLE>                     **
C               ****************************************************
C
      IEEWLI='CONS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED   SEPTEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET PAUSE LINES <value>              **
C               *****************************************************
C
      IPAULI=0
      IPAUCN=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET BOOTSTRAP PERCENTILE             **
C               **        <PERCENT POINT/DATA>                     **
C               *****************************************************
C
      IBOOPE='PERC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST    2011
C
C               *****************************************************
C               **  TREAT THE SET BOOTSTRAP DISTRIBUTIONAL         **
C               **        PERCENTILES <OFF/LOWER/UPPER/TWOSIDED>   **
C               *****************************************************
C
      IBOODP='TWOS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST    2011
C
C               *****************************************************
C               **  TREAT THE SET BOOTSTRAP CONFIDENCE INTERVALS   **
C               **                <PERCENTILE/T>                   **
C               *****************************************************
C
      IBOOCI='PERC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER   2011
C
C               *****************************************************
C               **  TREAT THE SET BOOTSTRAP T-PERCENTILE STANDARD  **
C               **                DEVIATION <VALUE>                **
C               *****************************************************
C
      PBOOTS=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER   2011
C
C               *****************************************************
C               **  TREAT THE SET BOOTSTRAP SMOOTHING <ON/OFF>     **
C               **            SET BOOTSTRAP SMOOTHING STAND DEVI   **
C               **                <VALUE>                          **
C               *****************************************************
C
      IBOOSM='PERC'
      PBOOSM=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2011
C
C               *****************************************************
C               **  TREAT THE SET CONSENSUS MEAN PLOT SORT         **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      ICMPSO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2011
C
C               *****************************************************
C               **  TREAT THE SET CONSENSUS MEAN PLOT DATA         **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      ICMPDA='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2011
C
C               *****************************************************
C               **  TREAT THE SET CONSENSUS MEAN PLOT ERROR        **
C               **                 CONFIDENCE LIMITS/              **
C               **                 ONE STANDARD ERROR/             **
C               **                 TWO STANDARD ERROR              **
C               *****************************************************
C
      ICMPER='2SE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER    2016
C
C               *****************************************************
C               **  TREAT THE SET CONSENSUS MEAN PLOT OMIT LABS    **
C               **                <LIST OF LABS TO OMIT>           **
C               *****************************************************
C
      ICMPNL=0
      DO5010II=1,MAXOLB
        ICMPLL(II)=-1
 5010 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL       2017
C
C               *****************************************************
C               **  TREAT THE SET CONSENSUS MEAN PLOT OMIT METHOD  **
C               **                <ONE/TWO/THREE> <METHOD>         **
C               *****************************************************
C
      ICMPM1='NULL'
      ICMPM2='NULL'
      ICMPM3='NULL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2010
C
C               *****************************************************
C               **  TREAT THE SET MOVING DIRECTION                 **
C               **        <LEFT/CENTER/RIGHT>                      **
C               *****************************************************
C
      IMOVDI='CENT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER    2010
C
C               *****************************************************
C               **  TREAT THE SET MOVING END POINT                 **
C               **        <SKIP/PARTIAL/SYMMETRIC>                 **
C               *****************************************************
C
      IMOVEP='SKIP'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET MATRIX TO VARIABLE               **
C               **        <COLUMN/ROW>                             **
C               *****************************************************
C
      IMATVA='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET VARIABLE TO MATRIX               **
C               **        <COLUMN/ROW>                             **
C               *****************************************************
C
      IVARMA='COLU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET HOMOSCEDASTICITY PLOT LOCATION   **
C               **        <STAT>                                   **
C               *****************************************************
C
      IHOMLO='MEAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER    2010
C
C               *****************************************************
C               **  TREAT THE SET HOMOSCEDASTICITY PLOT SCALE      **
C               **        <STAT>                                   **
C               *****************************************************
C
      IHOMSC='SD  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER    2010
C
C               ******************************************************
C               **  TREAT THE SET HOMOSCEDASTICITY PLOT CIRCLE     **
C               **                TECHNIQUE <ON/OFF>               **
C               *****************************************************
C
      IHOMCT='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY    2011
C
C               *****************************************************
C               **  TREAT THE SET BEST FIT CRITERION               **
C               **                <AIC/PPCC/KS/AD/CHISQUARE>       **
C               *****************************************************
C
      IBFICR='AD'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY    2011
C
C               *****************************************************
C               **  TREAT THE SET BEST FIT METHOD                  **
C               **                <MAXI LIKE/PPCC/KS/AD/CHISQUARE> **
C               *****************************************************
C
      IBFIME='ML'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY    2013
C
C               ******************************************************
C               **  TREAT THE SET BEST FIT FONG <ON/OFF>            **
C               ******************************************************
C
      IBFIFO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY       2013
C
C               ******************************************************
C               **  TREAT THE SET BEST FIT FONG TYPE <PDF/CDF>      **
C               ******************************************************
C
      IBFITY='PDF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY       2013
C
C               ******************************************************
C               **  TREAT THE SET DISTRIBUTIONAL PERCENTILE         **
C               **                <LOWER/UPPER/TWOSIDE>             **
C               ******************************************************
C
      IDTYPR='TWOS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH      2013
C
C               ******************************************************
C               **  TREAT THE SET WEIBULL GAUGE LENGTH <ON/OFF>     **
C               ******************************************************
C
      IWEIGL='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ************************************************************
C               **  TREAT THE SET WEIBULL MAXIMUM LIKELIHOOD <ON/OFF>     **
C               ************************************************************
C
      IWEIML='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ************************************************************
C               **  TREAT THE SET WEIBULL MODIFIED MOMENTS   <ON/OFF>     **
C               ************************************************************
C
      IWEIMM='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ***************************************************
C               **  TREAT THE SET WEIBULL MOMENTS   <ON/OFF>     **
C               ***************************************************
C
      IWEIMO='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER  2014
C
C               ***************************************************
C               **  TREAT THE SET WEIBULL ELEMENTAL PERCENTILES  **
C               **                <ON/OFF>                       **
C               ***************************************************
C
      IWEIEP='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER  2014
C
C               ***************************************************
C               **  TREAT THE SET WEIBULL L MOMENTS <ON/OFF>     **
C               ***************************************************
C
      IWEILM='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER  2014
C
C               ******************************************************
C               **  TREAT THE SET GEV  MAXIMUM LIKELIHOOD <ON/OFF>  **
C               ******************************************************
C
      IGEVML='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER  2014
C
C               ******************************************************
C               **  TREAT THE SET AUTOMATIC VARIABLE BASE NAME      **
C               **                <VALUE>                           **
C               ******************************************************
C
      IAVABN='COL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER  2014
C
C               ******************************************************
C               **  TREAT THE SET AUTOMATIC VARIABLE NAME           **
C               **                <FILE/AUTOMATIC>                  **
C               ******************************************************
C
      IAVANM='AUTO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER  2014
C
C               ******************************************************
C               **  TREAT THE SET X11 CLIPBOARD                     **
C               **                <CUT BUFFER/SELECTION/PRIMARY>    **
C               ******************************************************
C
      IX11CB='CLIP'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER  2014
C
C               ***************************************************
C               **  TREAT THE SET CLIPBOARD SKIP    <ON/OFF>     **
C               ***************************************************
C
      ICLISK='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER  2014
C
C               ***************************************************
C               **  TREAT THE SET CLIPBOARD DELAY   <VALUE>      **
C               ***************************************************
C
      PCLIDE=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER  2014
C
C               ***************************************************
C               **  TREAT THE SET CLIPBOARD LOOP LINES  <VALUE>  **
C               ***************************************************
C
      ICLILL=10000
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ******************************************************
C               **  TREAT THE SET SKEWNESS DEFINITION               **
C               **                 FISHER PEARSON/                  **
C               **                 ADJUSTED FISHER PEARSON/OLD      **
C               ******************************************************
C
      ISKWDF='FIPE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ******************************************************
C               **  TREAT THE SET PERCENTILE DIRECTION              **
C               **                <LOWER/UPPER/TWO-SIDED>           **
C               ******************************************************
C
      IPERDI='TWOS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL      2013
C
C               ******************************************************
C               **  TREAT THE SET FLUCTUATION PLOT BAR DIRECTION    **
C               **                <VERTICAL/HORIZONTAL>             **
C               ******************************************************
C
      IFLUBD='VERT'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH      2013
C
C               ********************************************************
C               **  TREAT THE SET CUMULATIVE STATISTIC START <IVALUE> **
C               ********************************************************
C
      ICSTSV=1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY    2011
C
C               ******************************************************
C               **  TREAT THE SET LEVENE GROUP STATISTICS          **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      ILEVGS='ML'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY    2011
C
C               *****************************************************
C               **  TREAT THE SET KRUSKAL WALLIS GROUP STATISTICS  **
C               **                <ON/OFF>                         **
C               *****************************************************
C
      IKRUGS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL       2011
C
C               *****************************************************
C               **  TREAT THE SET T TEST VARIANCE                  **
C               **                <EQUAL/UNEQUAL/BOTH>             **
C               *****************************************************
C
      ITTEVA='BOTH'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST       2011
C
C               *****************************************************
C               **  TREAT THE SET POSTSCRIPT VIEWER <NAME>         **
C               **            SET PDF        VIEWER <NAME>         **
C               **            SET IMAGE      VIEWER <NAME>         **
C               **            SET BACKUP     VIEWER <NAME>         **
C               *****************************************************
C
C     NOTE: COMMENTS FOR LINUX/MacOS SYSTEMS
C
C           1. "open" FOR MacOS AND "xdg-open" FOR LINUX USE THE
C              FILE EXTENSION TO DETERMINE THE APPROPRIATE APPLICATION
C              TO USE.  HOWEVER, THE "PSVIEW" COMMAND IS OFTEN USED
C              WITH THE dppl1f.dat AND dppl2f.dat FILES WHICH DO
C              NOT HAVE THE APPROPRIATE FILE EXTENSIONS.
C
C           2. ALSO, THE ghostview APPLICATION IS LESS LIKELY
C              TO BE INSTALLED BY DEFAULT.  THE "okular" APPLICATION
C              IS MORE LIKELY TO BE AVAILABLE.
C
C           SO TO ALLOW xdg-open AND open TO BE USED AS THE DEFAULT
C           VIEWER, ALSO DEFINE A "BACKUP" VIEWER.  THIS WILL BE USED
C           WHEN THE REQUESTED FILE DOES NOT HAVE THE APPROPRIATE
C           FILE EXTENSION.  FOR LINUX, WE WILL USE THE "okular"
C           APPLICATION AS THIS IS INSTALLLED BY DEFAULT ON MANY
C           SYSTEMS AND CAN HANDLE A NUMBER OF IMAGE TYPES AS WELL
C           AS POSTSCRIPT AND PDF FILES.  FOR MacOS, USE
C           "/Applications/Preview.app"
C
      IF(IOPSY1.EQ.'UNIX' .OR. IOPSY1.EQ.'LINU')THEN
        IF(IOPSY2.EQ.'MAC ')THEN
          IPSTVW='open'
          NCPSVW=4
          IPDFVW='open'
          NCPDVW=4
          IIMAVW='open'
          NCIMVW=4
          IBCKVW='/Applications/Preview.app'
          NCBKVW=25
        ELSE
          IPSTVW='xdg-open'
          NCPSVW=8
          IPDFVW='xdg-open'
          NCPDVW=8
          IIMAVW='xdg-open'
          NCIMVW=8
          IBCKVW='okular'
          NCBKVW=6
        ENDIF
      ELSEIF(IOPSY1.EQ.'PC-D')THEN
C
C       2019/12: TAKE INITIAL PATH FROM SYSTEM ENVIRONMENT
C                VARIABLES.  THIS IS MORE ROBUST FOR NON-ENGLISH
C                PLATFORMS.
C
        CALL DPCONA(92,IBASLC)
        IF(WINBIT.EQ.'64')THEN
          IPSTVW(1:NCP86F)=P86FIL(1:NCP86F)
          IPDFVW(1:NCP86F)=P86FIL(1:NCP86F)
          IBCKVW(1:NCP86F)=P86FIL(1:NCP86F)
          NCPSVW=NCP86F
          NCPDVW=NCP86F
          NCBKVW=NCP86F
        ELSE
          IPSTVW(1:NCPROF)=PROFIL(1:NCPROF)
          IPDFVW(1:NCPROF)=PROFIL(1:NCPROF)
          IBCKVW(1:NCPROF)=PROFIL(1:NCPROF)
          NCPSVW=NCPROF
          NCPDVW=NCPROF
          NCBKVW=NCPROF
        ENDIF
C
        NCPSVW=NCPSVW+1
        IPSTVW(NCPSVW:NCPSVW)=IBASLC
        IPSTVW(NCPSVW+1:NCPSVW+8)='GHOSTGUM'
        NCPSVW=NCPSVW+8
        IPSTVW(NCPSVW:NCPSVW)=IBASLC
        IPSTVW(NCPSVW+1:NCPSVW+6)='GSVIEW'
        NCPSVW=NCPSVW+6
        NCPSVW=NCPSVW+1
        IPSTVW(NCPSVW:NCPSVW)=IBASLC
        IPSTVW(NCPSVW+1:NCPSVW+12)='GSVIEW32.EXE'
        NCPSVW=NCPSVW+12
C
        NCPDVW=NCPDVW+1
        IPDFVW(NCPDVW:NCPDVW)=IBASLC
        IPDFVW(NCPDVW+1:NCPDVW+5)='ADOBE'
        NCPDVW=NCPDVW+5
        NCPDVW=NCPDVW+1
        IPDFVW(NCPDVW:NCPDVW)=IBASLC
        IPDFVW(NCPDVW+1:NCPDVW+17)='Acrobat Reader DC'
        NCPDVW=NCPDVW+17
        NCPDVW=NCPDVW+1
        IPDFVW(NCPDVW:NCPDVW)=IBASLC
        IPDFVW(NCPDVW+1:NCPDVW+6)='Reader'
        NCPDVW=NCPDVW+6
        NCPDVW=NCPDVW+1
        IPDFVW(NCPDVW:NCPDVW)=IBASLC
        IPDFVW(NCPDVW+1:NCPDVW+12)='AcroRd32.exe'
        NCPDVW=NCPDVW+12
C
        NCBKVW=NCBKVW+1
        IBCKVW(NCBKVW:NCBKVW)=IBASLC
        IBCKVW(NCBKVW+1:NCBKVW+8)='GHOSTGUM'
        NCBKVW=NCBKVW+8
        IBCKVW(NCBKVW:NCBKVW)=IBASLC
        IBCKVW(NCBKVW+1:NCBKVW+6)='GSVIEW'
        NCBKVW=NCBKVW+6
        NCBKVW=NCBKVW+1
        IBCKVW(NCBKVW:NCBKVW)=IBASLC
        IBCKVW(NCBKVW+1:NCBKVW+12)='GSVIEW32.EXE'
        NCBKVW=NCBKVW+12
C
        IIMAVW=' '
        NCIMVW=0
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER       2019
C
C               *****************************************************
C               **  TREAT THE SET LIST VIEWER   <NAME>             **
C               **  TREAT THE SET LIST LAUNCHER <NAME>             **
C               **  TREAT THE SET EXCEL VIEWER  <NAME>             **
C               **  TREAT THE SET WORD  VIEWER  <NAME>             **
C               **  TREAT THE SET POWER POINT  VIEWER  <NAME>      **
C               *****************************************************
C
C     FOR WINDOWS, YOU CAN SIMPLY DO A
C
C         SYSTEM FILE.
C
C     AND THE FILE ASSOCIATIONS WILL INVOKE TO PROPER APPLICATION.
C     FOR LINUX, YOU NEED TO SPECIFY AN EXPLICIT APPLICATION TO VIEW
C     AN EXCEL OR WORD FILE.
C
C     ON MANY LINUX/UNIX INSTALLATIONS, YOU CAN USE THE
C     "xdg-open" WHICH WILL USE FILE ASSOCIATIONS ON THE
C     SYSTEM TO AUTOMATICALLY DETERMINE THE USER'S PREFERRED
C     APPLICATION.
C
C     ON MacOS, "open" HAS SIMILAR FUNCTIONALITY AS "xdg-open"
C     ON LINUX.
C
      IF(IOPSY1.EQ.'UNIX' .OR. IOPSY1.EQ.'LINU')THEN
        ILSTVW='vi'
        NCLSVW=2
        ILSTLA='gnome-terminal -e'
        NCLSLA=17
CCCCC   IEXCVW='libreoffice --calc'
CCCCC   NCEXCW=18
CCCCC   IWORVW='libreoffice --writer'
CCCCC   NCWOVW=20
        IF(IOPSY2.EQ.'MAC ')THEN
          IEXCVW='open'
          NCEXVW=4
          IWORVW='open'
          NCWOVW=4
          IPPTVW='open'
          NCPPVW=4
        ELSE
          IEXCVW='xdg-open'
          NCEXVW=8
          IWORVW='xdg-open'
          NCWOVW=8
          IPPTVW='xdg-open'
          NCPPVW=8
        ENDIF
      ELSE
C
        ILSTVW='notepad'
        NCLSVW=7
        ILSTLA=' '
        NCLSLA=0
        IEXCVW=' '
        NCEXCW=0
        IWORVW=' '
        NCWOVW=0
        IPPTVW=' '
        NCPPVW=0
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER       2019
C
C               *****************************************************
C               **  TREAT THE SET LIST NEW WINDOW <ON/OFF>         **
C               **  TREAT THE SET HELP NEW WINDOW <ON/OFF>         **
C               *****************************************************
C
      IHLPNW='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER    2011
C
C               *****************************************************
C               **  TREAT THE SET CHARACTER AUTOMATIC OFFSET       **
C               **                <IVALUE>                         **
C               *****************************************************
C
      ICHAOF=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE    2012
C
C               *****************************************************
C               **  TREAT THE SET CHARACTER AUTOMATIC DYNAMIC      **
C               **                <OFF/ON>                         **
C               *****************************************************
C
      ICHADY='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE    2012
C
C               *****************************************************
C               **  TREAT THE SET CHARACTER REPEAT OFFSET          **
C               **                <VALUE>                          **
C               *****************************************************
C
      ICHARO=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2012
C
C               *********************************************
C               **  TREAT THE SET KRUSKAL WALLIS MULTIPLE  **
C               **                COMPARISON <ON/OFF>      **
C               *********************************************
C
      IKRUMC='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2012
C
C               *********************************************
C               **  TREAT THE SET ISO PLOT                 **
C               **                <LAB AVERAGES/RESPONSE>  **
C               *********************************************
C
      IISOLA='LAVE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2012
C
C               *********************************************
C               **  TREAT THE SET ISO PLOT STATISTIC       **
C               **                <MEAN/H15/MEDIAN>        **
C               *********************************************
C
      IISOME='MEAN'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2012
C
C               ***********************************************
C               **  TREAT THE SET RLP PLOT LABEL             **
C               **                <NONE/ALL/WARNING/ACTION>  **
C               ***********************************************
C
      IRLPLA='ALL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2012
C
C               ***********************************************
C               **  TREAT THE SET BLOCK PLOT FILTER <ON/OFF> **
C               ***********************************************
C
      IBPLFI='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2012
C
C               ***********************************************
C               **  TREAT THE SET BLOCK PLOT LABEL <ON/OFF>  **
C               ***********************************************
C
      IBPLLA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2012
C
C               ****************************************************
C               **  TREAT THE SET BLOCK PLOT BACKGROUND <ON/OFF>  **
C               ****************************************************
C
      IBPLBG='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2012
C
C               **************************************************
C               **  TREAT THE SET CAPTURE FLUSH ERASE <ON/OFF>  **
C               **************************************************
C
      ICAPFE='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2012
C
C               ***********************************************
C               **  TREAT THE SET BLOCK PLOT WIDTH <VALUE>   **
C               ***********************************************
C
      PBPLWI=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2016
C
C               ***********************************************
C               **  TREAT THE SET BLOCK PLOT JITTER <VALUE>  **
C               ***********************************************
C
      PBPLJI=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ***********************************************
C               **  TREAT THE SET POINCARE PLOT LAG <VALUE>  **
C               ***********************************************
C
      PPPLLA=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2017
C
C               ******************************************************
C               **  TREAT THE SET NORMAL KERNEL DENSITY MIXTURE     **
C               **                PLOT EXPANSION FACTOR <VALUE>     **
C               ******************************************************
C
      PNKDEF=1.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2019
C
C               ******************************************************
C               **  TREAT THE SET CARRIAGE RETURN GAP <VALUE>       **
C               ******************************************************
C
      PWRTGA=0.1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               *****************************************************
C               **  TREAT THE SET GRUBB TEST STANDARD DEVIATION   **
C               **                <VALUE>                         **
C               **  TREAT THE SET GRUBB TEST DEGREES OF FREEDOM   **
C               **                <VALUE>                         **
C               **  TREAT THE SET GRUBB TEST CRITICAL VALUE       **
C               **                <FORMULA/ASTM/SIMULATION>       **
C               ****************************************************
C
      PGRUSD=CPUMIN
      PGRUDF=CPUMAX
      IGRUTA='FORM'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2019
C
C               ******************************************************
C               **  TREAT THE SET AUXILLARY FILES DECIMAL POINT     **
C               **                <VALUE>                           **
C               ******************************************************
C
      IAUXDP=7
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2019
C
C               ******************************************************
C               **  TREAT THE SET HEAD LINES <VALUE>                **
C               **  TREAT THE SET TAIL LINES <VALUE>                **
C               ******************************************************
C
      IHEALI=10
      ITAILI=10
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET BROWSER HEIGHT <VALUE>            **
C               **  TREAT THE SET BROWSER WIDTH  <VALUE>            **
C               ******************************************************
C
      IBROHE=0
      IBROWI=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2019
C
C               ******************************************************
C               **  TREAT THE SET RANLUX LEVEL <1/2/3/4>            **
C               ******************************************************
C
      IRLXLE=3
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2012
C
C               ***********************************************
C               **  TREAT THE SET TOLERANCE LIMITS DEGREES   **
C               **                OF FREEDOM <VALUE>         **
C               ***********************************************
C
      PTOLDF=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2012
C
C               ***********************************************
C               **  TREAT THE SET FIELD <numb> TYPE          **
C               **                <NUMERIC/CHARACTER>        **
C               ***********************************************
C
      DO8111I=1,250
        IFIETY(I)=0
 8111 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2013
C
C               **************************************************
C               **  TREAT THE SET KENDALL TAU CRITICAL VALUE    **
C               **                <TABLE/NORMAL APPROXIMATION>  **
C               **************************************************
C
      IKTATA='TABL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2013
C
C               *****************************************************
C               **  TREAT THE SET RANK CORRELATION CRITICAL VALUE  **
C               **                <TABLE/NORMAL APPROXIMATION>     **
C               *****************************************************
C
      IRCRTA='TABL'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2013
C
C               ***********************************************
C               **  TREAT THE SET CONSENSUS MEAN TYPE B      **
C               **                <VALUE>                    **
C               ***********************************************
C
      PCMTYB=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2013
C
C               **************************************************
C               **  TREAT THE SET CONSENSUS MEAN TYPE B METHOD  **
C               **                <ADD/BOOTSTRAP>               **
C               **************************************************
C
      ICMTYB='ADD'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2013
C
C               **************************************************
C               **  TREAT THE SET CONSENSUS MEAN TABLE ONE      **
C               **                                     TWO      **
C               **                                     THREE    **
C               **                                     FOUR     **
C               **                               DETAILED TABLE **
C               **                <ON/OFF>                      **
C               **************************************************
C
      ICMET1='ON'
      ICMET2='ON'
      ICMET3='ON'
      ICMET4='ON'
      ICMET5='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH 2014
C
C               **************************************************
C               **  TREAT THE SET CONSENSUS MEAN TYPE B         **
C               **                <VARIABLE NAME>               **
C               **************************************************
C
      ICMETB='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE  2013
C
C               ***********************************************
C               **  TREAT THE SET BEST FIT LOWER LIMIT       **
C               **                         UPPER LIMIT       **
C               **                <VALUE>                    **
C               ***********************************************
C
      PBFILL=CPUMIN
      PBFIUL=CPUMIN
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY  2013
C
C               ***********************************************
C               **  TREAT THE SET BEST FIT FONG XVALUE       **
C               **                <VALUE>                    **
C               ***********************************************
C
      PBFIXV=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST     2013
C
C               ******************************************************
C               **  TREAT THE SET RGB MAXIMUM VALUE <VALUE>         **
C               ******************************************************
C
      IRGBMX=255
C
CCCCC THE FOLLOWING SECTION WAS ADDED    AUGUST     2013
C
C               *************************************************************
C               **  TREAT THE SET MCCOOL WEIBULL LOCATION TEST R1 <VALUE>  **
C               *************************************************************
C
      IMCCR1=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2013
C
C               *************************************************************
C               **  TREAT THE SET GHOSTSCRIPT VERSION <32/64>              **
C               *************************************************************
C
      IGSTVR='64'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH        2014
C
C               *************************************************************
C               **  TREAT THE SET BINOMIAL METHOD                          **
C                                 <WILSON/ADJUSTED WALD/JEFFREYS/EXACT>    **
C               *************************************************************
C
      IBINME='WILS'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER     2017
C
C               ******************************************************
C               **  TREAT THE SET DIFFERENCE OF BINOMIAL METHOD     **
C                                 <ADJUSTED/WALD>                   **
C               ******************************************************
C
      IBI2ME='ADJU'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2017
C
C               ******************************************************
C               **  TREAT THE SET BONETT STANDARD DEVIATION         **
C               **                CONFIDENCE INTERVAL <ON/OFF>      **
C               ******************************************************
C
      IBONSD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2017
C
C               ******************************************************
C               **  TREAT THE SET BONETT STANDARD DEVIATION         **
C               **                CONFIDENCE INTERVAL ADJUSTED      **
C               **                <ON/OFF>                          **
C               ******************************************************
C
      IBONAD='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY     2018
C
C               ******************************************************
C               **  TREAT THE SET DEX ORDERED PLOT IDENTIFICATION   **
C               **                <ON/OFF>                          **
C               ******************************************************
C
      IDPAID='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2019
C
C               ******************************************************
C               **  TREAT THE SET SYSTEM PERSIST <ON/OFF>           **
C               ******************************************************
C
      ISYSPE='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH     2019
C
C               ******************************************************
C               **  TREAT THE SET SYSTEM HIDDEN <ON/OFF>            **
C               ******************************************************
C
      ISYSHI='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER     2019
C
C               ******************************************************
C               **  TREAT THE SET HOME PATH     <ON/OFF>            **
C               ******************************************************
C
      IHOMPA='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY     2020
C
C               ******************************************************
C               **  TREAT THE SET IPLOT JITTER  <ON/OFF>            **
C               ******************************************************
C
      IIPLJI='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY     2020
C
C               ******************************************************
C               **  TREAT THE SET WRITE CSV     <ON/OFF>            **
C               ******************************************************
C
      ICSVWR='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY     2020
C
C               ******************************************************
C               **  TREAT THE SET EXCEL SHEET   <NAME>              **
C               **  TREAT THE SET EXCEL NUMBER OF ROWS <VALUE>      **
C               **  TREAT THE SET EXCEL START ROW <VALUE>           **
C               **  TREAT THE SET EXCEL STOP  ROW    <VALUE>        **
C               **  TREAT THE SET EXCEL START COLUMN <VALUE>        **
C               **  TREAT THE SET EXCEL STOP  COLUMN <VALUE>        **
C               ******************************************************
C
      IEXCSH='Sheet1'
      IEXCCL='NULL'
      IEXCR1=-1
      IEXCR2=-1
      IEXCC1=-1
      IEXCC2=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY     2020
C
C               ******************************************************
C               **  TREAT THE SET INSERT OVERWRITE <ON/OFF>         **
C               ******************************************************
C
      IINSOW='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL     2020
C
C               ******************************************************
C               **  TREAT THE SET BEST FIT <DIST>  <ON/OFF>         **
C               ******************************************************
C
      IBFINO='ON'
      IBFIUN='ON'
      IBFI2B='ON'
      IBFI4B='ON'
      IBFIPW='ON'
      IBFIRP='ON'
      IBFIAR='ON'
      IBFITR='ON'
      IBFITO='ON'
      IBFIRG='ON'
      IBFITS='ON'
      IBFINX='OFF'
      IBFGVX='ON'
      IBFGVN='ON'
      IBFGPX='ON'
      IBFGPN='ON'
      IBFIPA='ON'
      IBFFRX='ON'
      IBFFRN='ON'
      IBFGUX='ON'
      IBFGUN='ON'
      IBFILO='ON'
      IBFILL='ON'
      IBFIHS='ON'
      IBFIDX='ON'
      IBFIAX='ON'
      IBFIDW='ON'
      IBFIDG='ON'
      IBFITL='ON'
      IBFIGT='ON'
      IBFIER='ON'
      IBFIGH='ON'
      IBFIG ='ON'
      IBFISL='ON'
      IBFICA='ON'
      IBFICO='ON'
      IBFIFN='ON'
      IBFIHN='ON'
      IBFIHL='ON'
      IBFIBR='ON'
      IBFIAN='ON'
      IBFI2E='ON'
      IBFI1E='ON'
      IBFIRA='ON'
      IBFIMX='ON'
      IBF2WN='ON'
      IBF2WX='ON'
      IBF3WX='ON'
      IBF3WN='ON'
      IBFIIW='OFF'
      IBFI2L='ON'
      IBFI3L='ON'
      IBFIGA='ON'
      IBFILG='ON'
      IBFIIG='ON'
      IBFIFL='ON'
      IBFB10='ON'
      IBFIWA='ON'
      IBF2IG='ON'
      IBF3IG='ON'
      IBFILX='ON'
      IBFILD='ON'
      IBFIGX='ON'
      IBF2WN='ON'
      IBF2WX='ON'
      IBF1HN='ON'
      IBF2HN='ON'
      IBF1HL='ON'
      IBF2HL='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY     2018
C
C               ******************************************************
C               **  TREAT THE SET DEX ORDERED PLOT UNCERTAINTY      **
C               **                <ON/OFF>                          **
C               ******************************************************
C
      IDPAUN='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JANUARY     2018
C
C               ******************************************************
C               **  TREAT THE SET DEX PARETO PLOT DIRECTION         **
C               **                <ASCENDING/DESCENDING>            **
C               ******************************************************
C
      IDPADI='DESC'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY     2019
C
C               ******************************************************
C               **  TREAT THE SET DEX STATISTIC PLOT INTERACTION    **
C               **                <NONE/2/3>
C               ******************************************************
C
      IDEXIN='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH        2014
C
C               *********************************************************
C               **  TREAT THE SET WEIBULL MAXIMUM LIKELIHOOD METHOD     *
C               **                <COHEN/PROFILE LIKELIHOOD>            *
C               *********************************************************
C
      I3WEME='COHE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MARCH        2014
C
C               *********************************************************
C               **  TREAT THE SET WEIBULL MAXIMUM LIKELIHOOD MINIMUM   **
C               **                <VALUE>                              **
C               *********************************************************
C
      P3WEMI=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET LOGNORMAL MAXIMUM LIKELIHOOD METHOD  **
C               **                <COHEN/PROFILE LIKELIHOOD>           **
C               *********************************************************
C
      I3LNME='COHE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET LOGNORMAL MAXIMUM LIKELIHOOD MINIMUM **
C               **                <VALUE>                              **
C               *********************************************************
C
      P3LNMI=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET GAMMA     MAXIMUM LIKELIHOOD METHOD  **
C               **                <COHEN/PROFILE LIKELIHOOD>           **
C               *********************************************************
C
      I3GAME='COHE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET INVERSE GAUSSIAN DEFINITION          **
C               **                <TWEEDIE/CHAN>                       **
C               *********************************************************
C
      IGAUDF='TWEE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET INVERSE GAUSSIAN CONFIDENCE LIMITS   **
C               **                METHOD <MLE/MODIFIED MOMENTS>        **
C               *********************************************************
C
      IGAUME='MLE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL        2014
C
C               *********************************************************
C               **  TREAT THE SET GAMMA     MAXIMUM LIKELIHOOD MINIMUM **
C               **                <VALUE>                              **
C               *********************************************************
C
      P3GAMI=0.0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER  2014
C
C               **************************************************
C               **  TREAT THE SET SEARCH  DIRECTORY <PATH>       *
C               **  TREAT THE SET SEARCH2 DIRECTORY <PATH>       *
C               **  TREAT THE SET SEARCH3 DIRECTORY <PATH>       *
C               **************************************************
C
      ISEADI='NULL'
      ISEAD2='NULL'
      ISEAD3='NULL'
      ISEAD4='NULL'
      ISEAD5='NULL'
      ISEAD6='NULL'
      NCSEDI=-1
      NCSED2=-1
      NCSED3=-1
      NCSED4=-1
      NCSED5=-1
      NCSED6=-1
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER  2015
C
C               ***********************************************************
C               **  TREAT THE SET STANDARD INPUT <FILE>                   *
C               **            SET DELAY STANDARD INPUT <VALUE>            *
C               **            SET MAXIMUM COUNTER STANDARD INPUT <VALUE>  *
C               ***********************************************************
C
      ISTDIN='NULL'
      NCSTIN=-1
      PSTDSL=2.0
      ISTDCN=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2016
C
C               ********************************************************
C               **  TREAT THE SET MACRO QUOTES STRIP <ON/OFF>          *
C               ********************************************************
C
      IQUOST='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               ********************************************************
C               **  TREAT THE SET STATUS DISTINCT    <ON/OFF>          *
C               ********************************************************
C
      ISTADS='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               ********************************************************
C               **  TREAT THE SET CHECK NAME OUTPUT <DEFAULT/FILLIBEN> *
C               ********************************************************
C
      ICHKNA='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2018
C
C               **********************************************************
C               **  TREAT THE SET CHECK LENGTH OUTPUT <DEFAULT/FILLIBEN> *
C               **********************************************************
C
      ICHKLE='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               **********************************************************
C               **  TREAT THE SET WEB SEARCH DATAPLOT <ON/OFF>           *
C               **********************************************************
C
      IWBSDP='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2018
C
C               **********************************************************
C               **  TREAT THE SET COMMAND LINE EXECUTE WAIT <ON/OFF>     *
C               **********************************************************
C
      ICLEWT='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *******************************************************
C               **  TREAT THE SET HISTOGRAM MAXIMUM CLASSES <VALUE>  **
C               *******************************************************
C
      IHSTMC=10000
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *******************************************************
C               **  TREAT THE SET STREAM READ SIZE          <VALUE>  **
C               *******************************************************
C
      ISRESI=100
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2016
C
C               **************************************************
C               **  TREAT THE SET STREAM READ GROUP VARIABLE    **
C               **                <VARIABLE NAME>               **
C               **************************************************
C
      ISREVN='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JULY 2016
C
C               ********************************************************
C               **  TREAT THE SET STREAM READ RESPONSE VARIABLE ONE   **
C               **            SET STREAM READ RESPONSE VARIABLE TWO   **
C               **            SET STREAM READ RESPONSE VARIABLE THREE **
C               **                <VARIABLE NAME>                     **
C               ********************************************************
C
      ISRER1='NONE'
      ISRER2='NONE'
      ISRER3='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               ********************************************************
C               **  TREAT THE SET HISTOGRAM OUTLIERS POINTS <ON/OFF>  **
C               ********************************************************
C
      IHSTOP='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               ********************************************************
C               **  TREAT THE SET BOX PLOT EXTREME PERCENTILES <ON/OFF>*
C               ********************************************************
C
      IBXPDI='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *******************************************************
C               **  TREAT THE SET QUANTILE QUANTILE PLOT NUMBER OF   **
C               **                PERCENTILES <VALUE>                **
C               *******************************************************
C
      IQQNPR=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *******************************************************
C               **  TREAT THE SET QUANTILE QUANTILE PLOT BOOTSTRAP   **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      IQQBOO='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2016
C
C               *******************************************************
C               **  TREAT THE SET TWO SAMPLE TESTS NUMBER OF         **
C               **                PERCENTILES <VALUE>                **
C               *******************************************************
C
      I2SNPR=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    FEBRUARY 2015
C
C               *******************************************************
C               **  TREAT THE SET E691 TEST RESULTS  TABLE <ON/OFF>  **
C               **  TREAT THE SET E691 H CONSISTENCY TABLE <ON/OFF>  **
C               **  TREAT THE SET E691 K CONSISTENCY TABLE <ON/OFF>  **
C               **  TREAT THE SET E691 DATA SUMMARY  TABLE <ON/OFF>  **
C               *******************************************************
C
      I691DS='ON'
      I691TR='ON'
      I691HC='ON'
      I691KC='ON'
      I691PS='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2015
C
C               *****************************************************
C               **  TREAT THE SET E691 MATERIAL ID GROUP LABEL     **
C               **  <NONE/DEFUALT/GROUP LABEL NAME>                **
C               *****************************************************
C
      I691GL='NONE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2015
C
C               *******************************************************
C               **  TREAT THE SET CNPK DEFINITION <AIRFORCE/PEARN>   **
C               *******************************************************
C
      ICNPKD='PEAR'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    APRIL 2015
C
C               *******************************************************
C               **  TREAT THE SET STATISTIC PLOT REFERENCE LINE      **
C               **                <OVERALL/AVERAGE/MEDIAN>           **
C               *******************************************************
C
      ISPLRL='OVER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT TYPE            **
C               **                <DEFAULT/STACKED>                  **
C               *******************************************************
C
      IHKCPT='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT                 **
C               **                 LABORATORIES WITHIN MATERIALS/    **
C               **                 MATERIALS WITHIN LABORATORIES     **
C               *******************************************************
C
      IHKCLM='LABO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT GAP <VALUE>     **
C               *******************************************************
C
      IHKCGP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT MATERIAL FIRST  **
C               **                <VALUE>                            **
C               *******************************************************
C
      IHKCM1=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT MATERIAL LAST   **
C               **                <VALUE>                            **
C               *******************************************************
C
      IHKCM2=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT LABORATORY FIRST**
C               **                <VALUE>                            **
C               *******************************************************
C
      IHKCL1=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET H CONSISTENCY PLOT LABORATORY LAST **
C               **                <VALUE>                            **
C               *******************************************************
C
      IHKCL2=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    MAY 2015
C
C               *******************************************************
C               **  TREAT THE SET MOVING STATISTIC PLOT GROUPS       **
C               **                <DEFAULT/STACKED>                  **
C               *******************************************************
C
      IMOVGR='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT Y AXIS                **
C               **                <RAW/DEVIATION>                    **
C               *******************************************************
C
      ITWOYA='RAW '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT FIT TABLE             **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      ITWOFI='ON  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT AVERAGES TABLE        **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      ITWOAV='ON  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT ANOVA    TABLE        **
C               **                <ON/OFF>                           **
C               *******************************************************
C
      ITWOAN='ON  '
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT FACTOR DECIMAL        **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWODE=-99
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT ANOVA TABLE DECIMAL   **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWOAD=-99
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO WAY PLOT FACTOR LABEL          **
C               **                <CODED/VALUE>                      **
C               *******************************************************
C
      ITWOLA='CODE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT TYPE               **
C               **                <DEFAULT/STACKED>                  **
C               *******************************************************
C
      ITWFPT='DEFA'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT                    **
C               **                 LABORATORIES WITHIN MATERIALS/    **
C               **                 MATERIALS WITHIN LABORATORIES     **
C               *******************************************************
C
      ITWFLM='LABO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT GAP <VALUE>        **
C               *******************************************************
C
      ITWFGP=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT MATERIAL FIRST     **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWFM1=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT MATERIAL LAST      **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWFM2=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT LABORATORY FIRST   **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWFL1=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    JUNE 2015
C
C               *******************************************************
C               **  TREAT THE SET TWO FACTOR PLOT LABORATORY LAST    **
C               **                <VALUE>                            **
C               *******************************************************
C
      ITWFL2=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET OPTIMIZATION <MINIMUM/MAXIMUM>     **
C               *******************************************************
C
      IOPTMM='MINI'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2015
C
C               *******************************************************
C               **  TREAT THE SET JSCORE REPLICATION                 **
C               **                <AVERAGE/EXTREME/INDIVIDUAL>       **
C               *******************************************************
C
      IJSREP='AVER'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    OCTOBER 2015
C
C               *******************************************************
C               **  TREAT THE SET LOOP SUBSTITUTION                  **
C               **                <IMMEDIATE/DEFERRED>               **
C               *******************************************************
C
      ILOOSU='DEFE'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET PERCENTILE DIGITS <VALUE>          **
C               *******************************************************
C
      IPCIDI=3
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET SEARCH ENGINE                      **
C               **                <GOOGLE/BING/DUCK>                 **
C               *******************************************************
C
      IWEBSE='GOOG'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    NOVEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET DEVICE 3                           **
C               **                <AUTOMATIC/USER>                   **
C               *******************************************************
C
      IDEVO3='AUTO'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET DEVICE 2 SPLIT <ON/OFF>            **
C               *******************************************************
C
      IDV2SP='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET DEVICE 3 NAME COUNTER <ON/OFF>     **
C               *******************************************************
C
      IDV3NC='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET FRAME LIMITS OFFSET <ON/OFF>       **
C               *******************************************************
C
      IFRALI='ON'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET CAPTURE SPLIT <ON/OFF>             **
C               *******************************************************
C
      ICAPSP='OFF'
      ICAPCN=0
C
CCCCC THE FOLLOWING SECTION WAS ADDED    DECEMBER 2015
C
C               *******************************************************
C               **  TREAT THE SET CAPTURE CUMULATIVE <ON/OFF>        **
C               *******************************************************
C
      ICAPCU='OFF'
C
CCCCC THE FOLLOWING SECTION WAS ADDED    SEPTEMBER 2016
C
C               *******************************************************
C               **  TREAT THE SET NO RESET NAMES                     **
C               *******************************************************
C
      NUMNRE=0
      DO1010II=1,MAXRES
        IRESN1='    '
        IRESN2='    '
 1010 CONTINUE
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'ON')THEN
        WRITE(ICOUT,9990)
 9990   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9995)
 9995   FORMAT('***** AT THE END       OF INITSU--')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE INIT3D(IBUGIN)
C
C     PURPOSE--THIS IS SUBROUTING INIT3D.
C              (THE   3D    AT THE END OF    INIT3D   STANDS FOR   3-DIMENSION)
C              THIS SUBROUTINE INITIALIZES 3-D VARIABLES AND PARAMETERS
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
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 IBUGIN
C
CCCCC CHARACTER*4 IDEFGC
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCO3D.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGIN.EQ.'OFF')GOTO99
      WRITE(ICOUT,90)
   90 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,95)
   95 FORMAT('***** AT THE BEGINNING OF INIT3D--')
      CALL DPWRST('XXX','BUG ')
   99 CONTINUE
C
C               **************************************************
C               **  SET THE 3-D GENERAL SETTINGS                **
C               **************************************************
C
      IVISSW='ON'
      I3DPRO='PERS'
C
      AEYEXC=CPUMIN
      AEYEYC=CPUMIN
      AEYEZC=CPUMIN
C
      AORIXC=CPUMIN
      AORIYC=CPUMIN
      AORIZC=CPUMIN
C
C               **************************************************
C               **  SET THE 3-D PEDESTAL ATTRIBUTES             **
C               **************************************************
C
      IDEPGC='WHIT'
      IDEPGP='SOLI'
      IDEPGR='OFF'
      IDEPCO='BLUE'
C
      IPEDGC=IDEPGC
      IPEDGP=IDEPGP
      IPEDGR=IDEPGR
      IPEDCO=IDEPCO
      IPEDSW='OFF'
C
      ADEPBA=CPUMIN
      ADEPSZ=CPUMIN
C
      APEDBA=ADEPBA
      APEDSZ=ADEPSZ
C
C               **************************************************
C               **  SET THE 3-D BASEPLANE ATTRIBUTES            **
C               **************************************************
C
      IDBSGC='WHIT'
      IDBSGP='SOLI'
      IDBSGR='OFF'
      IDBSCO='BLUE'
C
      IBSPGC=IDBSGC
      IBSPGP=IDBSGP
      IBSPGR=IDBSGR
      IBSPCO=IDBSCO
      IBSPSW='OFF'
C
C               **************************************************
C               **  SET THE 3-D BACKPLANE ATTRIBUTES            **
C               **************************************************
C
      IDBKGC='WHIT'
      IDBKGP='SOLI'
      IDBKGR='OFF'
      IDBKCO='BLUE'
C
      IBKPGC=IDBKGC
      IBKPGP=IDBKGP
      IBKPGR=IDBKGR
      IBKPCO=IDBKCO
      IBKPSW='OFF'
C
C               **************************************************
C               **  SET THE 3-D SIDEFACE ATTRIBUTES             **
C               **************************************************
C
      IDSDGC='WHIT'
      IDSDGP='SOLI'
      IDSDGR='OFF'
      IDSDCO='BLUE'
C
      ISDFGC=IDSDGC
      ISDFGP=IDSDGP
      ISDFGR=IDSDGR
      ISDFCO=IDSDCO
      ISDFSW='OFF'
C
C               **************************************************
C               **  SET THE RAW 3-D DATA                        **
C               **************************************************
C
      X3DMIN=CPUMIN
      Y3DMIN=CPUMIN
      Z3DMIN=CPUMIN
C
      X3DMAX=CPUMIN
      Y3DMAX=CPUMIN
      Z3DMAX=CPUMIN
C
      X3DMID=CPUMIN
      Y3DMID=CPUMIN
      Z3DMID=CPUMIN
C
      X3DRAN=CPUMIN
      Y3DRAN=CPUMIN
      Z3DRAN=CPUMIN
C
      X3DEYE=CPUMIN
      Y3DEYE=CPUMIN
      Z3DEYE=CPUMIN
C
      X3DORI=CPUMIN
      Y3DORI=CPUMIN
      Z3DORI=CPUMIN
C
      D3DCXX=CPUMIN
      D3DCXY=CPUMIN
      D3DCXZ=CPUMIN
      D3DCYX=CPUMIN
      D3DCYY=CPUMIN
      D3DCYZ=CPUMIN
      D3DCZX=CPUMIN
      D3DCZY=CPUMIN
      D3DCZZ=CPUMIN
C
C               *******************************
C               **  EXIT AND RETURN TO MAIN  **
C               *******************************
C
      IF(IBUGIN.EQ.'OFF')GOTO9999
      WRITE(ICOUT,9990)
 9990 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9995)
 9995 FORMAT('***** AT THE END       OF INIT3D--')
      CALL DPWRST('XXX','BUG ')
 9999 CONTINUE
C
      RETURN
      END
      FUNCTION INITS (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      SINGLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     single precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  INITS
      REAL OS(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C***FIRST EXECUTABLE STATEMENT  INITS
      IF (NOS .LT. 1) THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        INITS = 0
        RETURN
      ENDIF
   11 FORMAT('***** ERROR FROM INITS.  THE NUMBER OF ')
   12 FORMAT('      COEFFICIENTS IS LESS THAN 1.      *****')
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(OS(I))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) THEN
      WRITE(ICOUT,21)
 21   FORMAT('***** ERROR FROM INITS.  CHEBYSHEV SERIES TOO ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,22)
 22   FORMAT('      SHORT FOR SPECIFIED ACCURACY.             *****')
      CALL DPWRST('XXX','BUG ')
      ENDIF
      INITS = I
C
      RETURN
      END
      SUBROUTINE INOUT(XA,YA,X,Y,NP,IO)
C
C     PURPOSE--XX
C
C     WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI).
C                 AS PART OF NOAA'S CONCX V.3   MARCH 1988.
C     ORIGINAL VERSION (IN DATAPLOT)--AUGUST    1988.
C     UPDATED         --JANUARY   1989.  MORE CHANGES TO STANDARD FORTRAN 77--
C                                        CHANGED DO WHILE/END DO
C                                        AND ATAN2D TO ATAN2
C                                        (ATAN2D IS A VAX DOUB. PREC. ATAN2)
C                                        (ALAN HECKERT).
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----START POINT-----------------------------------------------------
C
      AS=0.
      XX=X(1)-XA
      YY=Y(1)-YA
CCCCC A0=ATAN2D(YY,XX)
      A0=ATAN2(YY,XX)
      DO 10 N=2,NP+1
        M=MOD(N-1,NP)+1
        XX=X(M)-XA
        YY=Y(M)-YA
CCCCC   A=ATAN2D(YY,XX)
        A=ATAN2(YY,XX)
        DA=A-A0
        IF (DA.LT.-180.) DA=DA+360.
        IF (DA.GT.180.)  DA=DA-360.
        AS=AS+DA
        A0=A
 10   CONTINUE
      IF (ABS(AS).LT.180.) THEN
        IO=0
      ELSE
        IO=1
      END IF
      RETURN
      END
      SUBROUTINE INSERT(Y1,N1,Y2,N2,NLOC,IWRITE,YOUT,NOUT,MAXNXT,
     1                  IINSOW,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE INSERTS THE CONTENTS OF Y2 INTO
C              Y1 STARTING AT ROW NLOC.
C
C     INPUT  ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y1.
C                     --Y2     = THE SINGLE PRECISION VECTOR OF
C                                OBSERVATIONS TO BE INSERTED INTO Y1.
C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y2.
C                     --NLOC   = THE INTEGER NUMBER THAT SPECIFIES THE
C                                STARTING ROW IN Y1.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF THE
C                                MERGED VALUES.
C                     --NOUT   = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE OUTPUT VECTOR YOUT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE MERGED VALUES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--ISO 13528, FIRST EDITION, STATISTICAL METHODS FOR USE
C                IN PROFICIENCY TESTING BY INTERLABORATORY COMPARISONS,
C                2005, PP. 25-30.
C     WRITTEN BY--ALAN HECKERT
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--2020.02
C     ORIGINAL VERSION--FEBRUARY  2020.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IINSOW
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION YOUT(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INSE'
      ISUBN2='RT  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SERT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INSERT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MAX(N1,N2)
          WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN INSERT ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE FIRST ',
     1         'RESPONSE VARIABLE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N1
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(N2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,122)
  122   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE SECOND ',
     1         'RESPONSE VARIABLE IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N2
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ELSEIF(NLOC.LT.1 .OR. NLOC.GT.N1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,132)NLOC
  132   FORMAT('      THE INSERTION ROW, (',I8,') IS GREATER THAN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,134)N1
  134   FORMAT('      NUMBER OF ROWS IN THE FIRST RESPONSE VARIABLE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,136)N1
  136   FORMAT('      THE NUMBER OF ROWS IN THE FIRST RESPONSE ',
     1         'VARIABLE = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *****************************
C               **  STEP 2--               **
C               **  PERFORM THE INSERTION  **
C               *****************************
C
      NOUT=0
      DO210II=1,NLOC-1
        NOUT=NOUT+1
        YOUT(NOUT)=Y1(II)
  210 CONTINUE
C
      DO220II=1,N2
        NOUT=NOUT+1
        IF(NOUT.GT.MAXNXT)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,222)
  222     FORMAT('      THE MAXIMUM NUMBER OF ROWS IS EXCEEDED FOR ',
     1           'THE OUTPUT VARIABLE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,226)N1
  226     FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE ',
     1           'FIRST RESPONSE VARIABLE = ',I8,'.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,227)N2
  227     FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE ',
     1           'SECOND RESPONSE VARIABLE = ',I8,'.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,228)MAXNXT
  228     FORMAT('      THE MAXIMUM NUMBER OF ROWS = ',
     1           I8,'.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        YOUT(NOUT)=Y2(II)
  220 CONTINUE
C
      IF(NOUT.LT.N1 .OR. IINSOW.EQ.'OFF')THEN
        IF(IINSOW.EQ.'ON')THEN
          NSTRT=NOUT+1
        ELSE
          NSTRT=NLOC
        ENDIF
        DO230II=NSTRT,N1
          NOUT=NOUT+1
C
          IF(NOUT.GT.MAXNXT)THEN
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,111)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,222)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,226)N1
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,227)N2
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,228)MAXNXT
            CALL DPWRST('XXX','BUG ')
            IERROR='YES'
            GOTO9000
          ENDIF
C
          YOUT(NOUT)=Y1(II)
  230   CONTINUE
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)NOUT
  811   FORMAT('THE NUMBER OF VALUES GENERATED BY THE INSERT ',
     1         'COMMAND = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SERT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF INSERT--')
        CALL DPWRST('XXX','BUG ')
        DO9012I=1,NOUT
          WRITE(ICOUT,9015)I,YOUT(I)
 9015     FORMAT('I,YOUT(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
 9012   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTARR(X,NX,IWRITE,Y,NY,IBUGA3,IERROR)
C
C     PURPOSE--COMPUTE INTERARRIVAL TIMES OF A SERIES OF FAILURE
C              TIMES.
C              SORT FAILURE TIMES
C              Y(1) = X(1)
C              Y(2) = X(2)-X(1)
C              Y(2) = X(3)-X(2)
C              Y(3) = X(4)-X(3)
C              ETC.
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--ALAN HECKERT
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--98/5
C     ORIGINAL VERSION--MAY       1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTA'
      ISUBN2='RR  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INTARR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IWRITE,IBUGA3,NX
   52   FORMAT('IWRITE,IBUGA3,NX = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NX
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **************************************
C               **  COMPUTE SEQUENTIAL DIFFERENCE.  **
C               **************************************
C
      CALL SORT(X,NX,X)
      NXM1=NX-1
      IF(NXM1.LT.1)GOTO150
      DO100I=NX,2,-1
      IP1=I-1
      Y(I)=X(I)-X(IP1)
  100 CONTINUE
      Y(1)=X(1)
      NY=NX
      GOTO190
C
  150 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,151)
  151 FORMAT('***** ERROR IN INTARR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,152)
  152 FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,155)
  155 FORMAT('      VARIABLE MUST BE 2 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,157)NX
  157 FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
      CALL DPWRST('XXX','BUG ')
C
  190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INTARR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)NY,IERROR
 9012   FORMAT('NY,IERROR = ',I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,NX
          WRITE(ICOUT,9016)I,X(I),Y(I)
 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTCNT(X,N,ALOWLM,AUPPLM,IWRITE,XCOUNT,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE COUNT FOR THE NUMBER
C              OF VALUES IN X THAT FALL WITHIN CERTAIN LIMITS.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --ALOWLM = THE REAL NUMBER THAT SPECIFIES THE
C                                LOWER LIMIT FOR THE COUNT.
C                     --AUPPLM = THE REAL NUMBER THAT SPECIFIES THE
C                                UPPER LIMIT FOR THE COUNT.
C     OUTPUT ARGUMENTS--XCOUNT = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE COUNT.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE SAMPLE COUNT.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--ALAN HECKERT
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--2018.08
C     ORIGINAL VERSION--AUGUST    2018.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTC'
      ISUBN2='NT  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TCNT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INTCNT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,ALOWLM,AUPPLM
   52   FORMAT('IBUGA3,ISUBRO,N,ALOWLM,AUPPLM = ',2(A4,2X),I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN INTERVAL COUNT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               *************************
C               **  STEP 2--           **
C               **  COMPUTE THE COUNT. **
C               *************************
C
      ICNT=0
      DO200I=1,N
        IF(X(I).GE.ALOWLM .AND. X(I).LE.AUPPLM)ICNT=ICNT+1
  200 CONTINUE
      XCOUNT=REAL(ICNT)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,ALOWLM,AUPPLM,ICNT
  811   FORMAT('THE COUNT OF THE ',I8,' OBSERVATIONS IN (',
     1         E15.7,',',E15.17,') = ',I10)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TCNT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INTCNT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,XCOUNT
 9012   FORMAT('IERROR,XCOUNT = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTERP(Y,X,N,X2,N2,IWRITE,Y2,
     1                  YTEMP,YDIST,XDIST,DELX,DELY,DERIV,DELX6,
     1                  P,B,Z,C,A,MAXNXT,
     1                  IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION--APRIL     1987.
C     UPDATED         --MAY       1989. SORT THE INPUT DATA
C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON.
C                                       ARRAY DECLARATIONS MOVED FROM INTER2
C     UPDATED         --MAY       1994. ADD ISUBRO ARGUMENT
C     UPDATED         --JULY      2019. MOVE CREATION OF SCRATCH STORAGE
C                                       TO CALLING ROUTINE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
      DIMENSION YTEMP(*)
      DIMENSION YDIST(*)
      DIMENSION XDIST(*)
C
      DIMENSION DELX(*)
      DIMENSION DELY(*)
      DIMENSION DERIV(*)
      DIMENSION DELX6(*)
      DIMENSION P(*)
      DIMENSION B(*)
      DIMENSION Z(*)
      DIMENSION C(4,MAXNXT)
      DIMENSION A(MAXNXT,3)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTE'
      ISUBN2='RP  '
      IERROR='NO'
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TERP')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INTERP--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)N,N2
   52   FORMAT('N,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,X2(I)
   66     FORMAT('I,X2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989
      CALL SORTC(X,Y,N,X,Y)
C
C               ********************************************************
C               **  STEP 12--                                         **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES         **
C               ********************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TERP')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDIST=0
      DO1210I=1,N
        IF(NDIST.EQ.0)GOTO1220
        DO1215I2=1,NDIST
          IF(X(I).EQ.XDIST(I2))GOTO1210
 1215   CONTINUE
 1220   CONTINUE
        NDIST=NDIST+1
        XDIST(NDIST)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDIST,XDIST)
C
C               *****************************************************
C               **  STEP 13--                                      **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Y VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X VALUES.        **
C               *****************************************************
C
      IF(NDIST.EQ.N)THEN
        DO1311K=1,NDIST
          YDIST(K)=Y(K)
 1311   CONTINUE
      ELSE
        DO1321K=1,NDIST
          TAG=XDIST(K)
          J=0
          DO1322I=1,N
            IF(X(I).EQ.TAG)THEN
              J=J+1
              YTEMP(J)=Y(I)
            ENDIF
 1322     CONTINUE
          NI=J
          CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR)
          YDIST(K)=YMEAN
 1321   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
CCCCC THE REMAINDER OF THIS SUBROUTINE WAS REPLACED    MAY 1989
CCCCC BY A CALL TO INTER2                              MAY 1989
C
CCCCC JUNE, 1990.  MOVE SOME DIMENSIONING FROM INTER2 TO INTERP
C
      CALL INTER2(YDIST,XDIST,NDIST,X2,N2,Y2,
     1            DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXNXT,
     1            IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TERP')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INTERP--')
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3)
 9016     FORMAT('A(I,1),A(I,2),A(I,3)        = ',3G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
        DO9025I=1,N
          WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I)
 9026     FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ',
     1           6F10.5)
          CALL DPWRST('XXX','BUG ')
 9025   CONTINUE
        DO9035I=1,N
          WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I)
 9036     FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5)
          CALL DPWRST('XXX','BUG ')
 9035   CONTINUE
        DO9042I=1,N2
          WRITE(ICOUT,9043)I,X2(I),Y2(I)
 9043     FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
 9042   CONTINUE
        WRITE(ICOUT,9051)NDIST
 9051   FORMAT('NDIST = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9052I=1,NDIST
          WRITE(ICOUT,9053)I,XDIST(I),YDIST(I)
 9053     FORMAT('I,XDIST(I),YDIST(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9052   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTER2(Y,X,N,X2,N2,Y2,
     1                  DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXOBV,
     1                  IBUGG3,ISUBRO,IERROR)
CCCCC MAY, 1994.  ADD ISUBRO ARGUMENT
CCCCC JUNE, 1990.  SOME DIMENSIONING MOVED FROM INTER2 TO INTERP
C
C     PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/4
C     ORIGINAL VERSION--APRIL     1987.
C     UPDATED         --MAY       1989.  SORT THE INPUT DATA
C     UPDATED         --JUNE      1990.  MOVE DIMENSIONS FROM INTER2 TO INTERP
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
CCCCC CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
CCCCC JUNE, 1990.  FOLLOWING INCLUDE FILE NO LONGER NEEDED
CCCCC      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
CCCCC JUNE, 1990.  FOLLOWING DIMENSIONS NOW DONE IN INTERP
CCCCC DIMENSION DELX(MAXOBV)
CCCCC DIMENSION DELY(MAXOBV)
CCCCC DIMENSION DERIV(MAXOBV)
CCCCC DIMENSION DELX6(MAXOBV)
CCCCC DIMENSION P(MAXOBV)
CCCCCCDIMENSION B(MAXOBV)
CCCCC DIMENSION Z(MAXOBV)
      DIMENSION DELX(*)
      DIMENSION DELY(*)
      DIMENSION DERIV(*)
      DIMENSION DELX6(*)
      DIMENSION P(*)
      DIMENSION B(*)
      DIMENSION Z(*)
      DIMENSION C(4,MAXOBV)
      DIMENSION A(MAXOBV,3)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTE'
      ISUBN2='RP  '
      IERROR='NO'
C
      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TER2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INTER2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)N,N2,P(1)
   52   FORMAT('N,N2,P(1) = ',2I8,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,X2(I)
   66     FORMAT('I,X2(I) = ',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
      NM1=N-1
      NM2=N-2
C
C               ********************************************
C               **  STEP 21--                             **
C               **  FORM FIRST DIFFERENCES AND THE RATIOS **
C               ********************************************
C
      DO2100I=1,NM1
      IP1=I+1
      DELX(I)=X(IP1)-X(I)
      DELY(I)=Y(IP1)-Y(I)
      DERIV(I)=DELY(I)/DELX(I)
      DELX6(I)=DELX(I)/6.0
 2100 CONTINUE
C
C               **********************************
C               **  STEP 22--                   **
C               **  FORM DIFFERENCES OF RATIOS  **
C               **********************************
C
      DO2200I=2,NM1
      IM1=I-1
      B(I)=DERIV(I)-DERIV(IM1)
 2200 CONTINUE
C
C               **********************
C               **  STEP 23--
C               **********************
C
      A(1,2)=(-1.0-DELX(1)/DELX(2))
      A(1,3)=DELX(1)/DELX(2)
      A(2,3)=DELX6(2)-DELX6(1)*A(1,3)
      A(2,2)=2.0*(DELX6(1)+DELX6(2))-DELX6(1)*A(1,2)
      A(2,3)=A(2,3)/A(2,2)
      B(2)=B(2)/A(2,2)
C
C               ****************************************
C               **  STEP 24--
C               ****************************************
C
      DO2400I=3,NM1
      IM1=I-1
      A(I,2)=2.0*(DELX6(IM1)+DELX6(I))-DELX6(IM1)*A(IM1,3)
      B(I)=B(I)-DELX6(IM1)*B(IM1)
      A(I,3)=DELX6(I)/A(I,2)
      B(I)=B(I)/A(I,2)
 2400 CONTINUE
C
C               ****************************************
C               **  STEP 25--
C               ****************************************
C
      Q=DELX(NM2)/DELX(NM1)
      A(N,1)=1.0+Q+A(NM2,3)
      A(N,2)=(-Q-A(N,1)*A(NM1,3))
      B(N)=B(NM2)-A(N,1)*B(NM1)
      Z(N)=B(N)/A(N,2)
C
C               ****************************************
C               **  STEP 26--
C               ****************************************
C
      DO2600I=1,NM2
      K=N-I
      KP1=K+1
      Z(K)=B(K)-A(K,3)*Z(KP1)
 2600 CONTINUE
      Z(1)=(-A(1,2)*Z(2)-A(1,3)*Z(3))
C
C               ****************************************
C               **  STEP 27--                         **
C               ****************************************
C
      DO2700I=1,NM1
      IP1=I+1
      Q=1.0/(6.0*DELX(I))
      C(1,I)=Z(I)*Q
      C(2,I)=Z(IP1)*Q
      C(3,I)=Y(I)/DELX(I)-Z(I)*DELX6(I)
      C(4,I)=Y(IP1)/DELX(I)-Z(IP1)*DELX6(I)
 2700 CONTINUE
C
C               ****************************************
C               **  STEP 28--
C               **  PRINT OUT Z'S
C               ****************************************
C
      IF(IBUGG3.EQ.'ON')THEN
        DO2800I=1,N
          WRITE(ICOUT,2810)I,Z(I)
 2810     FORMAT('I,Z(I) = ',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
 2800   CONTINUE
      ENDIF
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT)GOTO3110
      GOTO3119
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)XT
 3117 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3119 CONTINUE
C
      DO3200I=1,N
      I2=I
      IF(X(I).EQ.XT)GOTO3210
      IF(X(I).GT.XT)GOTO3220
 3200 CONTINUE
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3201)
 3201 FORMAT('***** ERROR IN INTER2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3202)
 3202 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3203)
 3203 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3204)
 3204 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3205)
 3205 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3206)X(1)
 3206 FORMAT('         LARGEST  DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3207)XT
 3207 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 3210 CONTINUE
      Y2(J)=Y(I2)
      GOTO3100
C
 3220 CONTINUE
      K=I2-1
      KP1=K+1
      DELU=X(KP1)-XT
      DELL=XT-X(K)
      TERM1=DELU*(C(1,K)*DELU**2+C(3,K))
      TERM2=DELL*(C(2,K)*DELL**2+C(4,K))
      Y2(J)=TERM1+TERM2
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'ON')THEN
        DO4100J=1,N2
          WRITE(ICOUT,4110)X2(J),Y2(J)
          CALL DPWRST('XXX','BUG ')
 4110     FORMAT('X2(J),Y2(J) = ',2E15.7)
 4100   CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'TER2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INTER2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)N,N2
 9012   FORMAT('N,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,N
          WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3)
 9016     FORMAT('A(I,1),A(I,2),A(I,3)        = ',3E15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
        DO9025I=1,N
         WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I)
 9026    FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ',
     1          6F10.5)
         CALL DPWRST('XXX','BUG ')
 9025   CONTINUE
        DO9035I=1,N
          WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I)
 9036     FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5)
          CALL DPWRST('XXX','BUG ')
 9035   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTFCN(XTEMP,FHAT)
C
C     PURPOSE--AUXILLARY FUNCTION FOR THE QAGI (INDEFINITE INTEGRATION
C              ROUTINES).  IT COMPUTES THE FUNCTION BEING INTEGRATED
C              AT THE VALUE X AND RETURNS THE FUNCTION VALUE IN FHAT.
C     WRITTEN BY--ALAN HECKERT
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--2013/6
C     ORIGINAL VERSION--JUNE      2013.
C     UPDATED         --SEPTEMBER 2015. SUPPORT FUNCTION BLOCKS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL XTEMP
      REAL FHAT
C
      CHARACTER*4 IH
      CHARACTER*4 IH2
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOFB.INC'
C
      COMMON/IFBL2/IFLGFB
C
      CHARACTER*8 IFBNAM
      CHARACTER*8 IFBANS
C
      CHARACTER*4 IFEESV
      COMMON/IFEED/IFEESV
C
      CHARACTER*4 ZMODEL
      CHARACTER*4 IPARN
      CHARACTER*4 IPARN2
      CHARACTER*4 IANGLU
      CHARACTER*4 ITYPEH
      CHARACTER*4 IW21HO
      CHARACTER*4 IW22HO
      CHARACTER*4 IVARN
      CHARACTER*4 IVARN2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 IFTEXP
      CHARACTER*4 IFTORD
      CHARACTER*4 IFORSW
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
C
C---------------------------------------------------------------------
C
      PARAMETER (IOPTCH=1000)
      PARAMETER (IOPTC2=100)
C
      DIMENSION PARAM(IOPTC2)
      DIMENSION IPARN(IOPTC2)
      DIMENSION IPARN2(IOPTC2)
      DIMENSION IVARN(IOPTC2)
      DIMENSION IVARN2(IOPTC2)
C
      DIMENSION ZMODEL(IOPTCH)
      DIMENSION ITYPEH(IOPTCH)
      DIMENSION IW21HO(IOPTCH)
      DIMENSION IW22HO(IOPTCH)
      DIMENSION W2HOLD(IOPTCH)
C
      DIMENSION ILOCV(IOPTC2)
CCCCC DIMENSION ILAB(IOPTC2)
C
      COMMON /OPTCMC/ IBUGA3, ITYPEH, IW21HO, IW22HO, IPARN, IPARN2,
     &                IVARN, IVARN2, ZMODEL
      COMMON /OPTCMR/ PARAM, W2HOLD,
     &                NUMCHA, NUMVAR, NWHOLD, NUMDV, ILOCV
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
      IFOUND='NO'
      ISUBRO='NULL'
      IFTEXP='+'
      IFTORD='DATA'
      IFORSW='E'
C
      MAXCP1=MAXCOL+1
      MAXCP2=MAXCOL+2
      MAXCP3=MAXCOL+3
      MAXCP4=MAXCOL+4
      MAXCP5=MAXCOL+5
      MAXCP6=MAXCOL+6
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGINNING OF INTFCN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NUMCHA,NUMDV,NUMVAR,IFLGFB,XTEMP
   53   FORMAT('NUMCHA,NUMDV,NUMVAR,IFLGFB,XTEMP = ',4I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,54)(ZMODEL(J),J=1,MIN(NUMCHA,25))
   54   FORMAT('ZMODEL(I) = ',25A4)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,NUMVAR
          WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I)
   56     FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,G15.7,A4,A4)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO59I=1,NUMDV
          WRITE(ICOUT,61)I,IVARN(I),IVARN2(I)
   61     FORMAT('I, IVARN(I),IVARN2(I) = ',I8,2X,A4,A4)
          CALL DPWRST('XXX','BUG ')
   59   CONTINUE
      ENDIF
C
C               ***************************
C               **  STEP 3--             **
C               **  INITIALIZE PARAMETERS**
C               ***************************
C
      ISTEPN='3'
      IF(IBUGA3.EQ.'ON')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IFBNAM=' '
      IFBANS=' '
      IF(IFLGFB.EQ.1)THEN
        IFBNAM=IFBNA1
        IFBANS=IFBAN1
        IH=IFBPL1(1)(1:4)
        IH2=IFBPL1(1)(5:8)
      ELSEIF(IFLGFB.EQ.2)THEN
        IFBNAM=IFBNA2
        IFBANS=IFBAN2
        IH=IFBPL2(1)(1:4)
        IH2=IFBPL2(1)(5:8)
      ELSEIF(IFLGFB.EQ.3)THEN
        IFBNAM=IFBNA3
        IFBANS=IFBAN3
        IH=IFBPL3(1)(1:4)
        IH2=IFBPL3(1)(5:8)
      ENDIF
C
      IF(IFLGFB.LE.0)THEN
        JLOC=ILOCV(1)
        PARAM(JLOC)=XTEMP
C
        IPASS=2
        IBUGCO=IBUGA3
        IBUGEV=IBUGA3
        FX=0.0
        CALL COMPIM(ZMODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMVAR,
     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,FX,
     1              IBUGCO,IBUGEV,IERROR)
        FHAT=FX
      ELSE
C
C       FUNCTION BLOCK CASE:
C
C       STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT
C               VALUE OF DESIRED PARAMETER)
C
        DO3305II=1,NUMNAM
          IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND.
     1       IUSE(II).EQ.'P')THEN
            VALUE(II)=XTEMP
            IVALUE(II)=INT(XTEMP+0.5)
            GOTO3309
          ENDIF
 3305   CONTINUE
C
C       PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD
C       TO NAME LIST
C
        IF(NUMNAM.LT.MAXNAM)THEN
          NUMNAM=NUMNAM+1
          IHNAME(NUMNAM)=IH
          IHNAM2(NUMNAM)=IH2
          IUSE(NUMNAM)='P'
          VALUE(NUMNAM)=XTEMP
          IVALUE(NUMNAM)=INT(XTEMP + 0.5)
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,3306)
 3306     FORMAT('***** ERROR IN INTEGRATION--')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,3307)
 3307     FORMAT('      MAXIMUM NUMBER OF NAMES EXCEEDED.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
 3309   CONTINUE
C
        IFEEDB='OFF'
        CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW,
     1              IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV,
     1              ISUBRO,IFOUND,IERROR)
        IFEEDB=IFEESV
C
C       STEP 2: RETRIEVE RESPONSE
C
        DO3320II=1,NUMNAM
          IF(IFBANS(1:4).EQ.IHNAME(II) .AND.
     1       IFBANS(5:8).EQ.IHNAM2(II))THEN
            IF(IUSE(II).EQ.'P')THEN
              FHAT=VALUE(II)
              GOTO3329
            ELSEIF(IUSE(II).EQ.'V')THEN
              ICOLR=IVALUE(II)
              IJ=MAXN*(ICOLR-1)+1
              IF(ICOLR.LE.MAXCOL)FHAT=V(IJ)
              IF(ICOLR.EQ.MAXCP1)FHAT=PRED(1)
              IF(ICOLR.EQ.MAXCP2)FHAT=RES(1)
              IF(ICOLR.EQ.MAXCP3)FHAT=YPLOT(1)
              IF(ICOLR.EQ.MAXCP4)FHAT=XPLOT(1)
              IF(ICOLR.EQ.MAXCP5)FHAT=X2PLOT(1)
              IF(ICOLR.EQ.MAXCP6)FHAT=TAGPLO(1)
              GOTO3329
            ENDIF
          ENDIF
 3320   CONTINUE
C
C       PARAMETER/VARIABLE NAME NOT FOUND
C
        WRITE(ICOUT,3306)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3321)
 3321   FORMAT('      EXPECTED PARAMETER/VARIABLE NOT FOUND IN ',
     1         'NAME TABLE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3323)IFBANS
 3323   FORMAT('      EXPECTED NAME = ',A8)
        CALL DPWRST('XXX','BUG ')
C
 3329   CONTINUE
C
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END      OF INTFCN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9021)IERROR
 9021   FORMAT('IERROR = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9101)XTEMP,FHAT
 9101   FORMAT('XTEMP,FHAT = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTLIN (X1,Y1,X2,Y2,X3,Y3,X4,Y4,N,
     1                   XOUT,YOUT,NOUT,
     1                   IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS ROUTINE FINDS THE INTERSECTION POINT OF TWO
C              LINES.  EACH LINE IS DEFINED BY TWO POINTS, SO
C              THERE ARE FOUR POINTS IN ALL:
C
C                 (X1,Y1) = COORDINATES FOR POINT ONE OF LINE ONE
C                 (X2,Y2) = COORDINATES FOR POINT TWO OF LINE ONE
C                 (X3,Y3) = COORDINATES FOR POINT ONE OF LINE TWO
C                 (X4,Y4) = COORDINATES FOR POINT TWO OF LINE TWO
C
C     WRITTEN BY--ALAN HECKERT
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--2012.10
C     ORIGINAL VERSION--OCTOBER   2012.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      REAL X1(*)
      REAL Y1(*)
      REAL X2(*)
      REAL Y2(*)
      REAL X3(*)
      REAL Y3(*)
      REAL X4(*)
      REAL Y4(*)
      REAL XOUT(*)
      REAL YOUT(*)
      REAL A1
      REAL B1
      REAL C1
      REAL A2
      REAL B2
      REAL C2
      REAL DENOM
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TLIN')THEN
        WRITE(ICOUT,51)N
   51   FORMAT('AT THE BEGININNING OF INTLIN--N = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO59I=1,N
          WRITE(ICOUT,53)I,X1(I),Y1(I),X2(I),Y2(I)
   53     FORMAT('I,X1(I),Y1(I),X2(I),Y2(I) = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,55)I,X3(I),Y3(I),X4(I),Y4(I)
   55     FORMAT('I,X3(I),Y3(I),X4(I),Y4(I) = ',I8,4G15.7)
          CALL DPWRST('XXX','BUG ')
   59   CONTINUE
      ENDIF
C
      IERROR='NO'
C
      DO100I=1,N
        A1=Y2(I) - Y1(I)
        B1=X1(I) - X2(I)
        C1=X2(I)*Y1(I) - X1(I)*Y2(I)
        A2=Y4(I) - Y3(I)
        B2=X3(I) - X4(I)
        C2=X4(I)*Y3(I) - X3(I)*Y4(I)
        DENOM=A1*B2 - A2*B1
        IF(DENOM.EQ.0.0)THEN
          XOUT(I)=CPUMIN
          YOUT(I)=CPUMIN
        ELSE
          XOUT(I)=(B1*C2 - B2*C1)/DENOM
          YOUT(I)=(A2*C1 - A1*C2)/DENOM
        ENDIF
  100 CONTINUE
      NOUT=N
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TLIN')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('AT THE END OF INTLIN')
        CALL DPWRST('XXX','BUG ')
        DO9059I=1,N
          WRITE(ICOUT,9053)I,XOUT(I),YOUT(I)
 9053     FORMAT('I,X3(I),Y3(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9059   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTLI2 (X1,Y1,X2,Y2,X3,Y3,X4,Y4,
     1                   XOUT,YOUT,
     1                   IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS ROUTINE FINDS THE INTERSECTION POINT OF TWO
C              LINES.  EACH LINE IS DEFINED BY TWO POINTS, SO
C              THERE ARE FOUR POINTS IN ALL:
C
C                 (X1,Y1) = COORDINATES FOR POINT ONE OF LINE ONE
C                 (X2,Y2) = COORDINATES FOR POINT TWO OF LINE ONE
C                 (X3,Y3) = COORDINATES FOR POINT ONE OF LINE TWO
C                 (X4,Y4) = COORDINATES FOR POINT TWO OF LINE TWO
C
C              THIS IS SIMILAR TO INTLIN.  THE DISTINCTION IS THAT
C              INTLIN ACCEPTS ARRAY ARGUMENTS WHILE INTLI2 ACCEPTS
C              SCALAR ARGUMENTS.
C     WRITTEN BY--ALAN HECKERT
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--2012.10
C     ORIGINAL VERSION--OCTOBER   2012.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      REAL X1
      REAL Y1
      REAL X2
      REAL Y2
      REAL X3
      REAL Y3
      REAL X4
      REAL Y4
      REAL XOUT
      REAL YOUT
      REAL A1
      REAL B1
      REAL C1
      REAL A2
      REAL B2
      REAL C2
      REAL DENOM
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TLI2')THEN
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGININNING OF INTLI2')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)X1,Y1,X2,Y2,X3,Y3,X4,Y4
   53   FORMAT('X1,Y1,X2,Y2,X3,Y3,X4,Y4 = ',8G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IERROR='NO'
C
      A1=Y2 - Y1
      B1=X1 - X2
      C1=X2*Y1 - X1*Y2
      A2=Y4 - Y3
      B2=X3 - X4
      C2=X4*Y3 - X3*Y4
      DENOM=A1*B2 - A2*B1
      IF(DENOM.EQ.0.0)THEN
        XOUT=CPUMIN
        YOUT=CPUMIN
      ELSE
        XOUT=(B1*C2 - B2*C1)/DENOM
        YOUT=(A2*C1 - A1*C2)/DENOM
      ENDIF
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TLIN')THEN
        WRITE(ICOUT,9051)
 9051   FORMAT('AT THE END OF INTLIN')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9053)XOUT,YOUT
 9053   FORMAT('X3(I),Y3(I) = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE INTRV(XT,LXT,X,ILO,ILEFT,MFLAG)
C***BEGIN PROLOGUE  INTRV
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  E3,K6
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Computes the largest integer ILEFT in 1.LE.ILEFT.LE.LXT
C            such that XT(ILEFT).LE.X where XT(*) is a subdivision
C            of the X interval.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Reference
C         SIAM J. Numerical Analysis, 14, No. 3, June 1977, pp. 441-472.
C
C     Abstract
C         INTRV is the INTERV routine of the reference.
C
C         INTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE.
C         LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of
C         the X interval.  Precisely,
C
C                      X .LT. XT(1)                1         -1
C         if  XT(I) .LE. X .LT. XT(I+1)  then  ILEFT=I  , MFLAG=0
C           XT(LXT) .LE. X                         LXT        1,
C
C         That is, when multiplicities are present in the break point
C         to the left of X, the largest index is taken for ILEFT.
C
C     Description of Arguments
C         Input
C          XT      - XT is a knot or break point vector of length LXT
C          LXT     - length of the XT vector
C          X       - argument
C          ILO     - an initialization parameter which must be set
C                    to 1 the first time the spline array XT is
C                    processed by INTRV.
C
C         Output
C          ILO     - ILO contains information for efficient process-
C                    ing after the initial call, and ILO must not be
C                    changed by the user.  Distinct splines require
C                    distinct ILO parameters.
C          ILEFT   - largest integer satisfying XT(ILEFT) .LE. X
C          MFLAG   - signals when X lies out of bounds
C
C     Error Conditions
C         None
C***REFERENCES  C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  INTRV
C
C
      INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE
      REAL X, XT
      DIMENSION XT(LXT)
C***FIRST EXECUTABLE STATEMENT  INTRV
      IHI = ILO + 1
      IF (IHI.LT.LXT) GO TO 10
      IF (X.GE.XT(LXT)) GO TO 110
      IF (LXT.LE.1) GO TO 90
      ILO = LXT - 1
      IHI = LXT
C
   10 IF (X.GE.XT(IHI)) GO TO 40
      IF (X.GE.XT(ILO)) GO TO 100
C
C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND
      ISTEP = 1
   20 IHI = ILO
      ILO = IHI - ISTEP
      IF (ILO.LE.1) GO TO 30
      IF (X.GE.XT(ILO)) GO TO 70
      ISTEP = ISTEP*2
      GO TO 20
   30 ILO = 1
      IF (X.LT.XT(1)) GO TO 90
      GO TO 70
C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND
   40 ISTEP = 1
   50 ILO = IHI
      IHI = ILO + ISTEP
      IF (IHI.GE.LXT) GO TO 60
      IF (X.LT.XT(IHI)) GO TO 70
      ISTEP = ISTEP*2
      GO TO 50
   60 IF (X.GE.XT(LXT)) GO TO 110
      IHI = LXT
C
C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL
   70 MIDDLE = (ILO+IHI)/2
      IF (MIDDLE.EQ.ILO) GO TO 100
C     NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1
      IF (X.LT.XT(MIDDLE)) GO TO 80
      ILO = MIDDLE
      GO TO 70
   80 IHI = MIDDLE
      GO TO 70
C *** SET OUTPUT AND RETURN
   90 MFLAG = -1
      ILEFT = 1
      RETURN
  100 MFLAG = 0
      ILEFT = ILO
      RETURN
  110 MFLAG = 1
      ILEFT = LXT
      RETURN
      END
      SUBROUTINE INTVEC(Y,X,N,NUMVAR,IWRITE,XYINT,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              INTEGRAL OF THE DATA IN THE INPUT VECTOR Y (IF NUMVAR = 1)
C              OR OF THE INTEGRAL OF Y (VERTICALLY)
C              WITH RESPECT TO X (HORIZONTALLY) (IF NUMVAR = 2).
C     NOTE--WHEN NUMVAR = 1, IT IS ASSUMED THAT THE
C           HORIZONTAL AXIS VARIABLE IS EQUALLY-SPACED
C           WITH UNIT SPACING.
C     NOTE--THE TRAPEZOID RULE IS USED.
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                VERTICAL AXIS OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XYINT  = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE INTEGRAL.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE INTEGRAL.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --JUNE      1979.
C     UPDATED         --JULY      1979.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DYI
      DOUBLE PRECISION DXIM1
      DOUBLE PRECISION DYIM1
      DOUBLE PRECISION DDELX
      DOUBLE PRECISION DDELY
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INTV'
      ISUBN2='EC  '
      IERROR='NO'
C
      DXI=0.0D0
      DYI=0.0D0
      DXIM1=0.0D0
      DYIM1=0.0D0
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3
   52 FORMAT('IBUGA3 = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N,NUMVAR
   53 FORMAT('N,NUMVAR = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,X(I),Y(I)
   56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               *******************************************
C               **  COMPUTE     (NUMERICAL) INTEGRAL     **
C               *******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.GE.1)GOTO119
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      THE INTEGRAL IS TO BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)
  116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,117)N
  117 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  119 CONTINUE
C
      IF(N.EQ.1)GOTO120
      GOTO129
  120 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,121)
CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
CCCCC1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1')
CCCCC CALL DPWRST('XXX','BUG ')
      XYINT=0.0
      GOTO800
  129 CONTINUE
C
      IF(NUMVAR.EQ.1.OR.NUMVAR.EQ.2)GOTO139
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** INTERNAL ERROR IN INTVEC--',
     1'THE FOURTH INPUT ARGUMENT (NUMVAR) HAS VALUE OTHER THAN 1 OR 2')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)NUMVAR
  132 FORMAT('      NUMVAR = ',I8)
      CALL DPWRST('XXX','BUG ')
      GOTO9000
  139 CONTINUE
C
      HOLD=Y(1)
      DO145I=2,N
      IF(Y(I).NE.HOLD)GOTO149
  145 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,146)HOLD
CC146 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
CCCCC1'THE FIRST  INPUT ARGUMENT (A VECTOR Y) HAS ALL ELEMENTS = ',
CCCCC1E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      GOTO190
  149 CONTINUE
C
      IF(NUMVAR.LE.1)GOTO159
      HOLD=X(1)
      DO155I=2,N
      IF(Y(I).NE.HOLD)GOTO159
  155 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,156)HOLD
CC156 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--',
CCCCC1'THE SECOND INPUT ARGUMENT (A VECTOR X) HAS ALL ELEMENTS = ',
CCCCC1E15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XYINT=0.0
      GOTO800
  159 CONTINUE
C
  190 CONTINUE
C
C               ****************************************
C               **  STEP 2--                          **
C               **  COMPUTE THE (NUMERICAL) INTEGRAL  **
C               ****************************************
C
      DSUM=0.0D0
      I=1
      IF(NUMVAR.EQ.1)DXI=I
      IF(NUMVAR.EQ.2)DXI=X(I)
      DYI=Y(1)
      DO200I=2,N
      DXIM1=DXI
      DYIM1=DYI
      IF(NUMVAR.EQ.1)DXI=I
      IF(NUMVAR.EQ.2)DXI=X(I)
      DYI=Y(I)
      DDELX=DXI-DXIM1
      DDELY=DYI-DYIM1
      DTERM1=DYIM1*DDELX
      DTERM2=DDELY*DDELX/2.0D0
      DSUM=DSUM+DTERM1+DTERM2
  200 CONTINUE
      XYINT=DSUM
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
  800 CONTINUE
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)N,XYINT
  811 FORMAT('THE (TRAPEZOID RULE) INTEGRAL OF THE ',I8,
     1' OBSERVATIONS = ',E15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INTVEC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)DXI,DYI,DXIM1,DYIM1
 9014 FORMAT('DXI,DYI,DXIM1,DYIM1 = ',4D15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XYINT
 9015 FORMAT('XYINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE INT2D(Z,Y,X,N,Y2,NY,X2,NX,IWRITE,Z2,N2,
     1                 YTEMP,XTEMP,YDIST,XDIST,ZDIST,
     1                 ZTEMP,ZTEMP2,XNEW,YNEW,
     1                 WORK,IWORK,
     1                 IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BIVARIATE INTERPOLATION OF SCATTERED DATA.
C              THE INTERPOLATION IS GENERATED ON A GRID.
C              THE BILINEAR INTERPOLATION WORKS ON DATA THAT FORMS A
C              GRID TO POINTS NOT ON THE GRID WHILE THIS ROUTINE
C              INTERPOLATES NON-GRIDDED DATA TO FORM A GRID.
C              A TYPICAL USE OF THIS ROUTINE IS TO GENERATE A CONTOUR
C              PLOT FROM NON-GRIDDED DATA.
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                Z AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR
C           Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBRO
C
      CHARACTER*4 IHP
      CHARACTER*4 IHP2
      CHARACTER*4 IHWUSE
      CHARACTER*4 MESSAG
C
C---------------------------------------------------------------------
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION Z2(*)
C
      DIMENSION YTEMP(*)
      DIMENSION XTEMP(*)
      DIMENSION YDIST(*)
      DIMENSION XDIST(*)
      DIMENSION ZDIST(*)
      DIMENSION ZTEMP2(*)
      DIMENSION ZTEMP(*)
      DIMENSION XNEW(*)
      DIMENSION YNEW(*)
CCCCC DIMENSION IWORK(7*MAXOBV)
CCCCC DIMENSION WORK(7*MAXOBV)
      DIMENSION IWORK(*)
      DIMENSION WORK(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INT2'
      ISUBN2='D   '
      IERROR='NO'
C
      ILAST=-99
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF INT2D--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)N,NX,NY
   52   FORMAT('N,NX,NY = ',3I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Z(I),Y(I),X(I)
   56     FORMAT('I,Z(I),Y(I),X(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,NX
          WRITE(ICOUT,66)I,X2(I)
   66     FORMAT('I,X2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
        DO75I=1,NY
          WRITE(ICOUT,76)I,Y2(I)
   76     FORMAT('I,Y2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   75   CONTINUE
      ENDIF
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      ISTEPN='11'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO1010,I=1,N
        XTEMP(I)=X(I)
 1010 CONTINUE
C
      CALL SORTC(X,Y,N,X,Y)
      CALL SORTC(XTEMP,Z,N,XTEMP,Z)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1210I=1,N
        IF(NDISTX.EQ.0)GOTO1220
        DO1215I2=1,NDISTX
          IF(X(I).EQ.XDIST(I2))GOTO1210
 1215   CONTINUE
 1220   CONTINUE
        NDISTX=NDISTX+1
        XDIST(NDISTX)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 13--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               *******************************************************
C
      ISTEPN='13'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1310I=1,N
        IF(NDISTY.EQ.0)GOTO1320
        DO1315I2=1,NDISTY
          IF(Y(I).EQ.YDIST(I2))GOTO1310
 1315   CONTINUE
 1320   CONTINUE
        NDISTY=NDISTY+1
        YDIST(NDISTY)=Y(I)
 1310 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
C               *******************************************************
C               **  STEP 14--                                        **
C               **  SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE     **
C               **  CHECK FOR REPLICATION OF POINTS                  **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Z VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               *******************************************************
C
      ISTEPN='14'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NUMZ=0
      ISTART=1
      DO1410I=1,NDISTX
        XT=XDIST(I)
        ICOUNT=0
        DO1420J=ISTART,N
        IF(X(J).EQ.XT)THEN
          IF(ICOUNT.EQ.0)IFRST=J
          ICOUNT=ICOUNT+1
          YTEMP(ICOUNT)=Y(J)
          ZTEMP(ICOUNT)=Z(J)
          ILAST=J
        ELSEIF(X(J).GT.XT)THEN
          GOTO1421
        ENDIF
 1420   CONTINUE
 1421   CONTINUE
C
        ISTART=ILAST+1
        CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP)
        DO1471K=1,NDISTY
          TAG=YDIST(K)
          J=0
          DO1472II=1,ICOUNT
            IF(YTEMP(II).EQ.TAG)THEN
              J=J+1
              ZTEMP2(J)=ZTEMP(II)
            END IF
 1472     CONTINUE
          NI=J
          IF(NI.EQ.1)THEN
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZTEMP2(1)
            XNEW(NUMZ)=XT
            YNEW(NUMZ)=TAG
          ELSE IF(NI.GT.1)THEN
            CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR)
            NUMZ=NUMZ+1
            ZDIST(NUMZ)=ZMEAN
            XNEW(NUMZ)=XT
            YNEW(NUMZ)=TAG
          ENDIF
 1471   CONTINUE
C
 1410 CONTINUE
C
C               *******************************************************
C               **  STEP 15--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               **  FOR THE INTERPOLATION POINTS                     **
C               *******************************************************
C
      ISTEPN='15'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTX=0
      DO1510I=1,NX
        IF(NDISTX.EQ.0)GOTO1520
        DO1515I2=1,NDISTX
          IF(X2(I).EQ.XDIST(I2))GOTO1510
 1515   CONTINUE
 1520   CONTINUE
        NDISTX=NDISTX+1
        XDIST(NDISTX)=X2(I)
 1510 CONTINUE
C
      CALL SORT(XDIST,NDISTX,XDIST)
C
C               *******************************************************
C               **  STEP 16--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT Y VALUES        **
C               **  FOR THE INTERPOLATION POINTS                     **
C               *******************************************************
C
      ISTEPN='16'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDISTY=0
      DO1610I=1,NY
        IF(NDISTY.EQ.0)GOTO1620
        DO1615I2=1,NDISTY
          IF(Y2(I).EQ.YDIST(I2))GOTO1610
 1615   CONTINUE
 1620   CONTINUE
        NDISTY=NDISTY+1
        YDIST(NDISTY)=Y2(I)
 1610 CONTINUE
C
      CALL SORT(YDIST,NDISTY,YDIST)
C
      N2=NDISTX*NDISTY
      IF(N2.LE.MAXOBV)GOTO1699
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1651)
 1651 FORMAT('***** ERROR IN INT2D--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1652)
 1652 FORMAT('      THE NUMBER OF REQUESTED INTERPOLATION POINTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1653)MAXOBV
 1653 FORMAT('      WILL EXCEED THE MAXIMUM ALLOWABLE OF ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1654)
 1654 FORMAT('      THE NUMBER OF DISTINCT X AND Y INTERPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1655)NDISTX,NDISTY
 1655 FORMAT('      IS ',I8,' AND ',I8,' RESPECTIVELY.   *****')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1699 CONTINUE
C
C               ********************************************
C               **  STEP 17--                             **
C               **  CHECK FOR USER PARAMETER NPPR         **
C               ********************************************
C
      NPPR=10
      ANPPR=10.0
      IHP='NPPR'
      IHP2='    '
      IHWUSE='P'
      MESSAG='NO'
      CALL CHECKN(IHP,IHP2,IHWUSE,
     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
      IF(IERROR.EQ.'YES')GOTO1710
      ANPPR=VALUE(ILOCP)
 1710 CONTINUE
C
      NPPR=INT(ANPPR+0.5)
      IF(NPPR.GE.3)GOTO1719
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1651)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1712)
 1712 FORMAT('      THE AVERAGE NUMBER OF POINTS PER REGION MUST BE ',
     1       'GRETAER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1715)
 1715 FORMAT('      THAN OR EQUAL TO 3;  SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1716)NPPR
 1716 FORMAT('      THE CURRENT VALUE OF NPPR IS ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1717)
 1717 FORMAT('      A VALUE OF 10 WILL BE USED')
      CALL DPWRST('XXX','BUG ')
      NPPR=10
 1719 CONTINUE
C
C
C
C               ********************************************
C               **  STEP 18--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      NIWK=7*MAXOBV
      NWK=7*MAXOBV
      CALL INT2D2(ZDIST,YNEW,XNEW,N,YDIST,NY,XDIST,NX,Z2,N2,
     1            NPPR,NIWK,NWK,WORK,IWORK,
     1            IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF INT2D--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)N,N2
 9012   FORMAT('N,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO9042I=1,N2
          WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I)
 9043     FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9042   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE INT2D2(Z,Y,X,N,Y2,NY,X2,NX,Z2,N2,
     1NPPR,NIWK,NWK,WORK,IWORK,
     1IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE BI-VARIATE INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C              THIS ROUTINE STARTS FROM SCATTERED DATA AND INTERPOLATES
C              POINTS ON A GRID.  NOTE THAT X2 AND Y2 DEFINE THE GRID
C              TO INTERPOLATE OVER.
C              THIS ROUTINE USES THE LOTPS ROUTINE WRITTEN BY RICHARD
C              FRANKE OF THE NAVAL POSTGRADUATE SCHOOL.
C     INPUT  ARGUMENTS--Z      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                Z AXIS DATA POINTS.
C                     --Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                VERTICAL AXIS INTERPOLATION
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Z2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR
C           Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.)
C     NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--94/5
C     ORIGINAL VERSION--MAY       1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION Z2(*)
      DIMENSION Y2(*)
      DIMENSION X2(*)
      DIMENSION WORK(*)
      DIMENSION IWORK(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='INT2'
      ISUBN2='D2  '
      IERROR='NO'
C
      ISTART=-99
C
      DO10I=1,N2
      Z2(I)=0.0
 10   CONTINUE
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF INT2D2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)NX,NY
   52 FORMAT('NX, NY = ',2I8)
      CALL DPWRST('XXX','BUG ')
      DO54I=1,N
      WRITE(ICOUT,53)I,X(I),Y(I),Z(I)
      CALL DPWRST('XXX','BUG ')
 53   FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 54   CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      IMODE=1
      CALL LOTPS(IMODE,NPPR,N,X,Y,Z,NX,X2,NY,Y2,IWORK,NIWK,NIWKU,
     1WORK,NWK,NWKU,Z2,KERR)
      IF(KERR.GT.0)THEN
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO4190
      J1=0
      DO4100I=1,NX
      DO4110J=1,NY
      J1=J1+1
      WRITE(ICOUT,4112)X2(I),Y2(J),Z2(J1)
      CALL DPWRST('XXX','BUG ')
 4112 FORMAT('I,J,X2(I),Y2(J),Z2(I,J) = ',2I8,3E15.7)
 4110 CONTINUE
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF INT2D2--')
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION ISAMAX(N,SX,INCX)
C***BEGIN PROLOGUE  ISAMAX
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1A2
C***KEYWORDS  BLAS,LINEAR ALGEBRA,MAXIMUM COMPONENT,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find largest component of s.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C   ISAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of single precision SX.
C     ISAMAX =  first I, I = 1 to N, to minimize  ABS(SX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  ISAMAX
C
      REAL SX(*),SMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  ISAMAX
      ISAMAX = 0
      IF(N.LE.0) RETURN
      ISAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      SMAX = ABS(SX(1))
      NS = N*INCX
      II = 1
          DO 10 I=1,NS,INCX
          XMAG = ABS(SX(I))
          IF(XMAG.LE.SMAX) GO TO 5
          ISAMAX = II
          SMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
         XMAG = ABS(SX(I))
         IF(XMAG.LE.SMAX) GO TO 30
         ISAMAX = I
         SMAX = XMAG
   30 CONTINUE
      RETURN
      END
      subroutine isort (n, ix)
c-----------------------------------------------------------------------
c  Name:       ISORT  (Used by Fisher Exact Test)
c
c  Purpose:    Shell sort for an integer vector.
c
c  Usage:      CALL ISORT (N, IX)
c
c  Arguments:
c     N      - Lenth of vector IX.  (Input)
c     IX     - Vector to be sorted.  (Input/output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    n, ix(*)
c                                  SPECIFICATIONS FOR LOCAL VARIABLES
      integer    i, ikey, il(10), it, iu(10), j, kl, ku, m
c                                  SPECIFICATIONS FOR SUBROUTINES
CCCCC external   prterr
c                                  Sort IX
      INCLUDE 'DPCOP2.INC'
C
      m = 1
      i = 1
      j = n
   10 if (i .ge. j) go to 40
      kl   = i
      ku   = j
      ikey = i
      j    = j + 1
c                                  Find element in first half
   20 i = i + 1
      if (i .lt. j) then
         if (ix(ikey) .gt. ix(i)) go to 20
      end if
c                                  Find element in second half
   30 j = j - 1
      if (ix(j) .gt. ix(ikey)) go to 30
c                                  Interchange
      if (i .lt. j) then
         it    = ix(i)
         ix(i) = ix(j)
         ix(j) = it
         go to 20
      end if
      it       = ix(ikey)
      ix(ikey) = ix(j)
      ix(j)    = it
c                                  Save upper and lower subscripts of
c                                  the array yet to be sorted
      if (m .lt. 11) then
         if (j-kl .lt. ku-j) then
            il(m) = j + 1
            iu(m) = ku
            i     = kl
            j     = j - 1
         else
            il(m) = kl
            iu(m) = j - 1
            i     = j + 1
            j     = ku
         end if
         m = m + 1
         go to 10
      else
CCCCC    call prterr (20, 'This should never occur.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR FROM ISORT--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      This should never occur.')
      CALL DPWRST('XXX','BUG ')
      end if
c                                  Use another segment
   40 m = m - 1
      if (m .eq. 0) go to 9000
      i = il(m)
      j = iu(m)
      go to 10
c
 9000 return
      end
      SUBROUTINE IWECDF(X,GAMMA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE CUMULATIVE DISTRIBUTION  FUNCTION
C              F(X) = EXP(-(X**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
C
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'IWECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0)THEN
        CDF=0.0
      ELSE
        DGAMMA=DBLE(GAMMA)
        DX=DBLE(X)
        DCDF=DEXP(-(DX**(-DGAMMA)))
        CDF=REAL(DCDF)
      ENDIF
C
 9000 CONTINUE
C
      RETURN
      END
      SUBROUTINE IWEPDF(X,GAMMA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA*(X**(-GAMMA-1))*EXP(-(X**(-GAMMA))).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SHAPE PARAMETER
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGHT PARAMETER = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'IWEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0)THEN
        PDF=0.0
      ELSE
        DGAMMA=DBLE(GAMMA)
        DX=DBLE(X)
        DPDF=DGAMMA*(DX**(-DGAMMA-1.0D0))*DEXP(-(DX**(-DGAMMA)))
        PDF=REAL(DPDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IWEPPF(P,GAMMA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE INVERTED WEIBULL
C              DISTRIBUTION WITH SINGLE PRECISION
C              TAIL LENGTH PARAMETER = GAMMA.
C              THE INVERTED WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PERCENT POINT FUNCTION
C              G(P) = -[LOG(P)]**(-1/GAMMA)
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (INCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE
C                                OF THE TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--GAMMA SHOULD BE POSITIVE.
C                 --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, XX.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1'IWEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'IWEPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DGAMMA=DBLE(GAMMA)
      DP=DBLE(P)
      DTERM1=-DLOG(DP)
      DTERM2=-1.0D0/DGAMMA
      DPPF=DTERM1**DTERM2
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE IWERAN(N,GAMMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE INVERTED WEIBULL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C              THE PROTOTYPE WEIBULL DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL POSITIVE X,
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**-GAMMA)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE INVERTED WEIBULL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'IWERAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'IWERAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N INVERTED WEIBULL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL IWEPPF(X(I),GAMMA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      integer function iwork (iwkmax, iwkpt, number, itype)
c-----------------------------------------------------------------------
c  Name:       IWORK
c
c  Purpose:    Routine for allocating workspace.
c
c  Usage:      IWORK (IWKMAX, IWKPT, NUMBER, ITYPE)
c
c  Arguments:
c     IWKMAX - Maximum length of workspace.  (Input)
c     IWKPT  - Amount of workspace currently allocated.  (Input/output)
c     NUMBER - Number of elements of workspace desired.  (Input)
c     ITYPE  - Worspace type.  (Input)
c              ITYPE  TYPE
c                2    Integer
c                3    Real
c                4    Double Precision
c     IWORK  - Index in RWRK, DWRK, or IWRK of the beginning of the
c              first element in the workspace array.  (Output)
c-----------------------------------------------------------------------
c                                  SPECIFICATIONS FOR ARGUMENTS
      integer    iwkmax, iwkpt, number, itype
c                                  SPECIFICATIONS FOR INTRINSICS
      intrinsic  mod
ccccc integer    mod
c                                  SPECIFICATIONS FOR SUBROUTINES
CCCCC external   prterr
c
      INCLUDE 'DPCOP2.INC'
C
      iwork = iwkpt
      if (itype.eq.2 .or. itype.eq.3) then
         iwkpt = iwkpt + number
      else
         if (mod(iwork,2) .ne. 0) iwork = iwork + 1
         iwkpt = iwkpt + 2*number
         iwork = iwork/2
      end if
      if (iwkpt .gt. iwkmax+1) then
CCCCC    call prterr (40, 'Out of workspace.')
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** ERROR FROM IWORK--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)
 9013 FORMAT('      Out of workspace.')
      CALL DPWRST('XXX','BUG ')
      end if
      return
      end
      DOUBLE PRECISION FUNCTION J1FUN(DX)
C
C     PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION:
C                 J(X,A) = INTEGRAL[0 to X][T**(A-1)*LOG(T)*EXP(-T)]dt
C              THIS FUNCTION IS USED IN COMPUTING MAXIMUM LIKELIHOOD
C              ESTIMATES FOR THE GAMMA DISTRIBUTION FOR MULTIPLY
C              CENSORED DATA.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE J(X,A) FUNCTION IS TO BE
C                                EVALUATED.
C     OUTPUT ARGUMENTS--J1FUN  = THE DOUBLE PRECISION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.11
C     ORIGINAL VERSION--NOVEMBER  2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DA
      COMMON/J1COM/DA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      J1FUN=DX**(DA-1.0D0)*DLOG(DX)*DEXP(-DX)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION J2FUN(DX)
C
C     PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION:
C                 J(X,A) = INTEGRAL[0 to X]
C                          [T**(A-1)*(LOG(T)**2)**EXP(-T)]dt
C              THIS FUNCTION IS USED IN COMPUTING THE STANDARD
C              ERRORS OF THE MAXIMUM LIKELIHOOD ESTIMATES FOR THE
C              GAMMA DISTRIBUTION FOR MULTIPLY CENSORED DATA.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE J(X,A) FUNCTION IS TO BE
C                                EVALUATED.
C     OUTPUT ARGUMENTS--J2FUN  = THE DOUBLE PRECISION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.11
C     ORIGINAL VERSION--NOVEMBER  2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
C
      DOUBLE PRECISION DX
C
      DOUBLE PRECISION DA
      COMMON/J1COM/DA
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ************************************
C               **  STEP 1--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      J2FUN=DX**(DA-1.0D0)*(DLOG(DX)**2)*DEXP(-DX)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION J0INT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the Bessel
C      function J0, defined as
C
C        J0INT(x) = {integral 0 to x} J0(t) dt
C
C      The code uses Chebyshev expansions whose coefficients are
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If the value of |x| is too large, it is impossible to
C      accurately compute the trigonometric functions used. An
C      error message is printed, and the function returns the
C      value 1.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used from the array
C                ARJ01. The recommended value is such that
C                   ABS(ARJ01(NTERM1)) < EPS/100, provided that
C
C      NTERM2 - The no. of terms to be used from the array
C                ARJ0A1. The recommended value is such that
C                   ABS(ARJ0A1(NTERM2)) < EPS/100, provided that
C
C      NTERM3 - The no. of terms to be used from the array
C                ARJ0A2. The recommended value is such that
C                   ABS(ARJ0A2(NTERM3)) < EPS/100, provided that
C
C      XLOW - The value of |x| below which J0INT(x) = x to
C             machine-precision. The recommended value is
C                 sqrt(12*EPSNEG)
C
C      XHIGH - The value of |x| above which it is impossible
C              to calculate (x-pi/4) accurately. The recommended
C              value is      1/EPSNEG
C
C      For values of EPS and EPSNEG for various machine/compiler
C      combinations refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      COS , SIN , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C          Dr. Allan J. MacLeod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley,
C          Paisley,
C          SCOTLAND
C          PA1 2BE
C
C          (e-mail:   macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                    23 January, 1996
C
      INTEGER IND,NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION ARJ01(0:23),ARJ0A1(0:21),ARJ0A2(0:18),
     1     CHEVAL,FIVE12,ONE,ONEHUN,ONE28,PIB41,PIB411,PIB412,
     2     PIB42,RT2BPI,SIXTEN,T,TEMP,TWELVE,X,XHIGH,XLOW,
     3     XMPI4,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*26
CCCCC DATA FNNAME/'J0INT '/
CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO,ONE/ 0.0 D 0 , 1.0 D 0 /
      DATA TWELVE,SIXTEN/ 12.0 D 0 , 16.0 D 0 /
      DATA ONEHUN,ONE28,FIVE12/ 100.0 D 0 , 128.0 D 0 , 512 D 0 /
      DATA RT2BPI/0.79788 45608 02865 35588 D 0/
      DATA PIB411,PIB412/ 201.0 D 0 , 256.0 D 0/
      DATA PIB42/0.24191 33974 48309 61566 D -3/
      DATA ARJ01(0)/  0.38179 27932 16901 73518  D    0/
      DATA ARJ01(1)/ -0.21275 63635 05053 21870  D    0/
      DATA ARJ01(2)/  0.16754 21340 72157 94187  D    0/
      DATA ARJ01(3)/ -0.12853 20977 21963 98954  D    0/
      DATA ARJ01(4)/  0.10114 40545 57788 47013  D    0/
      DATA ARJ01(5)/ -0.91007 95343 20156 8859   D   -1/
      DATA ARJ01(6)/  0.64013 45264 65687 3103   D   -1/
      DATA ARJ01(7)/ -0.30669 63029 92675 4312   D   -1/
      DATA ARJ01(8)/  0.10308 36525 32506 4201   D   -1/
      DATA ARJ01(9)/ -0.25567 06503 99956 918    D   -2/
      DATA ARJ01(10)/ 0.48832 75580 57983 04     D   -3/
      DATA ARJ01(11)/-0.74249 35126 03607 7      D   -4/
      DATA ARJ01(12)/ 0.92226 05637 30861        D   -5/
      DATA ARJ01(13)/-0.95522 82830 7083         D   -6/
      DATA ARJ01(14)/ 0.83883 55845 986          D   -7/
      DATA ARJ01(15)/-0.63318 44888 58           D   -8/
      DATA ARJ01(16)/ 0.41560 50422 1            D   -9/
      DATA ARJ01(17)/-0.23955 29307              D  -10/
      DATA ARJ01(18)/ 0.12228 6885               D  -11/
      DATA ARJ01(19)/-0.55697 11                 D  -13/
      DATA ARJ01(20)/ 0.22782 0                  D  -14/
      DATA ARJ01(21)/-0.8417                     D  -16/
      DATA ARJ01(22)/ 0.282                      D  -17/
      DATA ARJ01(23)/-0.9                        D  -19/
      DATA ARJ0A1(0)/  1.24030 13303 75189 70827  D    0/
      DATA ARJ0A1(1)/ -0.47812 53536 32280 693    D   -2/
      DATA ARJ0A1(2)/  0.66131 48891 70667 8      D   -4/
      DATA ARJ0A1(3)/ -0.18604 27404 86349        D   -5/
      DATA ARJ0A1(4)/  0.83627 35565 080          D   -7/
      DATA ARJ0A1(5)/ -0.52585 70367 31           D   -8/
      DATA ARJ0A1(6)/  0.42606 36325 1            D   -9/
      DATA ARJ0A1(7)/ -0.42117 61024              D  -10/
      DATA ARJ0A1(8)/  0.48894 6426               D  -11/
      DATA ARJ0A1(9)/ -0.64834 929                D  -12/
      DATA ARJ0A1(10)/ 0.96172 34                 D  -13/
      DATA ARJ0A1(11)/-0.15703 67                 D  -13/
      DATA ARJ0A1(12)/ 0.27871 2                  D  -14/
      DATA ARJ0A1(13)/-0.53222                    D  -15/
      DATA ARJ0A1(14)/ 0.10844                    D  -15/
      DATA ARJ0A1(15)/-0.2342                     D  -16/
      DATA ARJ0A1(16)/ 0.533                      D  -17/
      DATA ARJ0A1(17)/-0.127                      D  -17/
      DATA ARJ0A1(18)/ 0.32                       D  -18/
      DATA ARJ0A1(19)/-0.8                        D  -19/
      DATA ARJ0A1(20)/ 0.2                        D  -19/
      DATA ARJ0A1(21)/-0.1                        D  -19/
      DATA ARJ0A2(0)/  1.99616 09630 13416 75339  D    0/
      DATA ARJ0A2(1)/ -0.19037 98192 46668 161    D   -2/
      DATA ARJ0A2(2)/  0.15397 10927 04422 6      D   -4/
      DATA ARJ0A2(3)/ -0.31145 08832 8103         D   -6/
      DATA ARJ0A2(4)/  0.11108 50971 321          D   -7/
      DATA ARJ0A2(5)/ -0.58666 78712 3            D   -9/
      DATA ARJ0A2(6)/  0.41399 26949              D  -10/
      DATA ARJ0A2(7)/ -0.36539 8763               D  -11/
      DATA ARJ0A2(8)/  0.38557 568                D  -12/
      DATA ARJ0A2(9)/ -0.47098 00                 D  -13/
      DATA ARJ0A2(10)/ 0.65022 0                  D  -14/
      DATA ARJ0A2(11)/-0.99624                    D  -15/
      DATA ARJ0A2(12)/ 0.16700                    D  -15/
      DATA ARJ0A2(13)/-0.3028                     D  -16/
      DATA ARJ0A2(14)/ 0.589                      D  -17/
      DATA ARJ0A2(15)/-0.122                      D  -17/
      DATA ARJ0A2(16)/ 0.27                       D  -18/
      DATA ARJ0A2(17)/-0.6                        D  -19/
      DATA ARJ0A2(18)/ 0.1                        D  -19/
C
      XLOW=CPUMIN
C
C   Start computation
C
      X = XVALUE
      IND = 1
      IF ( X .LT. ZERO ) THEN
         X = -X
         IND = -1
      ENDIF
C
C   Compute the machine-dependent constants.
C
      TEMP = D1MACH(3)
      XHIGH = ONE / TEMP
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         J0INT = ONE
         IF ( IND .EQ. -1 ) J0INT = -J0INT
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM J0INT--SIZE OF THE INPUT ARGUMENT ',
     1        'IS TOO LARGE, ARGUMENT = ',G15.7)
C
C   continue with constants
C
      T = TEMP / ONEHUN
      IF ( X .LE. SIXTEN ) THEN
         DO 10 NTERM1 = 23 , 0 , -1
            IF ( ABS(ARJ01(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      XLOW = SQRT ( TWELVE * TEMP )
      ELSE
         DO 40 NTERM2 = 21 , 0 , -1
            IF ( ABS(ARJ0A1(NTERM2)) .GT. T ) GOTO 49
 40      CONTINUE
 49      DO 50 NTERM3 = 18 , 0 , -1
            IF ( ABS(ARJ0A2(NTERM3)) .GT. T ) GOTO 59
 50      CONTINUE
 59      CONTINUE
      ENDIF
C
C   Code for 0 <= |x| <= 16
C
      IF ( X .LE. SIXTEN ) THEN
         IF ( X .LT. XLOW ) THEN
            J0INT = X
         ELSE
            T = X * X / ONE28 - ONE
            J0INT = X * CHEVAL(NTERM1,ARJ01,T)
         ENDIF
      ELSE
C
C   Code for |x| > 16
C
         T = FIVE12 / ( X * X ) - ONE
         PIB41 = PIB411 / PIB412
         XMPI4 = ( X - PIB41 ) - PIB42
         TEMP = COS(XMPI4) * CHEVAL(NTERM2,ARJ0A1,T) / X
         TEMP = TEMP - SIN(XMPI4) * CHEVAL(NTERM3,ARJ0A2,T)
         J0INT = ONE - RT2BPI * TEMP / SQRT(X)
      ENDIF
      IF ( IND .EQ. -1 ) J0INT = -J0INT
      RETURN
      END
      SUBROUTINE JACELL(AX,AMC,SNR,CNR,DNR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBIAN ELLIPTIC
C              FUNCTIONS.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AMC    = THE SINGLE PRECISION VALUE FOR THE
C                                PARAMETER OF THE FUNCTIONS
C     OUTPUT ARGUMENTS--SN     = THE SINGLE PRECISION VALUE OF THE SN
C                                FUNCTION.
C                     --CN     = THE SINGLE PRECISION VALUE OF THE CN
C                                FUNCTION.
C                     --DN     = THE SINGLE PRECISION VALUE OF THE DN
C                                FUNCTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C                 ELLIPTIC FUNCTIONS", BULIRSCH, NUMERISCHE MATHEMATIK,
C                 VOL. 7, PP. 78-90, 1965.
C                 THE ROUTINE HERE IS A FORTRAN TRANSLATION OF THE
C                 ALGOL-60 CODE GIVEN IN THE REFERENCE.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--NOVEMBER   1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      PARAMETER (MAXELE=13)
      LOGICAL B0
      DOUBLE PRECISION AM(MAXELE)
      DOUBLE PRECISION AN(MAXELE)
      DOUBLE PRECISION MC, C1, CA, X, A, B, C, D
      DOUBLE PRECISION SN, DN, CN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
      DATA C1 / 3.96825396825D-4/
      DATA CA / 0.0001D0 /
C
C---------------------------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
      X=DBLE(AX)
      MC=DBLE(AMC)
      DO10I=1,MAXELE
        AN(I)=0.0D0
        AM(I)=0.0D0
 10   CONTINUE
C
      IF(MC.EQ.0.0D0)GOTO1000
      B0=.TRUE.
      IF(MC.LT.0.0D0)THEN
        B0=.TRUE.
      ELSE
        B0=.FALSE.
      ENDIF
      IF(B0)THEN
        D=1.0D0-MC
        MC=-MC/D
        D=SQRT(D)
        X=D*X
      ENDIF
      DN=1.0D0
      A=1.0D0
      DO100I=1,MAXELE
        L=I
        AM(I)=A
        MC=DSQRT(MC)
        AN(I)=MC
        C=0.5D0*(A+MC)
        IF(DABS(A-MC).LE.CA*A)GOTO199
        MC=A*MC
        A=C
 100  CONTINUE
 199  CONTINUE
      X=C*X
      SN=DSIN(X)
      CN=DCOS(X)
      IF(SN.EQ.0.0D0)GOTO299
      A=CN/SN
      C=A*C
      DO200I=L,1,-1
        B=AM(I)
        A=C*A
        C=DN*C
        DN=(AN(I)+A)/(B+A)
        A=C/B
 200  CONTINUE
      A=1.0D0/DSQRT(C*C+1.0D0)
      IF(SN.LT.0.0D0)THEN
        SN=-A
      ELSE
        SN=A
      ENDIF
      CN=C*SN
 299  CONTINUE
      IF(B0)THEN
        A=DN
        DN=CN
        CN=A
        SN=SN/D
      ENDIF
      GOTO9999
C
 1000 CONTINUE
      D=DEXP(X)
      A=1.0D0/D
      B=A+D
      CN=2.0D0/B
      DN=2.0D0/B
      IF(DABS(X).LT.0.3D0)THEN
        D=X*X*X
        SN=CN*(D*((1.0D0/3.0D0)+D*X*C1)+DSIN(X))
      ELSE
        SN=(D-A)/B
      ENDIF
      GOTO9999
C
 9999 CONTINUE
      SNR=SNGL(SN)
      CNR=SNGL(CN)
      DNR=SNGL(DN)
      RETURN
      END
      SUBROUTINE JACKIN(A1,A2,IWRITE,
     1Y3,N3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--GENERATE A JACKNIFE INDEX
C              THIS WILL BE SEQUENCE 1 1 N WITH A SINGLE ELEMENT
C              DELETED
C     INPUT  ARGUMENTS--A1     =  ELEMENT TO DELETE
C                     --A2     =  SIZE OF SEQUENCE
C     OUTPUT ARGUMENTS--Y3     =  JACKNIFE INDEX
C
C      NOTE--IF A2 IS SMALLER THAN 1 OR LARGER THAN A1,
C            THEN THIS WILL BE INTERPRETED AS A NON-OPERATION.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--93/10
C     ORIGINAL VERSION--OCTOBER  1993.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='JACK'
      ISUBN2='IN  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'CKIN')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)A1,A2
   53 FORMAT('A1,A2 = ',2F8.2)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               *************************************
C               **  CONSTRUCT A   JACKNIFE INDEX   **
C               *************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      NSKIP=INT(A1+0.5)
      N1=INT(A2+0.5)
      IF(NSKIP.LT.1.OR.NSKIP.GT.N1)GOTO1110
      GOTO1119
C
 1110 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1111)
 1111 FORMAT('***** ERROR IN JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1112)
 1112 FORMAT('      THE ELEMENT TO SKIP MUST BE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1113)N1
 1113 FORMAT('      BETWEEN 1 AND ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1116)
 1116 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1117)NSKIP
 1117 FORMAT('      THE ELEMENT TO SKIP IS = ',I8,'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
 1119 CONTINUE
C
      DO1300I=1,N1
      Y3(I)=REAL(I)
 1300 CONTINUE
      Y3(NSKIP)=0.0
      N3=N1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'PARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF JACKIN--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,9017)N1,N2,N3
C9017 FORMAT('N1,N2,N3 = ',3I8)
      WRITE(ICOUT,9017)N1,N3
 9017 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      IF(N3.LE.0)GOTO9043
      DO9041I=1,N3
      WRITE(ICOUT,9042)I,Y3(I)
 9042 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE JACOBP(DEGREE,ALFA,BETA,X,F,FD,E,ED,FLAGF,FLAGD)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBI
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--DEGREE = THE INTEGER VALUE FOR THE ORDER OF
C                                THE POLYNOMIAL
C                       ALPHA  = THE DOUBLE PRECISION VALUE FOR THE
C                                FIRST SHAPE PARAMETER
C                       BETA   = THE DOUBLE PRECISION VALUE FOR THE
C                                SECOND SHAPE PARAMETER
C                       X      = THE DOUBLE PRECISION VALUE FOR THE
C                                INPUT ARGUMENT
C     OUTPUT ARGUMENTS--F      = THE DOUBLE PRECISION VALUE OF THE
C                                JACOBI POLYNOMIAL.
C                       FD     = THE DOUBLE PRECISION VALUE OF THE
C                                DERIVATIVE OF THE JACOBI POLYNOMIAL.
C                       E      = THE SINGLE PRECISION VALUE OF THE
C                                RELATIVE ERROR OF F
C                       ED     = THE SINGLE PRECISION VALUE OF THE
C                                RELATIVE ERROR OF FD
C                       FLAGF  = THE INTEGER VALUE WHICH SPECIFIES
C                                WHETHER F IS RELATIVE OR ABSOLUTE ERROR
C                       FLAGD  = THE INTEGER VALUE WHICH SPECIFIES
C                                WHETHER FD IS RELATIVE OR ABSOLUTE ERROR
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 "ALGORITHM 332.  JACOBI POLYNOMIALS", WITTE,
C                 COMMUNICATIONS OF THE ACM, VOL. 11, 1968.
C                 FOLLOWING CODE USES ACM ALGORTHM 332
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C
      DOUBLE PRECISION A, ALF, ALFA, B, BET, BETA
      DOUBLE PRECISION C, D, F, FD, G, H, P, PD, Q, QD
      DOUBLE PRECISION T1, T2, U, V, W, X
C
      REAL E, ED, EG, E1, E2, S, Y
C
      INTEGER I, J, K, M, N, DEGREE, FLAGF, FLAGD
C
      DIMENSION U(25), V(25), W(25), P(25), PD(25), Q(25), QD(25)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA M /-2/
      DATA ALF /-2.0D0/
      DATA BET /-2.0D0/
CCCCC DATA Y /3.0E-26/
      DATA RMXINT /134217727. /
C
C-----START POINT-----------------------------------------------------
C
CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN
CCCCC   WRITE(ICOUT,104)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
CC104 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
CCCCC1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****')
CCC46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      IF(DEGREE.LT.0 .OR. DEGREE.GT.25)THEN
        WRITE(ICOUT,106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO12
      ENDIF
  106 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (0,25) INTERVAL *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      CALL SPDIV(RMXINT,2.0,IND,RESULT)
      ETA=RESULT+1.0
      CALL SPDIV(1.0,ETA,IND,ETA)
      Y=ETA
C
      IF(DEGREE.EQ.0)THEN
        F=1.0D0
        E=0.0
        FD=0.0D0
        ED=0.0
        FLAGF=2
        FLAGD=2
        GOTO12
      ENDIF
C
C  CALCULATE THE U(J), V(J), W(J), IN THE RECURRENCE RELATION.
C  P(J) = P(J-1)*(U(J)+V(J)*X)-P(J-2)*W(J)
C
      M = DEGREE
      ALF = ALFA
      BET = BETA
      A = ALF+BET
      B = ALF-BET
      U(1) = B/2.0D0
      V(1) = 1.0D0+A/2.0D0
      W(1) = 0.0D0
C
      IF(DEGREE.EQ.1)GOTO5
C
      U(2) = A*B*(A+3.0D0)/(4.0D0*(A+2.0D0)**2)
      V(2) = (A+3.0D0)*(A+4.0D0)/(4.0D0*(A+2.0D0))
      W(2) = (1.0D0 + ALF)*(1.0D0 + BET)*(A+4.0D0)
      W(2) = W(2)/(2.0D0*(A+2.0D0)**2)
      I = 2
      K = DEGREE - 1
C
      IF((DEGREE.EQ.2) .OR. (I.GT.K))GOTO5
C
      DO4J=I,K
        A = DBLE(2*J+2)
        D = ALF+BET
        A = A+D
        B = D*(A-1.0D0)*(ALF-BET)
        C = DBLE(J+1)
        C = 2.0D0*C*(A-2.0D0)*(C+D)
        U(J+1) = B/C
        D = A*(A-1.0D0)*(A-2.0D0)
        V(J+1) = D/C
        D = J
        A = 2.0D0*(D+ALF)*(D+BET)*A
        W(J+1) = A/C
    4 CONTINUE
C
C  FIND THE STARTING VALUES FOR J=1 AND J=2 FOR USE IN THE RECURSION.
C
    5 CONTINUE
      T1 = V(1)*X
      P(1) = U(1)+T1
      S = Y*DMAX1(DABS(U(1)),DABS(T1))
      Q(1) = P(1)+S
      PD(1) = V(1)
      QD(1) = V(1)
C
      IF(DEGREE.EQ.1)GOTO7
C
      T1 = V(2)*X
      G = U(2)+T1
      EG = Y*DMAX1(DABS(U(2)),DABS(T1))
      H = G+EG
      T1 = G*P(1)
      E1 = DABS(EG*P(1))
      P(2) = T1 - W(2)
      S = Y*DABS(W(2))
      S = AMAX1(E1,S)
      Q(2) = H*Q(1)-W(2)+S
      PD(2) = G*PD(1)+V(2)*P(1)
      QD(2) = H*QD(1)+V(2)*Q(1)
C
      IF(DEGREE.EQ.2)GOTO7
C
C  USE THE RECURSION
C
      DO6J=3,DEGREE
        T2 = V(J)*X
        G = U(J)+T2
        EG = Y*DMAX1(DABS(U(J)),DABS(T2))
        H = G+EG
        T1 = G*P(J-1)
        T2 = W(J)*P(J-2)
        E1 = DABS(EG*P(J-1))
        E2 = DABS(T2)*Y
        P(J) = T1 - T2
        S = AMAX1(E1,E2)
        Q(J) = H*Q(J-1)-W(J)*Q(J-2)+S
        PD(J) = G*PD(J-1)-W(J)*PD(J-2)
        QD(J) = H*QD(J-1)-W(J)*QD(J-2)
        PD(J) = PD(J)+V(J)*P(J-1)
        QD(J) = QD(J)+V(J)*Q(J-1)
    6 CONTINUE
C
C  PREPARE THE OUTPUT
C
    7 CONTINUE
      N = DEGREE
      F = P(N)
      IF(DABS(F).LT.Y)THEN
        E=DABS(F-Q(N))
        FLAGF = 1
      ELSE
        E=DABS(1.0D0-Q(N)/F)
        FLAGF = 0
      ENDIF
      FD = PD(N)
      IF(DABS(FD).LT.Y)THEN
        ED=DABS(FD-QD(N))
        FLAGD=1
      ELSE
        ED=DABS(1.0D0-QD(N)/FD)
        FLAGD=0
      ENDIF
      GOTO12
C
   12 CONTINUE
      RETURN
      END
      SUBROUTINE JAIRY (X, RX, C, AI, DAI)
C***BEGIN PROLOGUE  JAIRY
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESJ and BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (JAIRY-S, DJAIRY-D)
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C           Weston, M. K., (SNLA)
C***DESCRIPTION
C
C                  JAIRY computes the Airy function AI(X)
C                   and its derivative DAI(X) for ASYJY
C
C                                   INPUT
C
C         X - Argument, computed by ASYJY, X unrestricted
C        RX - RX=SQRT(ABS(X)), computed by ASYJY
C         C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY
C
C                                  OUTPUT
C
C        AI - Value of function AI(X)
C       DAI - Value of the derivative DAI(X)
C
C***SEE ALSO  BESJ, BESY
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  JAIRY
C
      INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2,
     1 N2D, N3, N3D, N4, N4D
      REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3,
     1 CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC,
     2 E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X
      DIMENSION AJP(19), AJN(19), A(15), B(15)
      DIMENSION AK1(14), AK2(23), AK3(14)
      DIMENSION DAJP(19), DAJN(19), DA(15), DB(15)
      DIMENSION DAK1(14), DAK2(24), DAK3(14)
      SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2,
     1 CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B,
     2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D,
     3 DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB
      DATA N1,N2,N3,N4/14,23,19,15/
      DATA M1,M2,M3,M4/12,21,17,13/
      DATA FPI12,CON2,CON3,CON4,CON5/
     1 1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01,
     2 8.33333333333333E-01, 8.66025403784439E-01/
      DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7),
     1     AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13),
     2     AK1(14)         / 2.20423090987793E-01,-1.25290242787700E-01,
     3 1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04,
     4 1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07,
     5 8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11,
     6 2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/
      DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7),
     1     AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14),
     2     AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21),
     3     AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03,
     4-1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04,
     5 2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06,
     6-4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08,
     7 7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10,
     8-1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12,
     9 2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13,
     1-4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/
      DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7),
     1     AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13),
     2     AK3(14)         / 2.80271447340791E-01,-1.78127042844379E-03,
     3 4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08,
     4-6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11,
     5 5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14,
     6-1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/
      DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7),
     1     AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14),
     2     AJP(15),AJP(16),AJP(17),AJP(18),
     3     AJP(19)         / 7.78952966437581E-02,-1.84356363456801E-01,
     4 3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03,
     5-1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05,
     6-6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08,
     7 1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11,
     8 8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14,
     9-3.29810288929615E-15, 2.35798252031104E-16/
      DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7),
     1     AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14),
     2     AJN(15),AJN(16),AJN(17),AJN(18),
     3     AJN(19)         / 3.80497887617242E-02,-2.45319541845546E-01,
     4 1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02,
     5-5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04,
     6-4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07,
     7 6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10,
     8 7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13,
     9-2.67762710389189E-14, 2.36161316570019E-15/
      DATA A(1),   A(2),   A(3),   A(4),   A(5),   A(6),   A(7),
     1     A(8),   A(9),   A(10),  A(11),  A(12),  A(13),  A(14),
     2     A(15)           / 4.90275424742791E-01, 1.57647277946204E-03,
     3-9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07,
     4-1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10,
     5-2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13,
     6-1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15,
     7-9.99003874810259E-16/
      DATA B(1),   B(2),   B(3),   B(4),   B(5),   B(6),   B(7),
     1     B(8),   B(9),   B(10),  B(11),  B(12),  B(13),  B(14),
     2     B(15)           / 2.78593552803079E-01,-3.52915691882584E-03,
     3-2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07,
     4-2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11,
     5-3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13,
     6-1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15,
     7-3.32656311696166E-16/
      DATA N1D,N2D,N3D,N4D/14,24,19,15/
      DATA M1D,M2D,M3D,M4D/12,22,17,13/
      DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6),
     1     DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12),
     2    DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02,
     3-8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04,
     4-6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07,
     5-5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11,
     6 4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/
      DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6),
     1     DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12),
     2     DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18),
     3     DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23),
     4     DAK2(24)        / 2.93332343883230E-01,-8.06196784743112E-03,
     5 2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04,
     6-4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06,
     7 9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08,
     8-1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09,
     9 3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11,
     1-6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13,
     2 1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15,
     3-2.62786914342292E-15/
      DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6),
     1     DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12),
     2    DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03,
     3-4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07,
     4 7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11,
     5-5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14,
     6 1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/
      DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6),
     1     DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12),
     2     DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18),
     3     DAJP(19)        / 6.53219131311457E-02,-1.20262933688823E-01,
     4 9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03,
     5-8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05,
     6-2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08,
     7 4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11,
     8 2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14,
     9-1.12604374485125E-15, 7.31327529515367E-17/
      DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6),
     1     DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12),
     2     DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18),
     3     DAJN(19)        / 1.08594539632967E-02, 8.53313194857091E-02,
     4-3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02,
     5 9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04,
     6 1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06,
     7-1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09,
     8-2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12,
     9 7.39400971155740E-14,-7.32887475627500E-15/
      DATA DA(1),  DA(2),  DA(3),  DA(4),  DA(5),  DA(6),  DA(7),
     1     DA(8),  DA(9),  DA(10), DA(11), DA(12), DA(13), DA(14),
     2     DA(15)          / 4.91627321104601E-01, 3.11164930427489E-03,
     3 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08,
     4 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10,
     5 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13,
     6 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16,
     7 8.17900786477396E-16/
      DATA DB(1),  DB(2),  DB(3),  DB(4),  DB(5),  DB(6),  DB(7),
     1     DB(8),  DB(9),  DB(10), DB(11), DB(12), DB(13), DB(14),
     2     DB(15)          /-2.77571356944231E-01, 4.44212833419920E-03,
     3-8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07,
     4-6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10,
     5-4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13,
     6-4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15,
     7-7.11793337579530E-16/
C***FIRST EXECUTABLE STATEMENT  JAIRY
      IF (X.LT.0.0E0) GO TO 90
      IF (C.GT.5.0E0) GO TO 60
      IF (X.GT.1.20E0) GO TO 30
      T = (X+X-1.2E0)*CON4
      TT = T + T
      J = N1
      F1 = AK1(J)
      F2 = 0.0E0
      DO 10 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK1(J)
        F2 = TEMP1
   10 CONTINUE
      AI = T*F1 - F2 + AK1(1)
C
      J = N1D
      F1 = DAK1(J)
      F2 = 0.0E0
      DO 20 I=1,M1D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK1(J)
        F2 = TEMP1
   20 CONTINUE
      DAI = -(T*F1-F2+DAK1(1))
      RETURN
C
   30 CONTINUE
      T = (X+X-CON2)*CON3
      TT = T + T
      J = N2
      F1 = AK2(J)
      F2 = 0.0E0
      DO 40 I=1,M2
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK2(J)
        F2 = TEMP1
   40 CONTINUE
      RTRX = SQRT(RX)
      EC = EXP(-C)
      AI = EC*(T*F1-F2+AK2(1))/RTRX
      J = N2D
      F1 = DAK2(J)
      F2 = 0.0E0
      DO 50 I=1,M2D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK2(J)
        F2 = TEMP1
   50 CONTINUE
      DAI = -EC*(T*F1-F2+DAK2(1))*RTRX
      RETURN
C
   60 CONTINUE
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N1
      F1 = AK3(J)
      F2 = 0.0E0
      DO 70 I=1,M1
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + AK3(J)
        F2 = TEMP1
   70 CONTINUE
      RTRX = SQRT(RX)
      EC = EXP(-C)
      AI = EC*(T*F1-F2+AK3(1))/RTRX
      J = N1D
      F1 = DAK3(J)
      F2 = 0.0E0
      DO 80 I=1,M1D
        J = J - 1
        TEMP1 = F1
        F1 = TT*F1 - F2 + DAK3(J)
        F2 = TEMP1
   80 CONTINUE
      DAI = -RTRX*EC*(T*F1-F2+DAK3(1))
      RETURN
C
   90 CONTINUE
      IF (C.GT.5.0E0) GO TO 120
      T = 0.4E0*C - 1.0E0
      TT = T + T
      J = N3
      F1 = AJP(J)
      E1 = AJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 100 I=1,M3
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + AJP(J)
        E1 = TT*E1 - E2 + AJN(J)
        F2 = TEMP1
        E2 = TEMP2
  100 CONTINUE
      AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1))
      J = N3D
      F1 = DAJP(J)
      E1 = DAJN(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 110 I=1,M3D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DAJP(J)
        E1 = TT*E1 - E2 + DAJN(J)
        F2 = TEMP1
        E2 = TEMP2
  110 CONTINUE
      DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1))
      RETURN
C
  120 CONTINUE
      T = 10.0E0/C - 1.0E0
      TT = T + T
      J = N4
      F1 = A(J)
      E1 = B(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 130 I=1,M4
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + A(J)
        E1 = TT*E1 - E2 + B(J)
        F2 = TEMP1
        E2 = TEMP2
  130 CONTINUE
      TEMP1 = T*F1 - F2 + A(1)
      TEMP2 = T*E1 - E2 + B(1)
      RTRX = SQRT(RX)
      CV = C - FPI12
      CCV = COS(CV)
      SCV = SIN(CV)
      AI = (TEMP1*CCV-TEMP2*SCV)/RTRX
      J = N4D
      F1 = DA(J)
      E1 = DB(J)
      F2 = 0.0E0
      E2 = 0.0E0
      DO 140 I=1,M4D
        J = J - 1
        TEMP1 = F1
        TEMP2 = E1
        F1 = TT*F1 - F2 + DA(J)
        E1 = TT*E1 - E2 + DB(J)
        F2 = TEMP1
        E2 = TEMP2
  140 CONTINUE
      TEMP1 = T*F1 - F2 + DA(1)
      TEMP2 = T*E1 - E2 + DB(1)
      E1 = CCV*CON5 + 0.5E0*SCV
      E2 = SCV*CON5 - 0.5E0*CCV
      DAI = (TEMP1*E1-TEMP2*E2)*RTRX
      RETURN
      END
      SUBROUTINE JNSN(XBAR, SD, RB1, BB2, ITYPE, GAMMA, DELTA,
     $  XLAM, XI, IFAULT)
CSTART OF AS 99
C
C        ALGORITHM AS 99  APPL. STATIST. (1976) VOL.25, P.180
C
C        FINDS TYPE AND PARAMETERS OF A JOHNSON CURVE
C        WITH GIVEN FIRST FOUR MOMENTS
C
      REAL XBAR, SD, RB1, BB2, GAMMA, DELTA, XLAM, XI, TOL,
     $  B1, B2, Y, X, U, W, ZERO, ONE, TWO, THREE, FOUR, HALF,
     $  QUART, ZABS, ZEXP, ZLOG, ZSIGN, ZSQRT
      LOGICAL FAULT
C
      DATA TOL /0.01/
      DATA ZERO, QUART, HALF, ONE, TWO, THREE, FOUR
     $     /0.0,  0.25,  0.5, 1.0, 2.0,   3.0,  4.0/
C
      ZABS(X) = ABS(X)
      ZEXP(X) = EXP(X)
      ZLOG(X) = LOG(X)
      ZSIGN(X, Y) = SIGN(X, Y)
      ZSQRT(X) = SQRT(X)
C
      IFAULT = 1
      IF (SD .LT. ZERO) RETURN
      IFAULT = 0
      XI = ZERO
      XLAM = ZERO
      GAMMA = ZERO
      DELTA = ZERO
      IF (SD .GT. ZERO) GOTO 10
      ITYPE = 5
      XI = XBAR
      RETURN
   10 B1 = RB1 * RB1
      B2 = BB2
      FAULT = .FALSE.
C
C        TEST WHETHER LOGNORMAL (OR NORMAL) REQUESTED
C
      IF (B2 .GE. ZERO) GOTO 30
   20 IF (ZABS(RB1) .LE. TOL) GOTO 70
      GOTO 80
C
C        TEST FOR POSITION RELATIVE TO BOUNDARY LINE
C
   30 IF (B2 .GT. B1 + TOL + ONE) GOTO 60
      IF (B2 .LT. B1 + ONE) GOTO 50
C
C        ST DISTRIBUTION
C
   40 ITYPE = 5
      Y = HALF + HALF * ZSQRT(ONE - FOUR / (B1 + FOUR))
      IF (RB1 .GT. ZERO) Y = ONE - Y
      X = SD / ZSQRT(Y * (ONE - Y))
      XI = XBAR - Y * X
      XLAM = XI + X
      DELTA = Y
      RETURN
   50 IFAULT = 2
      RETURN
   60 IF (ZABS(RB1) .GT. TOL .OR. ZABS(B2 - THREE) .GT. TOL) GOTO 80
C
C        NORMAL DISTRIBUTION
C
   70 ITYPE = 4
      DELTA = ONE / SD
      GAMMA = -XBAR / SD
      RETURN
C
C        TEST FOR POSITION RELATIVE TO LOGNORMAL LINE
C
   80 X = HALF * B1 + ONE
      Y = ZABS(RB1) * ZSQRT(QUART * B1 + ONE)
      U = (X + Y) ** (ONE / THREE)
      W = U + ONE / U - ONE
      U = W * W * (THREE + W * (TWO + W)) - THREE
      IF (B2 .LT. ZERO .OR. FAULT) B2 = U
      X = U - B2
      IF (ZABS(X) .GT. TOL) GOTO 90
C
C        LOGNORMAL (SL) DISTRIBUTION
C
      ITYPE = 1
      XLAM = ZSIGN(ONE, RB1)
      U = XLAM * XBAR
      X = ONE / ZSQRT(ZLOG(W))
      DELTA = X
      Y = HALF * X * ZLOG(W * (W - ONE) / (SD * SD))
      GAMMA = Y
      XI = XLAM * (U - ZEXP((HALF / X - Y) / X))
      RETURN
C
C        SB OR SU DISTRIBUTION
C
   90 IF (X .GT. ZERO) GOTO 100
      ITYPE = 2
      CALL SUFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI)
      RETURN
  100 ITYPE = 3
      CALL SBFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI, FAULT)
      IF (.NOT. FAULT) RETURN
C
C        FAILURE - TRY TO FIT APPROXIMATE RESULT
C
      IFAULT = 3
      IF (B2 .GT. B1 + TWO) GOTO 20
      GOTO 40
      END
      SUBROUTINE JITTER(X,NX,DELTA,Y,NY,ISEED,IBUGA3,IERROR)
C
C     PURPOSE--JITTER A UNIVARIATE VARIABLE.  THAT IS, ADD A
C              UNIFORM RANDOM NUMBER (D DEFINES THE SCALE FOR
C              THIS RANDOM NUMBER).  THIS CAN BE HELPFUL IN
C              AVOIDING "OVERPLOTTING" ON CERTAIN TYPES OF
C              PLOTS.
C     NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.)
C           BEING IDENTICAL TO THE INPUT VECTOR X(.).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      REAL XTEMP(1)
C
C-----COMMON---------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='JITT'
      ISUBN2='ER  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF JITTER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)NX,DELTA,IBUGA3
   53   FORMAT('NX,DELTA,IBUGA3 = ',I8,G15.7,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MAX(100,NX)
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ********************************
C               **  STEP 1--                  **
C               **  COMPUTE JITTERED VALUES   **
C               ********************************
C
      IF(NX.LT.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,151)
  151   FORMAT('***** ERROR IN JITTER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,152)
  152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,154)
  154   FORMAT('      VARIABLE FOR WHICH THE DISTINCT VALUES ARE TO')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,155)
  155   FORMAT('      BE FOUND MUST BE 1 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,156)
  156   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,157)NX
  157   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      DELTA=ABS(DELTA)
      NTEMP=1
      IF(DELTA.EQ.0.0)DELTA=1.0
      DO100I=1,NX
        CALL UNIRAN(NTEMP,ISEED,XTEMP)
        XTEMP(1)=DELTA*XTEMP(1)
        ALOC=-DELTA/2.0
        ATEMP= ALOC + DELTA*XTEMP(1)
        Y(I)=X(I) + ATEMP
  100 CONTINUE
      NY=NX
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF JITTER--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO9015I=1,MAX(NY,100)
          WRITE(ICOUT,9016)I,X(I),Y(I)
 9016     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9015   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE JOIN(Y1,X1,Y2,N1,Y3,X3,TAG3,N3,MAXOBV,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--GIVEN AN (X,Y) VECTOR AND AN INDEX VARIABLE OF THE SAME
C              LENGTH, CREATE AN OUTPUT VARIABLE WHERE EACH ROW OF THE
C              (X,Y) VECTOR IS CONNECTED TO THE ROW SPECIFIED BY THE
C              INDEX VARIABLE.
C
C              THIS COMMAND IS TYPICALLY USED TO PLOT 2-D NEAREST
C              NEIGHBORS.  THAT IS, NEAREST NEIGHBORS CAN BE PLOTTED
C              WITH THE FOLLOWING SEQUENCE OF COMMANDS:
C
C                  LET INDX = NEAREST NEIGHBOR X Y
C                  LET X3 Y3 TAG3 = JOIN X Y INDX
C                  PLOT Y3 X3 TAG3
C
C     INPUT  ARGUMENTS--X1 (REAL)
C                     --Y1 (REAL)
C                     --Y2 (REAL)
C     OUTPUT ARGUMENTS--Y3 (REAL)
C                     --X3 (REAL)
C                     --TAG3 (REAL)
C
C     WRITTEN BY--ALAN HECKERT
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--2013/8
C     ORIGINAL VERSION--AUGUST     2013
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      REAL X1(*)
      REAL Y1(*)
      REAL Y2(*)
      REAL X3(*)
      REAL Y3(*)
      REAL TAG3(*)
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IERROR='NO'
      N3=0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JOIN')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF JOIN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,MAXOBV
   52   FORMAT('IBUGA3,ISUBRO,N1,MAXOBV = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N1
          WRITE(ICOUT,56)I,X1(I),Y1(I),Y2(I)
   56     FORMAT('I,X1(I),Y1(I),Y2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1151)
 1151   FORMAT('***** ERROR IN JOIN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1152)
 1152   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IS LESS THAN ',
     1         'ONE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1154)N1
 1154   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ************************************************
C               **  STEP 2--                                  **
C               **  NOW GENERATED THE JOINED VECTOR           **
C               ************************************************
C
      ICNT1=0
      ICNT2=0
      DO2000K=1,N1
        IINDX=INT(Y2(K)+0.5)
        IF(IINDX.LT.1 .OR. IINDX.GT.N1)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1151)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2011)K
 2011     FORMAT('      ROW ',I8,' OF THE INDEX VARIABLE IS LESS THAN ',
     1           '1 OR')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2013)N1
 2013     FORMAT('      GREATER THAN ',I8,'.  IT HAS THE VALUE ',I8)
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        ICNT1=ICNT1+1
        IF(ICNT1.GT.MAXOBV)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1151)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2111)
 2111     FORMAT('      THE NUMBER OF ROWS IN THE OUTPUT VARIABLE ',
     1           'HAS EXCEEDED ')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2113)MAXOBV
 2113     FORMAT('      THE MAXIMUM ALLOWABLE OF ',I8,'.')
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        ICNT2=ICNT2+1
        X3(ICNT1)=X1(K)
        Y3(ICNT1)=Y1(K)
        TAG3(ICNT1)=REAL(ICNT2)
        ICNT1=ICNT1+1
        IF(ICNT1.GT.MAXOBV)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1151)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2111)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,2113)MAXOBV
          CALL DPWRST('XXX','BUG ')
          IERROR='YES'
          GOTO9000
        ENDIF
        X3(ICNT1)=X1(IINDX)
        Y3(ICNT1)=Y1(IINDX)
        TAG3(ICNT1)=REAL(ICNT2)
 2000 CONTINUE
      N3=ICNT1
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JOIN')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF JOIN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,N3
 9013   FORMAT('IERROR,N3 = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO9021I=1,N3
          WRITE(ICOUT,9022)I,X3(I),Y3(I),TAG3(I)
 9022     FORMAT('I,X3(I),Y3(I),TAG3(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
 9021   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE JSBCDF(X,ALPHA1,ALPHA2,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X/(1-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE JOHNSON SB
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(X.GE.1.0)THEN
        CDF=1.0
        GOTO9000
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBCDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      ARG=ALPHA1 + ALPHA2*LOG(X/(1.0-X))
      DARG=DBLE(ARG)
      CALL NODCDF(DARG,DCDF)
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSBPDF(X,ALPHA1,ALPHA2,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = (ALPHA2/(X*(1-X))*
C                     NORPDF(ALPHA1 + ALPHA2*LOG(X/(1-X))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE JOHNSON SB
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0 .OR. X.GE.1.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPDF ')
    5 FORMAT('      SUBROUTINE IS OUTSIDE THE (0,1) INTERVAL.')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      ARG=ALPHA1 + ALPHA2*LOG(X/(1.0-X))
      DARG=DBLE(ARG)
      CALL NODPDF(DARG,DPDF)
      DX=DBLE(X)
      DPDF=(DBLE(ALPHA2)/(DX*(1.0D0-DX)))*DPDF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSBPPF(P,ALPHA1,ALPHA2,PPF)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DALPH1
      DOUBLE PRECISION DALPH2
      DOUBLE PRECISION DX
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DP
      DOUBLE PRECISION EPS
      DOUBLE PRECISION SIG
      DOUBLE PRECISION ZERO
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION AB
      DOUBLE PRECISION XL
      DOUBLE PRECISION XR
      DOUBLE PRECISION XRML
      DOUBLE PRECISION FXL
      DOUBLE PRECISION FXR
      DOUBLE PRECISION FCS
C
C-----COMMON-------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /1.0D-6/
      DATA SIG /1.0D-5/
      DATA ZERO /0.D0/
      DATA MAXIT /3000/
C
C-----START POINT---------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=1.0
        GOTO9999
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPPF ')
    5 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPPF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      A = ALPHA1
      B = ALPHA2
      DP = DBLE(P)
C
      IERR=0
      IC = 0
      AB = A/B
      XL = 0.0D0
      XR = 1.0D0
      FXL = -DP
      FXR = 1.0D0 - DP
C
      IF(FXL*FXR .GT. ZERO)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
C  BISECTION METHOD
C
  105 CONTINUE
      DX = (XL+XR)*0.5D0
      DALPH1=DBLE(A)
      DALPH2=DBLE(B)
      DARG=DALPH1 + DALPH2*DLOG(DX/(1.0D0-DX))
      CALL NODCDF(DARG,DCDF)
      P1=DCDF
      PPF=REAL(DX)
C
      FCS = P1 - DP
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = DX
      FXR = FCS
      GOTO115
  110 CONTINUE
      XL = DX
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** FATAL ERROR--JSBPPF ROUTINE DID NOT CONVERGE. ',
     1       '***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE JSBRAN(N,ALPHA1,ALPHA2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE JOHNSON SB DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA1  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA1 SHOULD BE POSITIVE.
C                     --ALPHA2  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                ALPHA2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE JOHNSON SB DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA2 SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'JSBRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N STANDARD NORMAL RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
C     GENERATE N JOHNSON SB DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM AS100.
C
      ITYPE=3
      ALOC=0.0
      SCALE=1.0
      DO100I=1,N
        XTEMP=X(I)
        XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT)
        X(I)=XTEMP2
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSCORE(Z,ROUND,N,IWRITE,XIDTEM,TEMP1,Y,NY,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JSCORE STATISTIC.
C              THIS IS USED IN ISO 13528 TYPE PROFICIENCY STUDIES.
C              THE INPUT IS ASSUMED TO BE A SERIES OF Z-SCORES
C              (THE ISO 13528 DEFINES MULTIPLE WAYS FOR COMPUTING
C              THE Z-SCORES, SO THIS COMMAND ASSUMES THAT THE INPUT
C              DATA IS ALREADY A Z-SCORE).
C
C              THE J-SCORE IS TYPICALLY DEFINED AS:
C
C                  IF  +3 <= Z          THEN J =  8
C                  IF  +2 <= Z <  +3    THEN J =  4
C                  IF  +1 <= Z <  +2    THEN J =  2
C                  IF  -1 <  Z <  +1    THEN J =  0
C                  IF  -2 <  Z <= -1    THEN J = -2
C                  IF  -3 <  Z <= -2    THEN J = -4
C                  IF  -3 <= Z          THEN J = -8
C
C              Z-SCORES ARE TYPICALLY COMPUTED OVER ONE OR MORE
C              MATERIALS AND ONE OR MORE ROUNDS.  J-SCORES ARE
C              TYPICALLY SUMMED OVER MULTIPLE ROUNDS UNTIL
C              ABS(JSCORE) >= 8.  THIS TYPICALLY TRIGGERS AN
C              ACTION SIGNAL AND THE J-SCORE IS RESET TO 0.
C              ALSO, WHEN SUCCESSIVE VALUES ARE OF DIFFERENT
C              SIGNS, THE JSCORE IS RESET TO 0.
C
C              THIS SUBROUTINE ASSUMES A SINGLE MATERIAL (I.E.,
C              WHEN THERE ARE MULTIPLE MATERIALS, THE DATA FOR A
C              SINGLE MATERIAL SHOULD BE EXTRACTED BEFORE CALLING
C              THIS ROUTINE).
C
C              IF THERE IS REPLICATION IN A ROUND, AN AVERAGE
C              Z-SCORE IS COMPUTED FOR THE ROUND BEFORE COMPUTING
C              THE J-SCORE.  ALTERNATIVELY, THE EXTREME Z-SCORE
C              CAN BE COMPUTED.
C
C              J-SCORES ARE TYPICALLY USED IN SHEWHART CONTROL
C              CHARTS AND ZONE PLOTS.
C
C     INPUT  ARGUMENTS--Z      = THE SINGLE PRECISION VECTOR OF
C                                Z-SCORES.
C                     --ROUND  = THE SINGLE PRECISION VECTOR THAT
C                                IDENTIFIES THE ROUND.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTORS Z AND ROUND.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED JSCORE VALUES (ONE FOR EACH
C                                DISTINCT ROUND).
C                     --NY     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE OUTPUT VECTOR Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE JSCORE VALUES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN, SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--THOMPSON, ELLISON, WOOD (2006), "THE INTERNATIONAL
C                 HARMONIZED PROTOCOL FOR THE PROFICIENCY TESTING OF
C                 ANALYTICAL CHEMISTRY LABORATORIES", PURE APPLIED
C                 CHEMISTRY, VOL. 78, NO. 1, PP. 145-196.
C     REFERENCES--ISO 13528, FIRST EDITION, STATISTICAL METHODS FOR USE
C                 IN PROFICIENCY TESTING BY INTERLABORATORY COMPARISONS,
C                 2005, PP. 27-28.
C     WRITTEN BY--ALAN HECKERT
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--2012.1
C     ORIGINAL VERSION--JANUARY   2012.
C     UPDATED         --OCTOBER   2015. WHEN THERE IS REPLICATION, ALLOW
C                                       EITHER AN AVERAGE OR AN EXTREME
C                                       Z-SCORE TO BE COMPUTED.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Z(*)
      DIMENSION Y(*)
      DIMENSION ROUND(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='JSCO'
      ISUBN2='RE  '
      IERROR='NO'
C
      ISIGN=-99
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CORE')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF JSCORE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,N
   52   FORMAT('IBUGA3,ISUBRO,IWRITE,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Z(I),ROUND(I)
   56     FORMAT('I,Z(I),ROUND(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN JSCORE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                     **
C               **  DETERMINE (AND SORT) THE UNIQUE VALUES FOR   **
C               **  ROUND-ID VARIABLE                            **
C               ****************************************************
C
      CALL DISTIN(ROUND,N,IWRITE,XIDTEM,NY,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NY,XIDTEM)
C
C               ***************************************************
C               **  STEP 3--                                     **
C               **  COMPUTE THE JSCORE FOR EACH ROUND            **
C               **    1) COMPUTE THE AVERAGE Z-SCORE FOR THE     **
C               **       ROUND.                                  **
C               **    2) COMPUTE THE JSCORE FOR THE ROUND.       **
C               ***************************************************
C
      AJ=0.0
      AJPREV=0.0
      SUM1=0.0
      EPS=0.000001
C
      DO110IR=1,NY
        HOLD1=XIDTEM(IR)
        K=0
        AMIN=CPUMAX
        AMAX=CPUMIN
        DO120J=1,N
          IF(ROUND(J).EQ.HOLD1)THEN
            K=K+1
            TEMP1(K)=Z(J)
          ENDIF
  120   CONTINUE
C
C       2015/10: SUPPORT FOLLOWING OPTIONS FOR THE CASE WHEN THERE
C                IS REPLICATION WITHIN A ROUND.
C
C                  1. TAKE THE AVERAGE OF THE Z-SCORES (THIS WAS THE
C                     PREVIOUSLY IMPLMENTED OPTION.
C                  2. TAKE THE MOST EXTREME Z-SCORE IN THE CELL.
C
CCCCC   ZSCORE=REAL(DSUM2/DBLE(K))
C
        IF(K.EQ.1)THEN
          ZSCORE=TEMP1(1)
        ELSE
          IF(IJSREP.EQ.'AVER')THEN
            CALL MEAN(TEMP1,K,IWRITE,ZSCORE,IBUGA3,IERROR)
          ELSEIF(IJSREP.EQ.'EXTR')THEN
            CALL MINIM(TEMP1,K,IWRITE,ZMIN,IBUGA3,IERROR)
            CALL MAXIM(TEMP1,K,IWRITE,ZMAX,IBUGA3,IERROR)
            ZSCORE=ZMIN
            IF(ABS(ZMAX).GT.ABS(ZMIN))ZSCORE=ZMAX
          ENDIF
        ENDIF
C
C       STEP 1: CONVERT Z-SCORE TO A NON-CUMULATIVE J-SCORE
C
        IF(ZSCORE.LE.-3.0)THEN
          AJSCOR=-8.0
        ELSEIF(ZSCORE.LE.-2.0)THEN
          AJSCOR=-4.0
        ELSEIF(ZSCORE.LE.-1.0)THEN
          AJSCOR=-2.0
        ELSEIF(ZSCORE.GE.3.0)THEN
          AJSCOR=8.0
        ELSEIF(ZSCORE.GE.2.0)THEN
          AJSCOR=4.0
        ELSEIF(ZSCORE.GE.1.0)THEN
          AJSCOR=2.0
        ELSE
          AJSCOR=0.0
          ISIGN=1
          IF(ZSCORE.LT.0.0)ISIGN=-1
        ENDIF
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CORE')THEN
          WRITE(ICOUT,211)IR,ZSCORE,AJSCOR
  211     FORMAT('STEP 1: IR,ZSCORE,AJSCOR = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
C       STEP 2: CONVERT NON-CUMULATIVE J-SCORE TO A CUMULATIVE J-SCORE
C
C               THERE ARE 2 SPECIAL CASES FOR THE CUMULAIVE Z-SCORE:
C
C                1) IF THE ABSOLUTE VALUE IS GREATER THAN 8, SET THE
C                   THE CURRENT J-SCORE TO 8 BUT RESET THE CUMULATIVE
C                   SUM TO 0.
C
C                2) IF THERE IS A CHANGE OF SIGN, SET THE CUMULATIVE
C                   J-SCORE FOR THAT CELL EQUAL TO THE NON-CUMULATIVE
C                   J-SCORE.  HOWEVER, RESET THE CUMULATIVE SCORE
C                   FOR THE NEXT CELL TO 0.
C
        IF(AJSCOR.LE.-8.0)THEN
          AJ=-8.0
          IF(AJPREV.LT.0.0)THEN
            SUM1=AJ + AJPREV
          ELSE
            SUM1=AJ
          ENDIF
          AJPREV=0.0
        ELSEIF(AJSCOR.GE.8.0)THEN
          AJ=8.0
          IF(AJPREV.GT.0.0)THEN
            SUM1=AJ + AJPREV
          ELSE
            SUM1=AJ
          ENDIF
          AJPREV=0.0
        ELSEIF(AJSCOR.LE.-4.0)THEN
          AJ=-4.0
          IF(AJPREV.LE.0.0)THEN
            SUM1=SUM1+AJ
            AJPREV=SUM1
          ELSE
            SUM1=AJ
            AJPREV=AJ
          ENDIF
        ELSEIF(AJSCOR.GE.4.0)THEN
          AJ=4.0
          IF(AJPREV.GE.0.0)THEN
            SUM1=SUM1+AJ
            AJPREV=SUM1
          ELSE
            SUM1=AJ
            AJPREV=AJ
          ENDIF
        ELSEIF(AJSCOR.LE.-2.0)THEN
          AJ=-2.0
          IF(AJPREV.LE.0.0)THEN
            SUM1=SUM1+AJ
            AJPREV=SUM1
          ELSE
            SUM1=AJ
            AJPREV=AJ
          ENDIF
        ELSEIF(AJSCOR.GE.2.0)THEN
          AJ=2.0
          IF(AJPREV.GE.0.0)THEN
            SUM1=SUM1+AJ
            AJPREV=SUM1
          ELSE
            SUM1=AJ
            AJPREV=AJ
          ENDIF
        ELSE
          IF(ISIGN.EQ.-1)THEN
            AJ=0.0
            IF(AJPREV.LE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ELSEIF(ISIGN.EQ.1)THEN
            AJ=0.0
            IF(AJPREV.GE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ENDIF
        ENDIF
C
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CORE')THEN
          WRITE(ICOUT,131)IR,HOLD1,ZSCORE,AJ,AJPREV,SUM1
  131     FORMAT('IR,HOLD1,ZSCORE,AJ,AJPREV,SUM1 = ',I8,5G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        Y(IR)=SUM1
        SUM1=AJPREV
  110 CONTINUE
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)NY
  811   FORMAT('THE NUMBER OF JSCORE VALUES GENERATED = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CORE')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF JSCORE--')
        CALL DPWRST('XXX','BUG ')
        DO9012I=1,NY
          WRITE(ICOUT,9015)I,Y(I)
 9015     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
 9012   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE JSCTAB(Z,ROUND,MATID,N,IWRITE,
     1                  XIDTEM,XIDTE2,TEMP1,
     1                  Y,RNDOUT,MATOUT,NY,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE JSCORE STATISTIC.
C              THIS IS USED IN ISO 13528 TYPE PROFICIENCY STUDIES.
C              THE INPUT IS ASSUMED TO BE A SERIES OF Z-SCORES
C              (THE ISO 13528 DEFINES MULTIPLE WAYS FOR COMPUTING
C              THE Z-SCORES, SO THIS COMMAND ASSUMES THAT THE INPUT
C              DATA IS ALREADY A Z-SCORE).
C
C              THE J-SCORE IS TYPICALLY DEFINED AS:
C
C                  IF  +3 <= Z          THEN J =  8
C                  IF  +2 <= Z <  +3    THEN J =  4
C                  IF  +1 <= Z <  +2    THEN J =  2
C                  IF  -1 <  Z <  +1    THEN J =  0
C                  IF  -2 <  Z <= -1    THEN J = -2
C                  IF  -3 <  Z <= -2    THEN J = -4
C                  IF  -3 <= Z          THEN J = -8
C
C              Z-SCORES ARE TYPICALLY COMPUTED OVER ONE OR MORE
C              MATERIALS AND ONE OR MORE ROUNDS.  J-SCORES ARE
C              TYPICALLY SUMMED OVER MULTIPLE ROUNDS UNTIL
C              ABS(JSCORE) >= 8.  THIS TYPICALLY TRIGGERS AN
C              ACTION SIGNAL AND THE J-SCORE IS RESET TO 0.
C              ALSO, WHEN SUCCESSIVE VALUES ARE OF DIFFERENT
C              SIGNS, THE JSCORE IS RESET TO 0.
C
C              THIS SUBROUTINE IS SIMILAR TO JSCORE.  THE DISTINCTION
C              IS THAT THIS ROUTINE PROCESSES MULTIPLE MATERIALS WHILE
C              JSCORE ASSUMES A SINGLE MATERIAL.  THIS ROUTINE WILL
C              RETURN THE CORRESPONDING ROUND AND MATERIAL ID'S FOR
C              THE CORRESPONDING J-SCORES.
C
C              IF THERE IS REPLICATION IN A ROUND, AN AVERAGE
C              Z-SCORE IS COMPUTED FOR THE ROUND BEFORE COMPUTING
C              THE J-SCORE.  ALTERNATIVELY, THE EXTREME Z-SCORE
C              CAN BE COMPUTED.
C
C              J-SCORES ARE TYPICALLY USED IN SHEWHART CONTROL
C              CHARTS AND ZONE PLOTS.
C
C     INPUT  ARGUMENTS--Z      = THE SINGLE PRECISION VECTOR OF
C                                Z-SCORES.
C                     --ROUND  = THE SINGLE PRECISION VECTOR THAT
C                                IDENTIFIES THE ROUND.
C                     --ROUND  = THE SINGLE PRECISION VECTOR THAT
C                                IDENTIFIES THE MATERIAL.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTORS Z AND ROUND.
C     OUTPUT ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED JSCORE VALUES (ONE FOR EACH
C                                DISTINCT ROUND).
C                     --RNDOUT = THE SINGLE PRECISION VECTOR OF THE
C                                ROUND-ID CORRESPONDING TO THE J-SCORE.
C                     --MATOUT = THE SINGLE PRECISION VECTOR OF THE
C                                MATERIAL-ID CORRESPONDING TO THE J-SCORE.
C                     --NY     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE OUTPUT VECTOR Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE JSCORE VALUES.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DISTIN, SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--THOMPSON, ELLISON, WOOD (2006), "THE INTERNATIONAL
C                 HARMONIZED PROTOCOL FOR THE PROFICIENCY TESTING OF
C                 ANALYTICAL CHEMISTRY LABORATORIES", PURE APPLIED
C                 CHEMISTRY, VOL. 78, NO. 1, PP. 145-196.
C     REFERENCES--ISO 13528, FIRST EDITION, STATISTICAL METHODS FOR USE
C                 IN PROFICIENCY TESTING BY INTERLABORATORY COMPARISONS,
C                 2005, PP. 27-28.
C     WRITTEN BY--ALAN HECKERT
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--2015.10
C     ORIGINAL VERSION--OCTOBER   2015.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      REAL Z(*)
      REAL ROUND(*)
      REAL MATID(*)
      REAL Y(*)
      REAL RNDOUT(*)
      REAL MATOUT(*)
      REAL XIDTEM(*)
      REAL XIDTE2(*)
      REAL TEMP1(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='JSCT'
      ISUBN2='AB  '
      IERROR='NO'
C
      ISIGN=-99
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CTAB')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF JSCTAB--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,N
   52   FORMAT('IBUGA3,ISUBRO,IWRITE,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Z(I),ROUND(I),MATID(I)
   56     FORMAT('I,Z(I),ROUND(I),MATID(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN JSCORE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)
  102   FORMAT('      THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)N
  103   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                     **
C               **  DETERMINE (AND SORT) THE UNIQUE VALUES FOR   **
C               **  ROUND-ID VARIABLE                            **
C               ****************************************************
C
      CALL DISTIN(ROUND,N,IWRITE,XIDTEM,NRND,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NRND,XIDTEM)
      CALL DISTIN(MATID,N,IWRITE,XIDTE2,NMAT,IBUGA3,IERROR)
      CALL SORT(XIDTE2,NMAT,XIDTE2)
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CTAB')THEN
        WRITE(ICOUT,201)NRND,NMAT
  201   FORMAT('NRND,NMAT = ',2I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ***************************************************
C               **  STEP 3--                                     **
C               **  LOOP THROUGH EACH MATERIAL                   **
C               ***************************************************
C
      NY=0
      DO310IMAT=1,NMAT
        HOLD2=XIDTE2(IMAT)
C
C               ***************************************************
C               **  STEP 4--                                     **
C               **  COMPUTE THE JSCORE FOR EACH ROUND            **
C               **    1) COMPUTE THE AVERAGE Z-SCORE FOR THE     **
C               **       ROUND.                                  **
C               **    2) COMPUTE THE JSCORE FOR THE ROUND.       **
C               ***************************************************
C
C
        AJ=0.0
        AJPREV=0.0
        SUM1=0.0
        EPS=0.000001
C
        DO410IRND=1,NRND
          HOLD1=XIDTEM(IRND)
          K=0
          AMIN=CPUMAX
          AMAX=CPUMIN
          DO420J=1,N
            IF(ROUND(J).EQ.HOLD1 .AND. MATID(J).EQ.HOLD2)THEN
              K=K+1
              TEMP1(K)=Z(J)
            ENDIF
  420     CONTINUE
C
C         SUPPORT FOLLOWING OPTIONS FOR THE CASE WHEN THERE
C         IS REPLICATION WITHIN A ROUND.
C
C            1. TAKE THE AVERAGE OF THE Z-SCORES (THIS WAS THE
C               PREVIOUSLY IMPLMENTED OPTION.
C            2. TAKE THE MOST EXTREME Z-SCORE IN THE CELL.
C
          IF(K.EQ.0)THEN
            GOTO410
          ELSEIF(K.EQ.1)THEN
            ZSCORE=TEMP1(1)
          ELSE
            IF(IJSREP.EQ.'AVER')THEN
              CALL MEAN(TEMP1,K,IWRITE,ZSCORE,IBUGA3,IERROR)
            ELSEIF(IJSREP.EQ.'EXTR')THEN
              CALL MINIM(TEMP1,K,IWRITE,ZMIN,IBUGA3,IERROR)
              CALL MAXIM(TEMP1,K,IWRITE,ZMAX,IBUGA3,IERROR)
              ZSCORE=ZMIN
              IF(ABS(ZMAX).GT.ABS(ZMIN))ZSCORE=ZMAX
            ENDIF
          ENDIF
C
C         STEP 1: CONVERT Z-SCORE TO A NON-CUMULATIVE J-SCORE
C
          IF(ZSCORE.LE.-3.0)THEN
            AJSCOR=-8.0
          ELSEIF(ZSCORE.LE.-2.0)THEN
            AJSCOR=-4.0
          ELSEIF(ZSCORE.LE.-1.0)THEN
            AJSCOR=-2.0
          ELSEIF(ZSCORE.GE.3.0)THEN
            AJSCOR=8.0
          ELSEIF(ZSCORE.GE.2.0)THEN
            AJSCOR=4.0
          ELSEIF(ZSCORE.GE.1.0)THEN
            AJSCOR=2.0
          ELSE
            AJSCOR=0.0
            ISIGN=1
            IF(ZSCORE.LT.0.0)ISIGN=-1
          ENDIF
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CTAB')THEN
            WRITE(ICOUT,411)IMAT,IR,ZSCORE,AJSCOR
  411       FORMAT('STEP 1: IMAT,IR,ZSCORE,AJSCOR = ',2I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
C         STEP 2: CONVERT NON-CUMULATIVE J-SCORE TO A CUMULATIVE J-SCORE
C
C                 THERE ARE 2 SPECIAL CASES FOR THE CUMULAIVE Z-SCORE:
C
C                  1) IF THE ABSOLUTE VALUE IS GREATER THAN 8, SET THE
C                     THE CURRENT J-SCORE TO 8 BUT RESET THE CUMULATIVE
C                     SUM TO 0.
C
C                  2) IF THERE IS A CHANGE OF SIGN, SET THE CUMULATIVE
C                     J-SCORE FOR THAT CELL EQUAL TO THE NON-CUMULATIVE
C                     J-SCORE.  HOWEVER, RESET THE CUMULATIVE SCORE
C                     FOR THE NEXT CELL TO 0.
C
          IF(AJSCOR.LE.-8.0)THEN
            AJ=-8.0
            IF(AJPREV.LT.0.0)THEN
              SUM1=AJ + AJPREV
            ELSE
              SUM1=AJ
            ENDIF
            AJPREV=0.0
          ELSEIF(AJSCOR.GE.8.0)THEN
            AJ=8.0
            IF(AJPREV.GT.0.0)THEN
              SUM1=AJ + AJPREV
            ELSE
              SUM1=AJ
            ENDIF
            AJPREV=0.0
          ELSEIF(AJSCOR.LE.-4.0)THEN
            AJ=-4.0
            IF(AJPREV.LE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ELSEIF(AJSCOR.GE.4.0)THEN
            AJ=4.0
            IF(AJPREV.GE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ELSEIF(AJSCOR.LE.-2.0)THEN
            AJ=-2.0
            IF(AJPREV.LE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ELSEIF(AJSCOR.GE.2.0)THEN
            AJ=2.0
            IF(AJPREV.GE.0.0)THEN
              SUM1=SUM1+AJ
              AJPREV=SUM1
            ELSE
              SUM1=AJ
              AJPREV=AJ
            ENDIF
          ELSE
            IF(ISIGN.EQ.-1)THEN
              AJ=0.0
              IF(AJPREV.LE.0.0)THEN
                SUM1=SUM1+AJ
                AJPREV=SUM1
              ELSE
                SUM1=AJ
                AJPREV=AJ
              ENDIF
            ELSEIF(ISIGN.EQ.1)THEN
              AJ=0.0
              IF(AJPREV.GE.0.0)THEN
                SUM1=SUM1+AJ
                AJPREV=SUM1
              ELSE
                SUM1=AJ
                AJPREV=AJ
              ENDIF
            ENDIF
          ENDIF
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CTAB')THEN
            WRITE(ICOUT,431)HOLD2,HOLD1,ZSCORE,AJ,AJPREV,SUM1
  431       FORMAT('HOLD2,HOLD1,ZSCORE,AJ,AJPREV,SUM1 = ',6G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          NY=NY+1
          Y(NY)=SUM1
          RNDOUT(NY)=HOLD1
          MATOUT(NY)=HOLD2
          SUM1=AJPREV
  410   CONTINUE
C
  310   CONTINUE
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)NY
  811   FORMAT('THE NUMBER OF JSCORE VALUES GENERATED = ',I8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CTAB')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF JSCTAB--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IERROR,NY
 9013   FORMAT('IERROR,NY = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        IF(NY.GT.0)THEN
          DO9012I=1,NY
            WRITE(ICOUT,9015)I,Y(I),RNDOUT(I),MATOUT(I)
 9015       FORMAT('I,Y(I),RNDOUT(I),MATOUT(I) = ',I8,3G15.7)
            CALL DPWRST('XXX','BUG ')
 9012     CONTINUE
        ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE JSUCDF(X,ALPHA1,ALPHA2,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X + SQRT(x**2+1))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE JOHNSON SU
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUCDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
      ARG=ALPHA1 + ALPHA2*LOG(X + SQRT(X**2+1))
      DARG=DBLE(ARG)
      CALL NODCDF(DARG,DCDF)
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSUPDF(X,ALPHA1,ALPHA2,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION.
C              THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE
C              NORMAL DISTRIBUTION:
C              F(X) = (ALPHA2/SQRT(X**2 + 1))*
C                     NORPDF(ALPHA1 + ALPHA2*LOG(X + SQRT(X**2+1)))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA1 = FIRST SHAPE PARAMETER
C                     --ALPHA2 = SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE JOHNSON SU
C             DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DARG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUPDF ')
   15 FORMAT('      SUBROUTINE IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
      ARG=ALPHA1 + ALPHA2*LOG(X + SQRT(X**2+1.0))
      DARG=DBLE(ARG)
      CALL NODPDF(DARG,DPDF)
      DX=DBLE(X)
      DPDF=(DBLE(ALPHA2)/DSQRT(DX*DX+1.0D0))*DPDF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE JSUPPF(P,ALPHA1,ALPHA2,PPF)
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--THE PERCENT POINT FUNCTION FOR THE JOHNSON SU
C           FUNCTION IS:
C           G(P,ALPHA1,ALPHA2) = SINH[(NORPPF(P) - ALPHA1)/ALPHA2]
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001/9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C     UPDATED         --NOVEMBER  2003. USE CLOSED FORMULA BASED
C                                       ON NORPPF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------
C
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C-----COMMON-------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT---------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ELSEIF(P.GE.1.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
      IF(ALPHA2.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA1
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
   14 FORMAT('***** ERROR--THE THIRD ARGUMENT TO JSUPPF ')
   15 FORMAT('      IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
C
C  NOTE: NOVEMBER 2003.  USE CLOSED FORM SOLUTION FOR PPF FUNCTION.
C
      CALL NODPPF(DBLE(P),DTERM1)
      DTERM2=(DTERM1 - DBLE(ALPHA1))/DBLE(ALPHA2)
      DTERM3=(DEXP(DTERM2) - DEXP(-DTERM2))/2.0D0
      PPF=REAL(DTERM3)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE JSURAN(N,ALPHA1,ALPHA2,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE JOHNSON SU DISTRIBUTION
C              WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA1  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                                ALPHA1 SHOULD BE POSITIVE.
C                     --ALPHA2  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                                ALPHA2 SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE JOHNSON SU DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA2 SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'JSURAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N STANDARD NORMAL RANDOM NUMBERS;
C
      CALL NORRAN(N,ISEED,X)
C
C     GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM.
C
C     GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS
C     USING APPLIED STATISTICS ALGORITHM AS100.
C
      ITYPE=2
      ALOC=0.0
      SCALE=1.0
      DO100I=1,N
        XTEMP=X(I)
        XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT)
        X(I)=XTEMP2
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION K0INT(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the integral of the modified Bessel function
C      defined by
C
C         K0INT(x) = {integral 0 to x} K0(t) dt
C
C      The code uses Chebyshev expansions, whose coefficients are
C      given to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If XVALUE < 0.0, the function is undefined. An error message is
C      printed and the function returns the value 0.0.
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - The no. of terms to be used in the array AK0IN1. The
C                recommended value is such that
C                   ABS(AK0IN1(NTERM1)) < EPS/100,
C
C      NTERM2 - The no. of terms to be used in the array AK0IN2. The
C                recommended value is such that
C                   ABS(AK0IN2(NTERM2)) < EPS/100,
C
C      NTERM3 - The no. of terms to be used in the array AK0INA. The
C                recommended value is such that
C                   ABS(AK0INA(NTERM3)) < EPS/100,
C
C      XLOW - The value below which K0INT = x * ( const - ln(x) ) to
C             machine precision. The recommended value is
C                   sqrt (18*EPSNEG).
C
C      XHIGH - The value above which K0INT = pi/2 to machine precision.
C              The recommended value is
C                   - log (2*EPSNEG)
C
C      For values of EPS and EPSNEG refer to the file MACHCON.TXT.
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      EXP , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C         Dr. Allan J. MacLeod,
C         Dept. of Mathematics and Statistics,
C         University of Paisley,
C         High St.,
C         Paisley,
C         SCOTLAND
C
C         (e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST REVISION:
C                   23 January, 1996
C
      INTEGER NTERM1,NTERM2,NTERM3
      DOUBLE PRECISION AK0IN1(0:15),AK0IN2(0:15),AK0INA(0:27),
     1     CHEVAL,CONST1,CONST2,EIGHTN,FVAL,HALF,
     2     ONEHUN,PIBY2,RT2BPI,SIX,T,TEMP,TWELVE,X,
     3     XHIGH,XLOW,XVALUE,ZERO
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC CHARACTER FNNAME*8,ERRMSG*14
CCCCC DATA FNNAME/'K0INT '/
CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/
      DATA ZERO,HALF,SIX/ 0.0 D 0 , 0.5 D 0 , 6.0 D 0 /
      DATA TWELVE,EIGHTN,ONEHUN/ 12.0 D 0 , 18.0 D 0 , 100.0 D 0 /
      DATA CONST1/1.11593 15156 58412 44881 D 0/
      DATA CONST2/-0.11593 15156 58412 44881 D 0/
      DATA PIBY2/1.57079 63267 94896 61923 D 0/
      DATA RT2BPI/0.79788 45608 02865 35588 D 0/
      DATA AK0IN1/16.79702 71446 47109 59477  D    0,
     1             9.79134 68767 68894 07070  D    0,
     2             2.80501 31604 43379 39300  D    0,
     3             0.45615 62053 18885 02068  D    0,
     4             0.47162 24457 07476 0784   D   -1,
     5             0.33526 51482 69698 289    D   -2,
     6             0.17335 18119 38747 27     D   -3,
     7             0.67995 18893 64702        D   -5,
     8             0.20900 26835 9924         D   -6,
     9             0.51660 38469 76           D   -8,
     X             0.10485 70833 1            D   -9,
     1             0.17782 9320               D  -11,
     2             0.25568 44                 D  -13,
     3             0.31557                    D  -15,
     4             0.338                      D  -17,
     5             0.3                        D  -19/
      DATA AK0IN2/10.76266 55822 78091 74077  D    0,
     1             5.62333 47984 99975 11550  D    0,
     2             1.43543 66487 92908 67158  D    0,
     3             0.21250 41014 37438 96043  D    0,
     4             0.20365 37393 10000 9554   D   -1,
     5             0.13602 35840 95623 632    D   -2,
     6             0.66753 88699 20909 3      D   -4,
     7             0.25043 00357 07337        D   -5,
     8             0.74064 23741 728          D   -7,
     9             0.17697 47043 14           D   -8,
     X             0.34857 75254              D  -10,
     1             0.57544 785                D  -12,
     2             0.80748 1                  D  -14,
     3             0.9747                     D  -16,
     4             0.102                      D  -17,
     5             0.1                        D  -19/
      DATA AK0INA(0)/  1.91172 06544 50604 53895  D    0/
      DATA AK0INA(1)/ -0.41830 64565 76958 1085   D   -1/
      DATA AK0INA(2)/  0.21335 25080 68147 486    D   -2/
      DATA AK0INA(3)/ -0.15859 49728 45041 81     D   -3/
      DATA AK0INA(4)/  0.14976 24699 85835 1      D   -4/
      DATA AK0INA(5)/ -0.16795 59553 22241        D   -5/
      DATA AK0INA(6)/  0.21495 47247 8804         D   -6/
      DATA AK0INA(7)/ -0.30583 56654 790          D   -7/
      DATA AK0INA(8)/  0.47494 64133 43           D   -8/
      DATA AK0INA(9)/ -0.79424 66043 2            D   -9/
      DATA AK0INA(10)/ 0.14156 55532 5            D   -9/
      DATA AK0INA(11)/-0.26678 25359              D  -10/
      DATA AK0INA(12)/ 0.52814 9717               D  -11/
      DATA AK0INA(13)/-0.10926 3199               D  -11/
      DATA AK0INA(14)/ 0.23518 838                D  -12/
      DATA AK0INA(15)/-0.52479 91                 D  -13/
      DATA AK0INA(16)/ 0.12101 91                 D  -13/
      DATA AK0INA(17)/-0.28763 2                  D  -14/
      DATA AK0INA(18)/ 0.70297                    D  -15/
      DATA AK0INA(19)/-0.17631                    D  -15/
      DATA AK0INA(20)/ 0.4530                     D  -16/
      DATA AK0INA(21)/-0.1190                     D  -16/
      DATA AK0INA(22)/ 0.319                      D  -17/
      DATA AK0INA(23)/-0.87                       D  -18/
      DATA AK0INA(24)/ 0.24                       D  -18/
      DATA AK0INA(25)/-0.7                        D  -19/
      DATA AK0INA(26)/ 0.2                        D  -19/
      DATA AK0INA(27)/-0.1                        D  -19/
C
      XLOW=CPUMIN
C
C   Start computation
C
      X = XVALUE
C
C   Error test
C
      IF ( X .LT. ZERO ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         K0INT = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM I0INT--ARGUMENT MUST BE ',
     1        'NON-NEGATIVE, ARGUMENT = ',G15.7)
C
C   Compute the machine-dependent constants.
C
      TEMP = D1MACH(3)
      T = TEMP / ONEHUN
      IF ( X .LE. SIX ) THEN
         DO 10 NTERM1 = 15 , 0 , -1
            IF ( ABS(AK0IN1(NTERM1)) .GT. T ) GOTO 19
 10      CONTINUE
 19      DO 20 NTERM2 = 15 , 0 , -1
            IF ( ABS(AK0IN2(NTERM2)) .GT. T ) GOTO 29
 20      CONTINUE
 29      XLOW = SQRT ( EIGHTN * TEMP )
      ELSE
         DO 40 NTERM3 = 27 , 0 , -1
            IF ( ABS(AK0INA(NTERM3)) .GT. T ) GOTO 49
 40      CONTINUE
 49      XHIGH = - LOG ( TEMP + TEMP )
      ENDIF
C
C   Code for 0 <= XVALUE <= 6
C
      IF ( X .LE. SIX ) THEN
         IF ( X .LT. XLOW ) THEN
            FVAL = X
            IF ( X .GT. ZERO ) THEN
               FVAL = FVAL * ( CONST1 - LOG(X) )
            ENDIF
            K0INT = FVAL
         ELSE
            T = ( ( X * X ) / EIGHTN - HALF ) - HALF
            FVAL = ( CONST2 + LOG(X) ) * CHEVAL(NTERM2,AK0IN2,T)
            K0INT = X * ( CHEVAL(NTERM1,AK0IN1,T) - FVAL )
         ENDIF
C
C   Code for x > 6
C
      ELSE
         FVAL = PIBY2
         IF ( X .LT. XHIGH ) THEN
            T = ( TWELVE / X - HALF ) - HALF
            TEMP = EXP(-X) * CHEVAL(NTERM3,AK0INA,T)
            FVAL = FVAL - TEMP / ( SQRT(X) * RT2BPI)
         ENDIF
         K0INT = FVAL
      ENDIF
      RETURN
      END
      SUBROUTINE KAPCDF(DX,DK,DH,DXI,DALPHA,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE KAPPA DISTRIBUTION
C              WITH SHAPE PARAMETERS K AND H.
C              THE CDF FOR THE DISTRIBUTION IS
C
C              F(X) = [1 - H*[1 - k*(X - XI)/ALPHA]**(1/K)]**(1/H)
C
C                     X < XI + ALPHA*(1 - H**(-K)    IF K >  0
C                     X < INFINITY                   IF K <= 0
C
C                     X > XI + ALPHA*(1 - H**(-K))/K  IF H >  0
C                     X > XI ALPHA/K                  IF H <= 0, K <  0
C                     X > -INFINITY                   IF H <= 0, K >= 0
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --DK     = THE FIRST SHAPE PARAMETER
C                     --DH     = THE SECOND SHAPE PARAMETER
C                     --DXI    = THE LOCATION PARAMETER
C                     --DALPHA = THE SCALE PARAMETER
C     OUTPUT ARGUMENTS--DCDF   = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE KAPPA DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDENT ON H AND K
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOSKING AND WALLIS (1997), "REGIONAL FREQUENCY
C                 ANALYSIS: xxx", CAMBRIDGE UNVERSITY PRESS,
C                 PP. 202-204.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DK
      DOUBLE PRECISION DH
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION CDFKAP
      EXTERNAL CDFKAP
C
      DOUBLE PRECISION PARA(4)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
   35 FORMAT('***** ERROR--THE THIRD ARGUMENT TO KAPCDF ',
     1       '(THE SCALE PARAMETER) IS NON-POSITIVE')
C
      DTERM1=DXI + DALPHA/DK
      IF(DK.GT.0.0D0 .AND. DX.GT.DTERM1)THEN
CCCCC   WRITE(ICOUT,5)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,6)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)DX
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,7)DTERM1
CCCCC   CALL DPWRST('XXX','BUG ')
        DCDF=1.0D0
        GOTO9999
      ENDIF
CCCC5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPCDF IS ',
CCCCC1       '> XI + ALPHA/K')
CCCC6 FORMAT('      WHEN THE FIRST SHAPE PARAMETER (K) IS POSITIVE.')
CCCC7 FORMAT('      THE VALUE OF XI + ALPHA/K IS ',G15.7)
C
      DTERM1=DXI + DALPHA*(1.0D0 - DH**(-DK))/DK
      IF(DH.GT.0.0D0 .AND. DX.LT.DTERM1)THEN
CCCCC   WRITE(ICOUT,15)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,16)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)DX
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,17)DTERM1
CCCCC   CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
CCC15 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPCDF IS ',
CCCCC1       '< XI + ALPHA*(1 - H**(-K))')
CCC16 FORMAT('      WHEN THE SECOND SHAPE PARAMETER (H) IS POSITIVE.')
CCC17 FORMAT('      THE VALUE OF XI + ALPHA*(1 - H**(-K))/K IS ',
CCCCC1       G15.7)
C
      DTERM1=DXI + DALPHA/DK
      IF(DH.LE.0.0D0 .AND. DK.GT.0.0D0 .AND. DX.LT.DTERM1)THEN
CCCCC   WRITE(ICOUT,25)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,26)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,27)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)DX
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,28)DTERM1
CCCCC   CALL DPWRST('XXX','BUG ')
        DCDF=0.0D0
        GOTO9999
      ENDIF
CCC25 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPCDF IS ',
CCCCC1       '< XI + ALPHA/K')
CCC26 FORMAT('      WHEN THE SECOND SHAPE PARAMETER (H) IS POSITIVE')
CCC27 FORMAT('      AND THE SECOND SHAPE PARAMETER (K) IS NEGATIVE.')
CCC28 FORMAT('      THE VALUE OF XI + ALPHA/K IS ',G15.7)
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      PARA(1)=DXI
      PARA(2)=DALPHA
      PARA(3)=DK
      PARA(4)=DH
      DCDF=CDFKAP(DX,PARA)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPML1(Y,N,
     1                  DTEMP1,XMOM,NMOM,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,
     1                  ALOCLM,SCALLM,SHA1LM,SHA2LM,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE L-MOMENTS ESTIMATES FOR THE
C              KAPPA DISTRIBUTION FOR THE RAW DATA CASE (I.E.,
C              NO CENSORING AND NO GROUPING).  THIS ROUTINE RETURNS ONLY
C              THE POINT ESTIMATES.
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLKP WILL GENERATE THE OUTPUT
C              FOR THE KAPPA MLE COMMAND).
C
C     REFERENCE--FORTRAN CODE WRITTEN FOR INCLUSION IN IBM
C                RESEARCH REPORT RC20525, 'FORTRAN ROUTINES FOR
C                USE WITH THE METHOD OF L-MOMENTS, VERSION 3',
C                J. R. M. HOSKING, IBM RESEARCH DIVISION,
C                T. J. WATSON RESEARCH CENTER, YORKTOWN HEIGHTS
C                NEW YORK 10598, U.S.A., VERSION 3     AUGUST 1996
C     WRITTEN BY--ALAN HECKERT
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--2010/7
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLKP)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
      DOUBLE PRECISION XMOM(*)
      DOUBLE PRECISION XPAR(4)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='KAPM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF KAPML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 2--                             **
C               **  CARRY OUT CALCULATIONS               **
C               **  FOR KAPPA MLE ESTIMATE               **
C               *******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='KAPPA'
      ALOCLM=CPUMIN
      SCALLM=CPUMIN
      SHA1LM=CPUMIN
      SHA2LM=CPUMIN
C
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      CALL SORT(Y,N,Y)
      NMOM=4
      DO2110I=1,N
        DTEMP1(I)=DBLE(Y(I))
 2110 CONTINUE
      CALL SAMLMU(DTEMP1,N,XMOM,NMOM)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')THEN
        WRITE(ICOUT,2120)XMOM(1),XMOM(2),XMOM(3),XMOM(4)
 2120   FORMAT('XMOM(1),XMOM(2),XMOM(3),XMOM(4) = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      CALL PELKAP(XMOM,XPAR,IFAIL)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MLKP')THEN
        WRITE(ICOUT,2130)XPAR(1),XPAR(2),XPAR(3),XPAR(4)
 2130   FORMAT('XPAR(1),XPAR(2),XPAR(3),XPAR(4) = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      IF(IFAIL.GE.1)GOTO9000
C
      ALOCLM=REAL(XPAR(1))
      SCALLM=REAL(XPAR(2))
      SHA1LM=REAL(XPAR(3))
      SHA2LM=REAL(XPAR(4))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'PML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF KAPML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHA1LM,SHA2LM,SCALLM,ALOCLM
 9017   FORMAT('SHA1ML,SHA2ML,SCALML,ALOCML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE KAPPDF(DX,DK,DH,DXI,DALPHA,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE KAPPA DISTRIBUTION
C              WITH SHAPE PARAMETERS K AND H.
C              THE PDF FOR THE KAPPA DISTRIBUTION IS
C
C              f(X;K,H,XI,ALPHA) =
C                  (1/ALPHA)*[1 - K*(X-XI)/ALPHA]**((1/K)-1)*
C                  [F(X;K,H,XI,ALPHA)]**(1-H)
C
C              WHERE F IS THE KAPPA CUMULATIVE DISTRIBUTION
C              FUNCTION.
C
C                     X < XI + ALPHA*(1 - H**(-K)    IF K >  0
C                     X < INFINITY                   IF K <= 0
C
C                     X > XI + ALPHA*(1 - H**(-K))/K  IF H >  0
C                     X > XI ALPHA/K                  IF H <= 0, K <  0
C                     X > -INFINITY                   IF H <= 0, K >= 0
C
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --DK     = THE FIRST SHAPE PARAMETER
C                     --DH     = THE SECOND SHAPE PARAMETER
C                     --DXI    = THE LOCATION PARAMETER
C                     --DALPHA = THE SCALE PARAMETER
C     OUTPUT ARGUMENTS--DPDF   = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE KAPPA DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--RANGE OF X DEPENDENT ON H AND K
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOSKING AND WALLIS (1997), "REGIONAL FREQUENCY
C                 ANALYSIS: xxx", CAMBRIDGE UNVERSITY PRESS,
C                 PP. 202-204.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DK
      DOUBLE PRECISION DH
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION CDFKAP
      EXTERNAL CDFKAP
C
      DOUBLE PRECISION PARA(4)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
   35 FORMAT('***** ERROR--THE THIRD ARGUMENT TO KAPPDF ',
     1       '(THE SCALE PARAMETER) IS NON-POSITIVE')
C
      DTERM1=DXI + DALPHA/DK
      IF(DK.GT.0.0D0 .AND. DX.GT.DTERM1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,7)DTERM1
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPDF IS ',
     1       '> XI + ALPHA/K')
    6 FORMAT('      WHEN THE FIRST SHAPE PARAMETER (K) IS POSITIVE.')
    7 FORMAT('      THE VALUE OF XI + ALPHA/K IS ',G15.7)
C
      DTERM1=DXI + DALPHA*(1.0D0 - DH**(-DK))/DK
      IF(DH.GT.0.0D0 .AND. DX.LT.DTERM1)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,17)DTERM1
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPDF IS ',
     1       '< XI + ALPHA*(1 - H**(-K))')
   16 FORMAT('      WHEN THE SECOND SHAPE PARAMETER (H) IS POSITIVE.')
   17 FORMAT('      THE VALUE OF XI + ALPHA*(1 - H**(-K))/K IS ',
     1       G15.7)
C
      DTERM1=DXI + DALPHA/DK
      IF(DH.LE.0.0D0 .AND. DK.GT.0.0D0 .AND. DX.LT.DTERM1)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,27)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,28)DTERM1
        CALL DPWRST('XXX','BUG ')
        DPDF=0.0D0
        GOTO9999
      ENDIF
   25 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPDF IS ',
     1       '< XI + ALPHA/K')
   26 FORMAT('      WHEN THE SECOND SHAPE PARAMETER (H) IS POSITIVE')
   27 FORMAT('      AND THE SECOND SHAPE PARAMETER (K) IS NEGATIVE.')
   28 FORMAT('      THE VALUE OF XI + ALPHA/K IS ',G15.7)
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      PARA(1)=DXI
      PARA(2)=DALPHA
      PARA(3)=DK
      PARA(4)=DH
      DTERM1=CDFKAP(DX,PARA)**(1.0D0 - DH)
      DTERM2=(1.0D0/DALPHA)*
     1       (1.0D0 - DK*(DX-DXI)/DALPHA)**((1.0D0/DK) - 1.0D0)
      DPDF=DTERM1*DTERM2
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPPPF(DP,DK,DH,DXI,DALPHA,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE KAPPA DISTRIBUTION
C              WITH SHAPE PARAMETERS K AND H.
C              THE PPF FOR THE DISTRIBUTION IS
C
C              G(P) = XI + (ALPHA/K)*{1 - ((1-P**H)/H)**K}
C                     0 < P < 1
C
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --DK     = THE FIRST SHAPE PARAMETER
C                     --DH     = THE SECOND SHAPE PARAMETER
C                     --DXI    = THE LOCATION PARAMETER
C                     --DALPHA = THE SCALE PARAMETER
C     OUTPUT ARGUMENTS--DPPF   = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE KAPPA DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 < P < 1
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--HOSKING AND WALLIS (1997), "REGIONAL FREQUENCY
C                 ANALYSIS: xxx", CAMBRIDGE UNVERSITY PRESS,
C                 PP. 202-204.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DK
      DOUBLE PRECISION DH
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DXI
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION QUAKAP
      EXTERNAL QUAKAP
C
      DOUBLE PRECISION PARA(4)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
      IF(DALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KAPPPF ',
     1       '(THE SCALE PARAMETER) IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(DK.GT.0.0D0)THEN
        IF(DP.GT.1.0D0)THEN
          WRITE(ICOUT,5)
    5     FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPPF IS ',
     1           'GREATER THAN 1.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ELSE
        IF(DP.GE.1.0D0)THEN
          WRITE(ICOUT,6)
    6     FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPPF IS ',
     1           'GREATER THAN OR EQUAL TO 1.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ENDIF
C
      IF(DH.GT.0.0D0)THEN
        IF(DP.LT.0.0D0)THEN
          WRITE(ICOUT,15)
   15     FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPPF IS ',
     1           'LESS THAN 0.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ELSEIF(DH.LE.0.0D0 .AND. DK.LT.0.0D0)THEN
        IF(DP.LT.0.0D0)THEN
          WRITE(ICOUT,16)
   16     FORMAT('***** ERROR--THE FIRST ARGUMENT TO KAPPPF IS ',
     1           'LESS THAN OR EQUAL TO 0.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ELSEIF(DH.LE.0.0D0 .AND. DK.GT.0.0D0)THEN
        IF(DP.LE.0.0D0)THEN
          WRITE(ICOUT,16)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DP
          CALL DPWRST('XXX','BUG ')
          GOTO9999
        ENDIF
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      PARA(1)=DXI
      PARA(2)=DALPHA
      PARA(3)=DK
      PARA(4)=DH
      DPPF=QUAKAP(DP,PARA)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KAPRAN(N,AK,H,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE KAPPA DISTRIBUTION WITH SHAPE PARAMETERS
C              K AND H.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE GENERATED.
C                     --K      = THE SINGLE PRECISION VALUE OF THE
C                                K SHAPE PARAMETER.
C                     --H      = THE SINGLE PRECISION VALUE OF THE
C                                H SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE KAPPA DISTRIBUTION
C             WITH SHAPE PARAMETERS K AND H.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, QUAKAP.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.5
C     ORIGINAL VERSION--MAY       2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DPPF
      DOUBLE PRECISION QUAKAP
      DOUBLE PRECISION PARA(4)
C
      EXTERNAL QUAKAP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF KAPPA ',
     1       'RANDOM NUMBERS IS NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N KAPPA DISTRIBUTION RANDOM NUMBERS USING THE
C     PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      PARA(1)=0.0D0
      PARA(2)=1.0D0
      PARA(3)=DBLE(AK)
      PARA(4)=DBLE(H)
C
      DO100I=1,N
        DPPF=QUAKAP(DBLE(X(I)),PARA)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE KATCDF(X,ALPHA,BETA,IKATDF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE KATZ DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL NON-NEGATIVE INTEGERS  X >= 0.
C
C              THE KATZ DISTRIBUTION IS DEFINED BY THE
C              RELATIONSHIP
C                  p(X+1;ALPHA,BETA)/P(X;ALPHA,BETA) =
C                  (ALPHA + BETA*X)/(1 + X)
C                  X = 0, 1, 2, 3, ,...
C                  ALPHA > 0, BETA < 1
C
C              AND
C
C                  p(0;ALPHA,BETA) = (1-BETA)**(ALPHA/BETA)
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              p(X+1;ALPHA,BETA) = {(ALPHA + BETA*X)/(1 + X)}*
C                                  p(X;ALPHA,BETA)
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --IKATDF = SPECIFY WHICH PARAMETERIZATION
C                                OF THE KATZ DISTRIBUTION TO USE.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS ALPHA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --ALPHA > 0, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION, WILEY,
C                 PP. 82-83.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      REAL RESULT
      CHARACTER*4 IKATDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5D0)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KATCDF IS LESS ',
     1'THAN 0')
C
      IF(IKATDF.EQ.'DEFA')THEN
        IF(ALPHA.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)ALPHA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0D0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KATCDF IS ',
     1         'NON-POSITIVE.')
C
        IF(BETA.GE.1.0D0)THEN
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)BETA
          CALL DPWRST('XXX','BUG ')
          CDF=0.0D0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KATCDF IS ',
     1         'GREATER THAN OR EQUAL TO 1.')
C
      ELSE
        DMU=ALPHA
        DNU=BETA
        IF(DMU.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          CDF=0.0D0
          GOTO9000
        ENDIF
        ALPHA=DMU/(DNU+1.0D0)
        BETA=DNU/(DNU+1.0D0)
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE):
C
      IF(BETA.EQ.0.0D0)THEN
        CALL POICDF(REAL(IX),REAL(ALPHA),RESULT)
        CDF=DBLE(RESULT)
        GOTO9000
      ENDIF
C
      CDF=(1.0D0 - BETA)**(ALPHA/BETA)
      IF(IX.EQ.0)GOTO9000
      DPDFSV=CDF
C
      DO100I=1,IX
        DX=DBLE(I-1)
        DTERM1=ALPHA + BETA*DX
        IF(DTERM1.LE.0.0D0)THEN
          CDF=1.0D0
          GOTO9000
        ELSE
          DTERM2=DLOG(DTERM1)
          DTERM3=DLOG(1.0D0 + DX)
          IF(DPDFSV.LE.0.0D0)THEN
            GOTO9000
          ELSE
            DTERM4=DLOG(DPDFSV)
          ENDIF
C
          DPDF=DEXP(DTERM2 - DTERM3 + DTERM4)
          CDF=CDF + DPDF
          IF(CDF.GE.1.0D0)THEN
            CDF=1.0D0
            GOTO9000
          ENDIF
          DPDFSV=DPDF
        ENDIF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KATPDF(X,ALPHA,BETA,IKATDF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE FOR THE KATZ DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL NON-NEGATIVE INTEGERS  X >= 0.
C
C              THE KATZ DISTRIBUTION IS DEFINED BY THE
C              RELATIONSHIP
C                  p(X+1;ALPHA,BETA)/P(X;ALPHA,BETA) =
C                  (ALPHA + BETA*X)/(1 + X)
C                  X = 0, 1, 2, 3, ,...
C                  ALPHA > 0, BETA < 1
C
C              AND
C
C                  p(0;ALPHA,BETA) = (1-BETA)**(ALPHA/BETA)
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              p(X+1;ALPHA,BETA) = {(ALPHA + BETA*X)/(1 + X)}*
C                                  p(X;ALPHA,BETA)
C
C              WE USE THIS RECURRENCE RELATION TO COMPUTE THE
C              PROBABILITY MASS FUNCTION AS WELL.
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --IKATDF = SPECIFY WHICH PARAMETERIZATION
C                                OF THE KATZ DISTRIBUTION TO USE.
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION
C             VALUE PDF FOR THE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS ALPHA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --ALPHA > 0, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION, WILEY,
C                 PP. 82-83.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      REAL RESLT1
      REAL RESLT2
      CHARACTER*4 IKATDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5D0)
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0D0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO KATPDF IS LESS ',
     1'THAN 0')
C
      IF(IKATDF.EQ.'DEFA')THEN
        IF(ALPHA.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)ALPHA
          CALL DPWRST('XXX','BUG ')
          PDF=0.0D0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KATPDF IS ',
     1         'NON-POSITIVE.')
C
        IF(BETA.GE.1.0D0)THEN
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)BETA
          CALL DPWRST('XXX','BUG ')
          PDF=0.0D0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KATPDF IS ',
     1         'GREATER THAN OR EQUAL TO 1.')
C
      ELSE
        DMU=ALPHA
        DNU=BETA
        IF(DMU.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          PDF=0.0D0
          GOTO9000
        ENDIF
        ALPHA=DMU/(DNU+1.0D0)
        BETA=DNU/(DNU+1.0D0)
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     USE THE RECURRENCE RELATION (PAGE 82 OF JOHNSON, KEMP, AND
C     KOTZ):
C
      IF(BETA.EQ.0.0D0)THEN
        CALL POICDF(REAL(IX),REAL(ALPHA),RESLT1)
        IF(IX.EQ.0)THEN
          PDF=DBLE(RESLT1)
        ELSE
          CALL POICDF(REAL(IX-1),REAL(ALPHA),RESLT2)
          PDF=DBLE(RESLT1-RESLT2)
        ENDIF
        GOTO9000
      ENDIF
C
      CDF=(1.0D0 - BETA)**(ALPHA/BETA)
      IF(IX.EQ.0)THEN
        PDF=CDF
        GOTO9000
      ENDIF
      DPDFSV=CDF
C
      DO100I=1,IX
        DX=DBLE(I-1)
        DTERM1=ALPHA + BETA*DX
        IF(DTERM1.LE.0.0D0)THEN
          PDF=0.0D0
          GOTO9000
        ELSE
          DTERM2=DLOG(DTERM1)
          DTERM3=DLOG(1.0D0 + DX)
          IF(DPDFSV.LE.0.0D0)THEN
            PDF=0.0D0
            GOTO9000
          ELSE
            DTERM4=DLOG(DPDFSV)
          ENDIF
C
          DPDF=DEXP(DTERM2 - DTERM3 + DTERM4)
          CDF=CDF + DPDF
          IF(CDF.GE.1.0D0)THEN
            PDF=0.0D0
            GOTO9000
          ENDIF
          DPDFSV=DPDF
        ENDIF
  100 CONTINUE
      PDF=DPDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KATPPF(P,ALPHA,BETA,IKATDF,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE KATZ DISTRIBUTION WITH SHAPE
C              PARAMETERS ALPHA AND BETA.  THIS DISTRIBUTION IS
C              DEFINED FOR ALL NON-NEGATIVE INTEGERS  X >= 0.
C
C              THE KATZ DISTRIBUTION IS DEFINED BY THE
C              RELATIONSHIP
C                  p(X+1;ALPHA,BETA)/P(X;ALPHA,BETA) =
C                  (ALPHA + BETA*X)/(1 + X)
C                  X = 0, 1, 2, 3, ,...
C                  ALPHA > 0, BETA < 1
C
C              AND
C
C                  p(0;ALPHA,BETA) = (1-BETA)**(ALPHA/BETA)
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              p(X+1;ALPHA,BETA) = {(ALPHA + BETA*X)/(1 + X)}*
C                                  p(X;ALPHA,BETA)
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY
C              CALCULATING THE CDF FUNCTION UNTIL THE SPECIFIED
C              PROBABILITY IS OBTAINED.
C     INPUT  ARGUMENTS--P      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                0 <= P <= 1
C                     --ALPHA  = THE FIRST SHAPE PARAMETER
C                     --BETA   = THE SECOND SHAPE PARAMETER
C                     --IKATDF = SPECIFY WHICH PARAMETERIZATION
C                                OF THE KATZ DISTRIBUTION TO USE.
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS ALPHA AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P <= 1 (BETA < 0)
C                   0 <= P < 1  (BETA >= 0)
C                 --ALPHA > 0, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION, WILEY,
C                 PP. 82-83.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      REAL RESULT
      CHARACTER*4 IKATDF
C
C-----COMMON----------------------------------------------------------
C
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(IKATDF.EQ.'DEFA')THEN
C
        IF(BETA.GE.0.0D0)THEN
          IF(P.LT.0.0D0 .OR. P.GE.1.0D0)THEN
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0D0
            GOTO9000
          ENDIF
        ELSE
          IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
            WRITE(ICOUT,4)
            CALL DPWRST('XXX','BUG ')
            WRITE(ICOUT,46)P
            CALL DPWRST('XXX','BUG ')
            PPF=0.0D0
            GOTO9000
          ENDIF
        ENDIF
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO KATPPF IS ',
     1         'OUTSIDE THE ALLOWABLE (0,1) INTERVAL)')
C
        IF(ALPHA.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)ALPHA
          CALL DPWRST('XXX','BUG ')
          PPF=0.0D0
          GOTO9000
        ENDIF
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KATPPF IS ',
     1         'NON-POSITIVE.')
C
        IF(BETA.GE.1.0D0)THEN
          WRITE(ICOUT,25)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)BETA
          CALL DPWRST('XXX','BUG ')
          PPF=0.0D0
          GOTO9000
        ENDIF
   25   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KATPPF IS ',
     1         'GREATER THAN OR EQUAL TO 1.')
C
      ELSE
        IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
          WRITE(ICOUT,4)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)P
          CALL DPWRST('XXX','BUG ')
          PPF=0.0D0
          GOTO9000
        ENDIF
        DMU=ALPHA
        DNU=BETA
        IF(DMU.LE.0.0D0)THEN
          WRITE(ICOUT,15)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,46)DMU
          CALL DPWRST('XXX','BUG ')
          PPF=0.0D0
          GOTO9000
        ENDIF
        ALPHA=DMU/(DNU+1.0D0)
        BETA=DNU/(DNU+1.0D0)
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     USE THE RECURRENCE RELATION (PAGE 82 OF
C     JOHNSON, KEMP, AND KOTZ)
C
      IF(P.LE.0.0D0)THEN
        PPF=0.0D0
        GOTO9000
      ENDIF
C
      IF(BETA.EQ.0.0D0)THEN
        CALL POIPPF(REAL(P),REAL(ALPHA),RESULT)
        PPF=DBLE(RESULT)
        GOTO9000
      ENDIF
C
C     FOR BETA < 0, CHECK FOR MAXIMUM ALLOWABLE X
C     (ALPHA + BETA*X >= 0  => X <= ALPHA/ABS(BETA))
C
      IF(BETA.LT.0.0D0 .AND. P.GE.1.0D0)THEN
        IPPF=INT(ALPHA/ABS(BETA))
        PPF=DBLE(IPPF)
        GOTO9000
      ENDIF
C
C     COMPUTE PDF FOR X = 0
C
      DEPS=1.0D-7
      CDF=(1.0D0 - BETA)**(ALPHA/BETA)
      IF(CDF.GE.P-DEPS)THEN
         PPF=0.0D0
         GOTO9000
      ENDIF
      DPDFSV=CDF
      I=0
C
  100 CONTINUE
        I=I+1
        IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN
          WRITE(ICOUT,55)
   55     FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ',
     1           'EXCEEDS THE LARGEST MACHINE INTEGER.')
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9000
        ENDIF
        DX=DBLE(I-1)
C
        DTERM1=ALPHA + BETA*DX
        IF(DTERM1.LE.0.0D0)THEN
          PPF=DX
          GOTO9000
        ELSE
          DTERM2=DLOG(DTERM1)
          DTERM3=DLOG(1.0D0 + DX)
          IF(DPDFSV.LE.0.0D0)THEN
            PPF=DX
            GOTO9000
          ELSE
            DTERM4=DLOG(DPDFSV)
          ENDIF
C
          DPDF=DEXP(DTERM2 - DTERM3 + DTERM4)
          CDF=CDF + DPDF
          IF(CDF.GE.P-DEPS)THEN
            PPF=DBLE(I)
            GOTO9000
          ENDIF
          DPDFSV=DPDF
        ENDIF
      GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KATRAN(N,ALPHA,BETA,IKATDF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE KATZ DISTRIBUTION WITH SHAPE PARAMETERS
C              ALPHA AND BETA.
C
C              THE KATZ DISTRIBUTION IS DEFINED BY THE
C              RELATIONSHIP
C                  p(X+1;ALPHA,BETA)/P(X;ALPHA,BETA) =
C                  (ALPHA + BETA*X)/(1 + X)
C                  X = 0, 1, 2, 3, ,...
C                  ALPHA > 0, BETA < 1
C
C              AND
C
C                  p(0;ALPHA,BETA) = (1-BETA)**(ALPHA/BETA)
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --A      = THE DOUBLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --BETA   = THE DOUBLE PRECISION VALUE
C                                OF THE THIRD SHAPE PARAMETER.
C                     --IKATDF = SPECIFY WHICH PARAMETERIZATION
C                                OF THE KATZ DISTRIBUTION TO USE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE KATZ DISTRIBUTION
C             WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA > 0, BETA < 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LKPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", THIRD EDITION, WILEY,
C                 PP. 82-83.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
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--2007/1
C     ORIGINAL VERSION--JANUARY   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION BETA
C
      CHARACTER*4 IKATDF
C
      DOUBLE PRECISION DPPF
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF KATZ')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE')
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE ALPHA PARAMETER FOR THE KATZ')
   12 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
C
      IF(BETA.GE.1.0D0)THEN
        WRITE(ICOUT,21)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
   21 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE KATZ')
   22 FORMAT('      RANDOM NUMBERS IS GREATER THAN OR EQUAL TO 1.')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N KATZ DISTRIBUTION RANDOM NUMBERS USING
C     THE INVERSION METHOD.
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        ZTEMP=X(I)
        CALL KATPPF(DBLE(ZTEMP),ALPHA,BETA,IKATDF,DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE KCONS(Y,X,XIDTEM,TEMP,N,IWRITE,YOUT,NUMSET,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE K CONSISTENCY STATISTIC IS DEFINED AS:
C
C                 K(i) = SD(i)/Sr
C
C              WITH SD(i) DENOTING THE STANDARD DEVIATION OF
C              LAB i AND THE REPEATABILITY STANDARD DEVIATION,
C              RESPECTIVELY.  THE REPEATABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X      = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE K CONSISTENCY
C                                STATISTIC.
C                     --NUMSET = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF GROUPS IN X
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE K CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION YOUT(*)
      DIMENSION XIDTEM(*)
      DIMENSION TEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='KCON'
      ISUBN2='S   '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE K CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE K CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSET,XIDTEM)
C
      IF(NUMSET.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSET < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DSUM=0.0D0
      J=0
      DO1110ISET1=1,NUMSET
        K=0
        DO1130I=1,N
          IF(XIDTEM(ISET1).EQ.X(I))THEN
            K=K+1
            TEMP(K)=Y(I)
          ENDIF
 1130   CONTINUE
        NTEMP=K
        CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
        DSUM=DSUM + DBLE(XSD)**2
        YOUT(ISET1)=XSD
        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
          WRITE(ICOUT,1131)NUMSET,XSD
 1131     FORMAT('***** GROUP ',I8,' SD = ',G15.7)
          CALL DPWRST('XXX','BUG ')
        ENDIF
 1110 CONTINUE
C
      XREP=REAL(DSQRT(DSUM/DBLE(NUMSET)))
      DO1150I=1,NUMSET
        YOUT(I)=YOUT(I)/XREP
 1150 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSET
 9013   FORMAT('N,NUMSET = ',I8,1X,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XREP
 9015   FORMAT('XREP = ',E15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NUMSET
          WRITE(ICOUT,9019)I,YOUT(I)
 9019     FORMAT('I,YOUT(I) = ',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE KCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,N,
     1IWRITE,YOUT,TAG,TAG2,NOUT,
     1ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC
C              OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID
C              VECTOR X.  THE K CONSISTENCY STATISTIC IS DEFINED AS:
C
C                 K(i) = SD(i)/Sr
C
C              WITH SD(i) DENOTING THE STANDARD DEVIATION OF
C              LAB i AND THE REPEATABILITY STANDARD DEVIATION,
C              RESPECTIVELY.  THE REPEATABILITY STANDARD
C              DEVIATION IS DEFINED AS:
C
C                 Sr = SQRT(SUM[i=1 to p][s(i)**2/p]
C
C              WITH
C                 p      = NUMBER OF LABS
C                 s(i)   = STANDARD DEVIATION OF GROUP i.
C
C              THE DISTINCTION BETWEEN KCONS AND KCONS2 IS THAT
C              KCONS IS USED TO COMPUTE THE K CONSISTENCY STATISTIC
C              FOR A SINGLE MATERIAL WHILE KCONS2 COMPUTES THE
C              K CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS.
C
C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --X1     = THE SINGLE PRECISION VECTOR OF
C                                GROUP ID's.
C                     --X2     = THE SINGLE PRECISION VECTOR OF
C                                MATERIAL ID's.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--YOUT   = THE SINGLE PRECISION VECTOR OF THE
C                                COMPUTED SAMPLE K CONSISTENCY
C                                STATISTIC.
C                     --TAG    = THE SINGLE PRECISION VECTOR OF THE
C                                MATERIAL ID's.
C                     --TAG2   = THE SINGLE PRECISION VECTOR OF THE
C                                LAB ID's.
C                     --NOUT   = THE INTEGER VALUE CONTAINING THE
C                                NUMBER OF VALUES IN YOUT
C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE
C             SAMPLE K CONSISTENCY STATISTIC.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, DISTIN, SD.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--"Standard Practice for Conducting an
C                 Interlaboratory Study to Determine the Precision
C                 of a Test Method", ASTM International,
C                 100 Barr Harbor Drive, PO BOX C700,
C                 West Conshohoceken, PA 19428-2959, USA.
C                 This document is in support of
C                 ASTM Standard E 691 - 99.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.2
C     ORIGINAL VERSION--FEBRUARY  2005.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
C
      DIMENSION Y(*)
      DIMENSION X1(*)
      DIMENSION X2(*)
      DIMENSION YOUT(*)
      DIMENSION TAG(*)
      DIMENSION TAG2(*)
      DIMENSION XIDTEM(*)
      DIMENSION XIDTE2(*)
      DIMENSION TEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='KCON'
      ISUBN2='S2  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X1(I),X2(I)
   56     FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LE.1)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,114)
  114   FORMAT('      VARIABLES FOR WHICH THE K CONSISTENCY ',
     1         'STATISTIC')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)
  115   FORMAT('      IS TO BE COMPUTED MUST BE 2 OR LARGER.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ****************************************************
C               **  STEP 2--                                      **
C               **  COMPUTE THE K CONSISTENCY STATISTIC           **
C               ****************************************************
C
      IWRITE='OFF'
      CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR)
      CALL SORT(XIDTEM,NUMSE1,XIDTEM)
      CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR)
      CALL SORT(XIDTE2,NUMSE2,XIDTE2)
C
      IF(NUMSE1.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,192)
  192   FORMAT('      NUMBER OF LABS    NUMSE1 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(NUMSE2.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,194)
  194   FORMAT('      NUMBER OF MATERIALS    NUMSE2 < 1')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      J=0
      DO1110ISET2=1,NUMSE2
C
        DSUM=0.0D0
        DO1130ISET1=1,NUMSE1
C
          K=0
          DO1140I=1,N
            IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN
              K=K+1
              TEMP(K)=Y(I)
            ENDIF
 1140     CONTINUE
          NTEMP=K
C
          CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR)
          DSUM=DSUM + DBLE(XSD)**2
          NOUT=(ISET2-1)*NUMSE1 + ISET1
          YOUT(NOUT)=XSD
          TAG(NOUT)=XIDTE2(ISET2)
          TAG2(NOUT)=XIDTEM(ISET1)
C
          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
            WRITE(ICOUT,1141)NUMSE1,NUMSE2,XSD
 1141       FORMAT('***** GROUP ',I8,' SD = ',G15.7)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
 1130   CONTINUE
C
        XREP=REAL(DSQRT(DSUM/DBLE(NUMSE1)))
        DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1
          YOUT(I)=YOUT(I)/XREP
 1150   CONTINUE
C
 1110 CONTINUE
      NOUT=NUMSE1*NUMSE2
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KCONS--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR
 9012   FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XREP
 9013   FORMAT('N,NUMSE1,NUMSE2,XREP = ',I8,1X,I8,1X,I8,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO9018I=1,NOUT
          WRITE(ICOUT,9019)I,TAG(I),YOUT(I)
 9019     FORMAT('I,TAG(I),YOUT(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9018   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE KENTAU(X,Y,N,ICASAN,IKTATA,IWRITE,XTEMP,YTEMP,MAXNXT,
     1                  XYKTAU,KTAUA,KTAUB,KTAUC,
     1                  STATCD,PVAL,PVALLT,PVALUT,
     1                  CUTU90,CUTU95,CTU975,CUTU99,CTU995,
     1                  CUTL90,CUTL95,CTL975,CUTL99,CTL995,
     1                  IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE KENDALL'S TAU COEFFICIENT
C              BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X, OR EQUIVALENTLY,
C                                THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--XYKTAU = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED KENDALL'S TAU
C                                COEFFICIENT BETWEEN THE 2 SETS OF
C                                DATA IN THE INPUT VECTORS X AND Y.
C                                THIS SINGLE PRECISION VALUE
C                                WILL BE BETWEEN -1.0 AND 1.0
C                                (INCLUSIVELY).
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             KENDALL'S TAU BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORTC.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--W. J. CONOVER, "PRACTICAL NON-PARAMETRIC
C                 STATISTICS", THIRD EDITION, WILEY, 1999,
C                 PP. 318-322.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/10
C     ORIGINAL VERSION--OCTOBER   2004.
C     UPDATED         --FEBRUARY  2013. RETURN CRITICAL VALUES FOR
C                                       SMALL SAMPLES, CDF/PVALUES
C                                       FOR LARGE SAMPLES
C     UPDATED         --AUGUST    2019. SUPPORT SOME DIFFERENT
C                                       FORMULATIONS OF KENDALL'S TAU
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASAN
      CHARACTER*4 IKTATA
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
C
      DIMENSION XTEMP(*)
      DIMENSION YTEMP(*)
C
      DIMENSION WP900(60)
      DIMENSION WP950(60)
      DIMENSION WP975(60)
      DIMENSION WP990(60)
      DIMENSION WP995(60)
C
      REAL KTAUA
      REAL KTAUB
      REAL KTAUC
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C     FOLLOWING VALUES ARE FROM TABLE A11 IN CONOVER.
C
      DATA WP900/
     1   0.0000, 0.0000, 0.0000, 0.6667, 0.6000, 0.4667, 0.4286, 0.3571,
     1   0.3333, 0.3333, 0.3091, 0.2727, 0.2821, 0.2527, 0.2571, 0.2333,
     1   0.2353, 0.2288, 0.2164, 0.2105, 0.2000, 0.1948, 0.1937, 0.1884,
     1   0.1867, 0.1815, 0.1738, 0.1746, 0.1675, 0.1678, 0.1613, 0.1613,
     1   0.1591, 0.1551, 0.1529, 0.1492, 0.1471, 0.1465, 0.1444, 0.1372,
     1   0.1390, 0.1382, 0.1362, 0.1353, 0.1333, 0.1304, 0.1304, 0.1277,
     1   0.1276, 0.1249, 0.1247, 0.1222, 0.1219, 0.1209, 0.1192, 0.1182,
     1   0.1165, 0.1155, 0.1151, 0.1141/
C
      DATA WP950/
     1   0.0000, 0.0000, 0.0000, 0.6667, 0.6000, 0.6000, 0.5238, 0.5000,
     1   0.4444, 0.4222, 0.3818, 0.3636, 0.3333, 0.3407, 0.3143, 0.3000,
     1   0.2941, 0.2810, 0.2749, 0.2632, 0.2571, 0.2554, 0.2490, 0.2391,
     1   0.2333, 0.2308, 0.2251, 0.2222, 0.2167, 0.2138, 0.2086, 0.2056,
     1   0.2008, 0.1979, 0.1933, 0.1905, 0.1892, 0.1863, 0.1849, 0.1821,
     1   0.1780, 0.1754, 0.1739, 0.1712, 0.1697, 0.1671, 0.1656, 0.1649,
     1   0.1616, 0.1608, 0.1592, 0.1569, 0.1553, 0.1544, 0.1529, 0.1506,
     1   0.1504, 0.1482, 0.1467, 0.1458/
C
      DATA WP975/
     1   0.0000, 0.0000, 0.0000, 1.0000, 0.8000, 0.7333, 0.6190, 0.5714,
     1   0.5000, 0.4667, 0.4545, 0.4242, 0.4103, 0.3846, 0.3714, 0.3667,
     1   0.3529, 0.3333, 0.3216, 0.3158, 0.3048, 0.2987, 0.2885, 0.2826,
     1   0.2800, 0.2738, 0.2650, 0.2593, 0.2562, 0.2506, 0.2473, 0.2419,
     1   0.2386, 0.2335, 0.2303, 0.2286, 0.2252, 0.2205, 0.2173, 0.2154,
     1   0.2122, 0.2102, 0.2071, 0.2051, 0.2020, 0.2000, 0.1970, 0.1950,
     1   0.1939, 0.1902, 0.1890, 0.1870, 0.1858, 0.1838, 0.1811, 0.1792,
     1   0.1779, 0.1760, 0.1748, 0.1729/
C
      DATA WP990/
     1   0.0000, 0.0000, 0.0000, 1.0000, 0.8000, 0.7333, 0.7143, 0.6429,
     1   0.6111, 0.5556, 0.5273, 0.5152, 0.4872, 0.4505, 0.4476, 0.4167,
     1   0.4118, 0.3987, 0.3801, 0.3684, 0.3619, 0.3506, 0.3439, 0.3333,
     1   0.3267, 0.3231, 0.3162, 0.3069, 0.3054, 0.2966, 0.2903, 0.2863,
     1   0.2841, 0.2763, 0.2739, 0.2698, 0.2643, 0.2603, 0.2578, 0.2538,
     1   0.2512, 0.2474, 0.2447, 0.2410, 0.2383, 0.2367, 0.2340, 0.2305,
     1   0.2279, 0.2261, 0.2235, 0.2217, 0.2192, 0.2173, 0.2148, 0.2130,
     1   0.2105, 0.2087, 0.2075, 0.2056/
C
      DATA WP995/
     1   0.0000, 0.0000, 0.0000, 1.0000, 1.0000, 0.8667, 0.8095, 0.7143,
     1   0.6667, 0.6000, 0.5636, 0.5455, 0.5285, 0.4945, 0.4857, 0.4667,
     1   0.4559, 0.4379, 0.4269, 0.4105, 0.4000, 0.3853, 0.3834, 0.3696,
     1   0.3600, 0.3538, 0.3504, 0.3386, 0.3350, 0.3287, 0.3204, 0.3185,
     1   0.3106, 0.3084, 0.3008, 0.2984, 0.2943, 0.2888, 0.2848, 0.2821,
     1   0.2780, 0.2729, 0.2713, 0.2664, 0.2646, 0.2618, 0.2581, 0.2553,
     1   0.2517, 0.2490, 0.2471, 0.2443, 0.2424, 0.2397, 0.2377, 0.2351,
     1   0.2331, 0.2305, 0.2285, 0.2271/
C
C-----START POINT-----------------------------------------------------
C
C     2019/08: NOTE THAT THERE ARE SEVERAL ALTERNATIVE FORMULATIONS
C              OF KENDALL'S TAU IN THE LITERATURE.  OUR ORIGINAL
C              IMPLEMENTATION IS FROM CONOVER WHICH IS:
C
C                 K = (Nc - Nd)/(Nc + Nd)
C
C              WHERE Nc IS THE NUMBER OF CONCORDANT PAIRS AND Nd IS THE
C              NUMBER OF DISCORDANT PAIRS.  THIS IS ALSO CALLED THE
C              GOODMAN AND KRUSKAL GAMMA COEFFICIENT.
C
C              KENDALL'S ORIGINAL FORMULATION IS:
C
C                K = (Nc - Nd)/{N*(N-1)/2}
C
C              THIS IS ALSO REFERRED TO AS KENDALL'S TAU-A IN THE
C              LITERATURE.
C
C              THE DISTINCTION BETWEEN THE 2 STATISTICS IS THAT THE
C              CONOVER (GAMMA) FORMULATION TAKES TIES INTO ACCOUNT WHILE
C              KENDALL'S TAU-A DOES NOT.
C
C              THERE ARE SEVERAL ADDITIONAL VARIANTS.  THESE USE
C              (Nc - Nd) IN THE NUMERATOR, BUT USE DIFFERENT
C              DENOMINATORS.
C
      ISUBN1='KENT'
      ISUBN2='AU  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NTAU')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF KENTAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ICASAN,IBUGA3,N
   52   FORMAT('ICASAN,IBUGA3,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
       ENDIF
C
C               ********************************************
C               **  COMPUTE RANK CORRELATION COEFFICIENT  **
C               ********************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1.OR.N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN KENDALLS TAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE  RESPONSE ',
     1         'VARIABLES')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)
  116   FORMAT('      SUCH WAS NOT THE CASE HERE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS   = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING IN KENDALLS TAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THE NUMBER OF PAIRS (N) HAS THE VALUE 1.')
        CALL DPWRST('XXX','BUG ')
        XYKTAU=1.0
        GOTO9000
      ENDIF
C
C               *************************************************
C               **  STEP 2--                                   **
C               **  COMPUTE THE RANK CORRELATION COEFFICIENT.  **
C               *************************************************
C
      CALL DISTIN(X,N,IWRITE,XTEMP,NXD,IBUGA3,IERROR)
      CALL DISTIN(Y,N,IWRITE,YTEMP,NYD,IBUGA3,IERROR)
      M=MIN(NXD,NYD)
      AM=REAL(M)
CCCCC CALL SORTC(X,Y,N,XTEMP,YTEMP)
C
      ANC=0.0
      AND=0.0
      AN=REAL(N)
      DENOM1=(AN/2.0)*(AN-1.0)
      TX=0.0
      TY=0.0
      TXY=0.0
      ANC2=0.0
      AND2=0.0
      AN1=0.0
      AN2=0.0
C
      NM1=N-1
      DO200J=1,NM1
        M=J+1
        DO300I=M,N
          ANUM=Y(J) - Y(I)
          ADENOM=X(J) - X(I)
          IF(ADENOM.NE.0.0)THEN
            RATIO=ANUM/ADENOM
            IF(RATIO.GT.0.0)THEN
              ANC=ANC+1.0
              ANC2=ANC2+1.0
            ELSEIF(RATIO.LT.0.0)THEN
              AND=AND+1.0
              AND2=AND2+1.0
            ELSE
              ANC=ANC+0.5
              AND=AND+0.5
              TY=TY+1.0
            ENDIF
          ELSE
            IF(Y(I).NE.Y(J))THEN
              TX=TX+1.0
            ELSE
              TXY=TXY+1.0
            ENDIF
          ENDIF
  300   CONTINUE
  200 CONTINUE
      XYKTAU=(ANC-AND)/(ANC+AND)
C
C     KENDALL'S TAU-A
C
      KTAUA=(ANC-AND)/DENOM1
C
C     KENDALL'S TAU-B
C
      DENOM2=SQRT((ANC2+AND2+TX)*(ANC2+AND2+TY))
      KTAUB=(ANC2-AND2)/DENOM2
C
C     KENDALL'S TAU-C
C
      DENOM3=(AM-1.0)/AM
      DENOM3=DENOM3*AN*AN
      KTAUC=2.0*(ANC2-AND2)/DENOM3
C
C               *************************************************
C               **  STEP 2B--                                  **
C               **  NOW COMPUTE CDF, PVALUE, AND CRITICAL      **
C               **  VALUES.                                    **
C               *************************************************
C
C     USE TABLED CRITICAL VALUES FROM TABLE A11 FOR N <= 60.  OTHERWISE,
C     USE
C
C           W(p) = Z(p)*SQRT(N*(2*N+5))/(3*SQRT(N*(N-1)))
C
C     ONLY COMPUTE THESE FOR CONOVER DEFINITION OF KENDALL'S TAU.
C
      AN=REAL(N)
      ANUM=SQRT(2.0*(2.0*AN+5.0))
      DENOM=3.0*SQRT(AN*(AN-1.0))
      AFACT=ANUM/DENOM
      ATEMP=XYKTAU/AFACT
      CALL NORCDF(ATEMP,STATCD)
      PVALLT=STATCD
      PVALUT=1.0 - STATCD
      PVAL=2.0*MIN(PVALLT,PVALUT)
C
      IF(N.GT.60 .OR. IKTATA.EQ.'NORM')THEN
        P=0.90
        CALL NORPPF(P,CUTU90)
        P=0.95
        CALL NORPPF(P,CUTU95)
        P=0.975
        CALL NORPPF(P,CTU975)
        P=0.99
        CALL NORPPF(P,CUTU99)
        P=0.995
        CALL NORPPF(P,CTU995)
        CUTU90=AFACT*CUTU90
        CUTU95=AFACT*CUTU95
        CTU975=AFACT*CTU975
        CUTU99=AFACT*CUTU99
        CTU995=AFACT*CTU995
      ELSE
        CUTU90=WP900(N)
        CUTU95=WP950(N)
        CTU975=WP975(N)
        CUTU99=WP990(N)
        CTU995=WP995(N)
      ENDIF
      CUTL90=-CUTU90
      CUTL95=-CUTU95
      CTL975=-CTU975
      CUTL95=-CUTU95
      CUTL99=-CUTU99
      CTL995=-CTU995
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XYKTAU
  811   FORMAT('THE KENDALLS TAU COEFFICIENT OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NTAU')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF KENTAU--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,ANC,AND,XYKTAU
 9012   FORMAT('IERROR,ANC,AND,XYKTAU = ',A4,2X,3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)KTAUA,KTAUB,KTAUC,TX,TY,TXY
 9014   FORMAT('KTAUA,KTAUB,KTAUC,TX,TY,TXY = ',6G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9016)ANC2,AND2,DENOM1,DENOM2,DENOM3,AM
 9016   FORMAT('ANC2,AND2,DENOM1,DENOM2,DENOM3,AM = ',6G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE KLVNA(X,BER,BEI,GER,GEI,DER,DEI,HER,HEI)
C
C       ======================================================
C       Purpose: Compute Kelvin functions ber x, bei x, ker x
C                and kei x, and their derivatives  ( x > 0 )
C       Input :  x   --- Argument of Kelvin functions
C       Output:  BER --- ber x
C                BEI --- bei x
C                GER --- ker x
C                GEI --- kei x
C                DER --- ber'x
C                DEI --- bei'x
C                HER --- ker'x
C                HEI --- kei'x
C       ================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        PI=3.141592653589793D0
        EL=.5772156649015329D0
        EPS=1.0D-15
        IF (X.EQ.0.0D0) THEN
           BER=1.0D0
           BEI=0.0D0
           GER=1.0D+300
           GEI=-0.25D0*PI
           DER=0.0D0
           DEI=0.0D0
           HER=-1.0D+300
           HEI=0.0D0
           RETURN
        ENDIF
        X2=0.25D0*X*X
        X4=X2*X2
        IF (DABS(X).LT.10.0D0) THEN
           BER=1.0D0
           R=1.0D0
           DO 10 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4
              BER=BER+R
              IF (DABS(R).LT.DABS(BER)*EPS) GO TO 15
10         CONTINUE
15         BEI=X2
           R=X2
           DO 20 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4
              BEI=BEI+R
              IF (DABS(R).LT.DABS(BEI)*EPS) GO TO 25
20         CONTINUE
25         GER=-(DLOG(X/2.0D0)+EL)*BER+0.25D0*PI*BEI
           R=1.0D0
           GS=0.0D0
           DO 30 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4
              GS=GS+1.0D0/(2.0D0*M-1.0D0)+1.0D0/(2.0D0*M)
              GER=GER+R*GS
              IF (DABS(R*GS).LT.DABS(GER)*EPS) GO TO 35
30         CONTINUE
35         GEI=X2-(DLOG(X/2.0D0)+EL)*BEI-0.25D0*PI*BER
           R=X2
           GS=1.0D0
           DO 40 M=1,60
              R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4
              GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2.0D0*M+1.0D0)
              GEI=GEI+R*GS
              IF (DABS(R*GS).LT.DABS(GEI)*EPS) GO TO 45
40         CONTINUE
45         DER=-0.25D0*X*X2
           R=DER
           DO 50 M=1,60
              R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4
              DER=DER+R
              IF (DABS(R).LT.DABS(DER)*EPS) GO TO 55
50         CONTINUE
55         DEI=0.5D0*X
           R=DEI
           DO 60 M=1,60
              R=-0.25D0*R/(M*M)/(2.D0*M-1.D0)/(2.D0*M+1.D0)*X4
              DEI=DEI+R
              IF (DABS(R).LT.DABS(DEI)*EPS) GO TO 65
60            CONTINUE
65         R=-0.25D0*X*X2
           GS=1.5D0
           HER=1.5D0*R-BER/X-(DLOG(X/2.D0)+EL)*DER+0.25*PI*DEI
           DO 70 M=1,60
              R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4
              GS=GS+1.0D0/(2*M+1.0D0)+1.0D0/(2*M+2.0D0)
              HER=HER+R*GS
              IF (DABS(R*GS).LT.DABS(HER)*EPS) GO TO 75
70         CONTINUE
75         R=0.5D0*X
           GS=1.0D0
           HEI=0.5D0*X-BEI/X-(DLOG(X/2.D0)+EL)*DEI-0.25*PI*DER
           DO 80 M=1,60
              R=-0.25D0*R/(M*M)/(2*M-1.0D0)/(2*M+1.0D0)*X4
              GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2*M+1.0D0)
              HEI=HEI+R*GS
              IF (DABS(R*GS).LT.DABS(HEI)*EPS) RETURN
80         CONTINUE
        ELSE
           PP0=1.0D0
           PN0=1.0D0
           QP0=0.0D0
           QN0=0.0D0
           R0=1.0D0
           KM=18
           IF (DABS(X).GE.40.0) KM=10
           FAC=1.0D0
           DO 85 K=1,KM
              FAC=-FAC
              XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI
              CS=COS(XT)
              SS=SIN(XT)
              R0=0.125D0*R0*(2.0D0*K-1.0D0)**2/K/X
              RC=R0*CS
              RS=R0*SS
              PP0=PP0+RC
              PN0=PN0+FAC*RC
              QP0=QP0+RS
              QN0=QN0+FAC*RS
85         CONTINUE
           XD=X/DSQRT(2.0D0)
           XE1=DEXP(XD)
           XE2=DEXP(-XD)
           XC1=1.D0/DSQRT(2.0D0*PI*X)
           XC2=DSQRT(.5D0*PI/X)
           CP0=DCOS(XD+0.125D0*PI)
           CN0=DCOS(XD-0.125D0*PI)
           SP0=DSIN(XD+0.125D0*PI)
           SN0=DSIN(XD-0.125D0*PI)
           GER=XC2*XE2*(PN0*CP0-QN0*SP0)
           GEI=XC2*XE2*(-PN0*SP0-QN0*CP0)
           BER=XC1*XE1*(PP0*CN0+QP0*SN0)-GEI/PI
           BEI=XC1*XE1*(PP0*SN0-QP0*CN0)+GER/PI
           PP1=1.0D0
           PN1=1.0D0
           QP1=0.0D0
           QN1=0.0D0
           R1=1.0D0
           FAC=1.0D0
           DO 90 K=1,KM
              FAC=-FAC
              XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI
              CS=DCOS(XT)
              SS=DSIN(XT)
              R1=0.125D0*R1*(4.D0-(2.0D0*K-1.0D0)**2)/K/X
              RC=R1*CS
              RS=R1*SS
              PP1=PP1+FAC*RC
              PN1=PN1+RC
              QP1=QP1+FAC*RS
              QN1=QN1+RS
90         CONTINUE
           HER=XC2*XE2*(-PN1*CN0+QN1*SN0)
           HEI=XC2*XE2*(PN1*SN0+QN1*CN0)
           DER=XC1*XE1*(PP1*CP0+QP1*SP0)-HEI/PI
           DEI=XC1*XE1*(PP1*SP0-QP1*CP0)+HER/PI
        ENDIF
        RETURN
        END
      SUBROUTINE KROBOV( NDIM, MINVLS, MAXVLS, FUNCTN, ABSEPS, RELEPS,
     &                   ABSERR, FINEST, INFORM )
*
*  Automatic Multidimensional Integration Subroutine
*
*         AUTHOR: Alan Genz
*                 Department of Mathematics
*                 Washington State University
*                 Pulman, WA 99164-3113
*                 Email: AlanGenz@wsu.edu
*
*         Last Change: 4/15/98
*
*  KROBOV computes an approximation to the integral
*
*      1  1     1
*     I  I ... I       F(X)  dx(NDIM)...dx(2)dx(1)
*      0  0     0
*
*
*  KROBOV uses randomized Korobov rules. The primary references are
*  "Randomization of Number Theoretic Methods for Multiple Integration"
*   R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14,
*  and
*   "Optimal Parameters for Multidimensional Integration",
*    P. Keast, SIAM J Numer Anal, 10, pp.831-838.
*
***************  Parameters ********************************************
****** Input parameters
*  NDIM    Number of variables, must exceed 1, but not exceed 40
*  MINVLS  Integer minimum number of function evaluations allowed.
*          MINVLS must not exceed MAXVLS.  If MINVLS < 0 then the
*          routine assumes a previous call has been made with
*          the same integrand and continues that calculation.
*  MAXVLS  Integer maximum number of function evaluations allowed.
*  FUNCTN  EXTERNALly declared user defined function to be integrated.
*          It must have parameters (NDIM,Z), where Z is a real array
*          of dimension NDIM.
*  ABSEPS  Required absolute accuracy.
*  RELEPS  Required relative accuracy.
****** Output parameters
*  MINVLS  Actual number of function evaluations used.
*  ABSERR  Estimated absolute accuracy of FINEST.
*  FINEST  Estimated value of integral.
*  INFORM  INFORM = 0 for normal exit, when
*                     ABSERR <= MAX(ABSEPS, RELEPS*ABS(FINEST))
*                  and
*                     INTVLS <= MAXCLS.
*          INFORM = 1 If MAXVLS was too small to obtain the required
*          accuracy. In this case a value FINEST is returned with
*          estimated absolute accuracy ABSERR.
************************************************************************
      EXTERNAL FUNCTN
      INTEGER NDIM, MINVLS, MAXVLS, INFORM, NP, PLIM, NLIM,
     &        SAMPLS, I, INTVLS, MINSMP
      PARAMETER ( PLIM = 20, NLIM = 100, MINSMP = 6 )
      INTEGER C(PLIM,NLIM), P(PLIM)
      DOUBLE PRECISION FUNCTN, ABSEPS, RELEPS, FINEST, ABSERR, DIFINT,
     &       FINVAL, VARSQR, VAREST, VARPRD, VALUE
      DOUBLE PRECISION ALPHA(NLIM), X(NLIM), VK(NLIM), ONE
      PARAMETER ( ONE = 1 )
      SAVE P, C, SAMPLS, NP, VAREST
C
      DATA P( 1), ( C( 1,I), I = 1, 99 ) /    113,
     &     42,    54,    55,    32,    13,    26,    26,    13,    26,
     &     14,    13,    26,    35,     2,     2,     2,     2,    56,
     &     28,     7,     7,    28,     4,    49,     4,    40,    48,
     &      5,    35,    27,    16,    16,     2,     2,     7,    28,
     &      4,    49,     4,    56,     8,     2,     2,    56,     7,
     &     16,    28,     7,     7,    28,     4,    49,     4,    37,
     &     55,    21,    33,    40,    16,    16,    28,     7,    16,
     &     28,     4,    49,     4,    56,    35,     2,     2,     2,
     &     16,    16,    28,     4,    16,    28,     4,    49,     4,
     &     40,    40,     5,    42,    27,    16,    16,    28,     4,
     &     16,    28,     4,    49,     4,     8,     8,     2,     2/
      DATA P( 2), ( C( 2,I), I = 1, 99 ) /    173,
     &     64,    34,    57,     9,    72,    86,    16,    75,    75,
     &     70,    42,     2,    86,    62,    62,    30,    30,     5,
     &     42,    70,    70,    70,    53,    70,    70,    53,    42,
     &     62,    53,    53,    53,    69,    75,     5,    53,    86,
     &      2,     5,    30,    75,    59,     2,    69,     5,     5,
     &     63,    62,     5,    69,    30,    44,    30,    86,    86,
     &      2,    69,     5,     5,     2,     2,    61,    69,    17,
     &      2,     2,     2,    53,    69,     2,     2,    86,    69,
     &     13,     2,     2,    37,    43,    65,     2,     2,    30,
     &     86,    45,    16,    32,    18,    86,    86,    86,     9,
     &     63,    63,    11,    76,    76,    76,    63,    60,    70/
      DATA P( 3), ( C( 3,I), I = 1, 99 ) /    263,
     &    111,    67,    98,    36,    48,   110,     2,   131,     2,
     &      2,   124,   124,    48,     2,     2,   124,   124,    70,
     &     70,    48,   126,    48,   126,    56,    65,    48,    48,
     &     70,     2,    92,   124,    92,   126,   131,   124,    70,
     &     70,    70,    20,   105,    70,     2,     2,    27,   108,
     &     27,    39,     2,   131,   131,    92,    92,    48,     2,
     &    126,    20,   126,     2,     2,   131,    38,   117,     2,
     &    131,    68,    58,    38,    90,    38,   108,    38,     2,
     &    131,   131,   131,    68,    14,    94,   131,   131,   131,
     &    108,    18,   131,    56,    85,   117,   117,     9,   131,
     &    131,    55,    92,    92,    92,   131,   131,    48,    48/
      DATA P( 4), ( C( 4,I), I = 1, 99 ) /    397,
     &    151,   168,    46,   197,    69,    64,     2,   198,   191,
     &    134,   134,   167,   124,    16,   124,   124,   124,   124,
     &    141,   134,   128,     2,     2,    32,    32,    32,    31,
     &     31,    64,    64,    99,     4,     4,   167,   124,   124,
     &    124,   124,   124,   124,   107,    85,    79,    85,   111,
     &     85,   128,    31,    31,    31,    31,    64,   167,     4,
     &    107,   167,   124,   124,   124,   124,   124,   124,   107,
     &    183,     2,     2,     2,    62,    32,    31,    31,    31,
     &     31,    31,   167,     4,   107,   167,   124,   124,   124,
     &    124,   124,   124,   107,   142,   184,   184,    65,    65,
     &    183,    31,    31,    31,    31,    31,   167,     4,   107/
      DATA P( 5), ( C( 5,I), I = 1, 99 ) /    593,
     &    229,    40,   268,    42,   153,   294,    71,     2,   130,
     &    199,   199,   199,   149,   199,   149,   153,   130,   149,
     &    149,    15,   119,   294,    31,    82,   260,   122,   209,
     &    209,   122,   296,   130,   130,   260,   260,    30,   206,
     &     94,   209,    94,   122,   209,   209,   122,   122,   209,
     &    130,     2,   130,   130,    38,    38,    79,    82,    94,
     &     82,   122,   122,   209,   209,   122,   122,   168,   220,
     &     62,    60,   168,   282,   282,    82,   209,   122,    94,
     &    209,   122,   122,   122,   122,   258,   148,   286,   256,
     &    256,    62,    62,    82,   122,    82,    82,   122,   122,
     &    122,   209,   122,    15,    79,    79,    79,    79,   168/
      DATA P( 6), ( C( 6,I), I = 1, 99 ) /    907,
     &    264,   402,   406,   147,   452,   153,   224,     2,     2,
     &    224,   224,   449,   101,   182,   449,   101,   451,   181,
     &    181,   101,   101,   377,    85,   453,   453,   453,    85,
     &    197,   451,     2,     2,   101,   449,   449,   449,   173,
     &    173,     2,   453,   453,     2,   426,    66,   367,   426,
     &    101,   453,     2,    32,    32,    32,   101,     2,     2,
     &    453,   223,   147,   449,   290,     2,   453,     2,    83,
     &    223,   101,   453,     2,    83,    83,   147,     2,   453,
     &    147,   147,   147,   147,   147,   147,   147,   453,   153,
     &    153,   147,     2,   224,   290,   320,   453,   147,   431,
     &    383,   290,   290,     2,   162,   162,   147,     2,   162/
      DATA P( 7), ( C( 7,I), I = 1, 99 ) /   1361,
     &    505,   220,   195,   410,   199,   248,   460,   471,     2,
     &    331,   662,   547,   209,   547,   547,   209,     2,   680,
     &    680,   629,   370,   574,    63,    63,   259,   268,   259,
     &    547,   209,   209,   209,   547,   547,   209,   209,   547,
     &    547,   108,    63,    63,   108,    63,    63,   108,   259,
     &    268,   268,   547,   209,   209,   209,   209,   547,   209,
     &    209,   209,   547,   108,    63,    63,    63,   405,   285,
     &    234,   259,   259,   259,   259,   209,   209,   209,   209,
     &    209,   209,   209,   209,   547,   289,   289,   234,   285,
     &    316,     2,   410,   259,   259,   259,   268,   209,   209,
     &    209,   209,   547,   547,   209,   209,   209,   285,   316/
      DATA P( 8), ( C( 8,I), I = 1, 99 ) /   2053,
     &    468,   635,   849,   687,   948,    37,  1014,   513,     2,
     &      2,     2,     2,     2,  1026,     2,     2,  1026,   201,
     &    201,     2,  1026,   413,  1026,  1026,     2,     2,   703,
     &    703,     2,     2,   393,   393,   678,   413,  1026,     2,
     &      2,  1026,  1026,     2,   405,   953,     2,  1026,   123,
     &    123,   953,   953,   123,   405,   794,   123,   647,   613,
     &   1026,   647,   768,   953,   405,   953,   405,   918,   918,
     &    123,   953,   953,   918,   953,   536,   405,    70,   124,
     &   1005,   529,   207,   405,   405,   953,   953,   123,   918,
     &    918,   953,   405,   918,   953,   468,   405,   794,   794,
     &    647,   613,   548,   405,   953,   405,   953,   123,   918/
      DATA P( 9), ( C( 9,I), I = 1, 99 ) /   3079,
     &   1189,  1423,   287,   186,   341,    77,   733,   733,  1116,
     &      2,  1539,     2,     2,     2,     2,     2,  1116,   847,
     &   1174,     2,   827,   713,   910,   944,   139,  1174,  1174,
     &   1539,  1397,  1397,  1174,   370,    33,  1210,     2,   370,
     &   1423,   370,   370,  1423,  1423,  1423,   434,  1423,   901,
     &    139,  1174,   427,   427,   200,  1247,   114,   114,  1441,
     &    139,   728,  1116,  1174,   139,   113,   113,   113,  1406,
     &   1247,   200,   200,   200,   200,  1247,  1247,    27,   427,
     &    427,  1122,  1122,   696,   696,   427,  1539,   435,  1122,
     &    758,  1247,  1247,  1247,   200,   200,   200,  1247,   114,
     &     27,   118,   118,   113,   118,   453,   453,  1084,  1406/
      DATA P(10), ( C(10,I), I = 1, 99 ) /   4621,
     &   1764,  1349,  1859,   693,    78,   438,   531,    68,  2234,
     &   2310,  2310,  2310,     2,  2310,  2310,  2102,  2102,   178,
     &    314,   921,  1074,  1074,  1074,  2147,   314,  1869,   178,
     &    178,  1324,  1324,   510,  2309,  1541,  1541,  1541,  1541,
     &    342,  1324,  1324,  1324,  1324,   510,   570,   570,  2197,
     &    173,  1202,   998,  1324,  1324,   178,  1324,  1324,  1541,
     &   1541,  1541,   342,  1541,   886,   178,  1324,  1324,  1324,
     &    510,   784,   784,   501,   652,  1541,  1541,  1324,   178,
     &   1324,   178,  1324,  1541,   342,  1541,  2144,   784,  2132,
     &   1324,  1324,  1324,  1324,   510,   652,  1804,  1541,  1541,
     &   1541,  2132,  1324,  1324,  1324,   178,   510,  1541,   652/
      DATA P(11), ( C(11,I), I = 1, 99 ) /   6947,
     &   2872,  1238,   387,  2135,   235,  1565,   221,  1515,  2950,
     &    486,  3473,     2,  2950,   982,  2950,  3122,  2950,  3172,
     &   2091,  2091,     9,  3449,  3122,  2846,  3122,  3122,  1947,
     &   2846,  3122,   772,  1387,  2895,  1387,     3,     3,     3,
     &   1320,  1320,  2963,  2963,  1320,  1320,  2380,   108,  1284,
     &    702,  1429,   907,  3220,  3125,  1320,  2963,  1320,  1320,
     &   2963,  1320,  1639,  3168,  1660,  2895,  2895,  2895,  2895,
     &   1639,  1297,  1639,   404,  3168,  2963,  2943,  2943,   550,
     &   1387,  1387,  2895,  2895,  2895,  1387,  2895,  1387,  2895,
     &   1320,  1320,  2963,  1320,  1320,  1320,  2963,  1320,     2,
     &   3473,     2,  3473,   772,  2550,     9,  1320,  2963,  1320/
      DATA P(12), ( C(12,I), I = 1, 99 ) /  10427,
     &   4309,  2339,  4154,  4480,  4967,   630,  5212,  2592,  4715,
     &   1808,  1808,  5213,     2,   216,  4014,  3499,  3499,  4204,
     &   2701,  2701,  5213,  4157,  1209,  4157,  4460,   335,  4460,
     &   1533,  4575,  4013,  4460,  1881,  2701,  4030,  4030,  1881,
     &   4030,  1738,   249,   335,    57,  2561,  2561,  2561,  1533,
     &   1533,  1533,  4013,  4013,  4013,  4013,  4013,  1533,   856,
     &    856,   468,   468,   468,  2561,   468,  2022,  2022,  2434,
     &    138,  4605,  1100,  2561,  2561,    57,    57,  3249,   468,
     &    468,   468,    57,   468,  1738,   313,   856,     6,  3877,
     &    468,   557,   468,    57,   468,  4605,  2022,     2,  4605,
     &    138,  1100,    57,  2561,    57,    57,  2022,  5213,  3249/
      DATA P(13), ( C(13,I), I = 1, 99 ) /  15641,
     &   6610,  1658,  3022,  2603,  5211,   265,  4985,     3,  4971,
     &   2127,  1877,  1877,     2,  2925,  3175,  3878,  1940,  1940,
     &   1940,  5117,  5117,  5771,  5117,  5117,  5117,  5117,  5117,
     &   5771,  5771,  5117,  3658,  3658,  3658,  3658,  3658,  3658,
     &   5255,  2925,  2619,  1714,  4100,  6718,  6718,  4100,  2322,
     &    842,  4100,  6718,  5119,  4728,  5255,  5771,  5771,  5771,
     &   5117,  5771,  5117,  5117,  5117,  5117,  5117,  5117,  5771,
     &   5771,  1868,  4483,  4728,  3658,  5255,  3658,  5255,  3658,
     &   3658,  5255,  5255,  3658,  6718,  6718,   842,  2322,  6718,
     &   4100,  6718,  4100,  4100,  5117,  5771,  5771,  5117,  5771,
     &   5771,  5771,  5771,  5117,  5117,  5117,  5771,  5771,  1868/
      DATA P(14), ( C(14,I), I = 1, 99 ) /  23473,
     &   9861,  7101,  6257,  7878, 11170, 11638,  7542,  2592,  2591,
     &   6074,  1428,  8925, 11736,  8925,  5623,  5623,  1535,  6759,
     &   9953,  9953, 11459,  9953,  7615,  7615, 11377, 11377,  2762,
     &  11734, 11459,  6892,  1535,  6759,  4695,  1535,  6892,     2,
     &      2,  6892,  6892,  4177,  4177,  6339,  6950,  1226,  1226,
     &   1226,  4177,  6892,  6890,  3640,  3640,  1226, 10590, 10590,
     &   6950,  6950,  6950,  1226,  6950,  6950,  7586,  7586,  7565,
     &   7565,  3640,  3640,  6950,  7565,  6950,  3599,  3599,  3599,
     &   2441,  4885,  4885,  4885,  7565,  7565,  1226,  1226,  1226,
     &   6950,  7586,  1346,  2441,  6339,  3640,  6950, 10590,  6339,
     &   6950,  6950,  6950,  1226,  1226,  6950,   836,  6891,  7565/
      DATA P(15), ( C(15,I), I = 1, 99 ) /  35221,
     &  13482,  5629,  6068, 11974,  4732, 14946, 12097, 17609, 11740,
     &  15170, 10478, 10478, 17610,     2,     2,  7064,  7064,  7064,
     &   5665,  1771,  2947,  4453, 12323, 17610, 14809, 14809,  5665,
     &   5665,  2947,  2947,  2947,  2947, 12323, 12323,  4453,  4453,
     &   2026, 11772,  2026, 11665, 12323, 12323,  3582,  2940,  2940,
     &   6654,  4449,  9254, 11470,   304,   304, 11470,   304, 11470,
     &   6156,  9254, 11772,  6654, 11772,  6156, 11470, 11470, 11772,
     &  11772, 11772, 11470, 11470,   304, 11470, 11470,   304, 11470,
     &    304, 11470,   304,   304,   304,  6654, 11508,   304,   304,
     &   6156,  3582, 11470, 11470, 11470, 17274,  6654,  6654,  6744,
     &   6711,  6654,  6156,  3370,  6654, 12134,  3370,  6654,  3582/
      DATA P(16), ( C(16,I), I = 1, 99 ) /  52837,
     &  13482,  5629,  6068, 11974,  4732, 14946, 12097, 17609, 11740,
     &  15170, 10478, 10478, 17610,     2,     2,  7064,  7064,  7064,
     &   5665,  1771,  2947,  4453, 12323, 17610, 14809, 14809,  5665,
     &   5665,  2947,  2947,  2947,  2947, 12323, 12323,  4453,  4453,
     &   2026, 11772,  2026, 11665, 12323, 12323,  3582,  2940,  2940,
     &   6654,  4449,  9254, 11470,   304,   304, 11470,   304, 11470,
     &   6156,  9254, 11772,  6654, 11772,  6156, 11470, 11470, 11772,
     &  11772, 11772, 11470, 11470,   304, 11470, 11470,   304, 11470,
     &    304, 11470,   304,   304,   304,  6654, 11508,   304,   304,
     &   6156,  3582, 11470, 11470, 11470, 17274,  6654,  6654,  6744,
     &   6711,  6654,  6156,  3370,  6654, 12134,  3370,  6654,  3582/
      DATA P(17), ( C(17,I), I = 1, 99 ) /  79259,
     &  34566, 38838, 23965, 17279, 35325, 33471,   330, 36050, 26419,
     &   3012, 38428, 36430, 36430, 36755, 39629,  5749,  5749, 36755,
     &   5749, 14353, 14353, 14353, 32395, 32395, 32395, 32395, 32396,
     &  32396, 32396, 32396, 27739, 14353, 36430, 36430, 36430, 15727,
     &  38428, 28987, 28987, 27739, 38428, 27739, 18786, 14353, 15727,
     &  28987, 19151, 19757, 19757, 19757, 14353, 22876, 19151, 24737,
     &  24737,  4412, 30567, 30537, 19757, 30537, 19757, 30537, 30537,
     &   4412, 24737, 28987, 19757, 19757, 19757, 30537, 30537, 33186,
     &   4010,  4010,  4010, 17307, 15217, 32789, 37709,  4010,  4010,
     &   4010, 33186, 33186,  4010, 11057, 39388, 33186,  1122, 15089,
     &  39629,     2,     2, 23899, 16466, 16466, 17038,  9477,  9260/
      DATA P(18), ( C(18,I), I = 1, 99 ) / 118891,
     &  31929, 40295,  2610,  5177, 17271, 23770,  9140,   952, 39631,
     &      3, 11424, 49719, 38267, 25172,     2,     2, 59445,     2,
     &  59445, 38267, 44358, 14673, 53892, 14674, 14673, 14674, 41368,
     &  17875, 17875, 30190, 20444, 55869, 15644, 25499, 15644, 20983,
     &  44358, 15644, 15644,   485, 41428,   485,   485,   485, 41428,
     &  53798, 50230, 53798, 50253, 50253, 35677, 35677, 17474,  7592,
     &   4098, 17474,   485, 41428,   485, 41428,   485, 41428,   485,
     &  41428, 41428, 41428, 41428, 41428,  9020, 22816,  4098,  4098,
     &   4098,  7592, 42517,   485, 50006, 50006, 22816, 22816,  9020,
     &    485, 41428, 41428, 41428, 41428, 50006,   485, 41428, 41428,
     &  41428, 41428, 22816, 41428, 41428,   485,   485,   485,  9020/
      DATA P(19), ( C(19,I), I = 1, 99 ) / 178349,
     &  73726, 16352, 16297, 74268, 60788,  8555,  1077, 25486, 86595,
     &  59450, 19958, 62205, 62205,  4825,  4825, 89174, 89174, 62205,
     &  19958, 62205, 19958, 27626, 63080, 62205, 62205, 62205, 19958,
     &   8914, 83856, 30760, 47774, 47774, 19958, 62205, 39865, 39865,
     &  74988, 75715, 75715, 74988, 34522, 74988, 74988, 25101, 44621,
     &  44621, 44621, 25101, 25101, 25101, 44621, 47768, 41547, 44621,
     &  10273, 74988, 74988, 74988, 74988, 74988, 74988, 34522, 34522,
     &  67796, 67796, 30208,     2, 67062, 18500, 29251, 29251,     2,
     &  67796, 67062, 38649, 59302,  6225, 67062,  6475,  6225, 46772,
     &  38649, 67062, 46772, 46772, 67062, 46772, 25372, 67062,  6475,
     &  25372, 67062, 67062, 67062,  6225, 67062, 67062, 68247, 80676/
      DATA P(20), ( C(20,I), I = 1, 99 )/ 267523,
     & 103650, 50089, 70223, 41805, 74847,112775, 40889, 64866, 44053,
     &   1754,129471, 13630, 53467, 53467, 61378,133761,     2,133761,
     &      2,133761,133761, 65531, 65531, 65531, 38080,133761,133761,
     & 131061,  5431, 65531, 78250, 11397, 38841, 38841,107233,107233,
     & 111286, 19065, 38841, 19065, 19065, 16099,127638, 82411, 96659,
     &  96659, 82411, 96659, 82411, 51986,101677, 39264, 39264,101677,
     &  39264, 39264, 47996, 96659, 82411, 47996, 10971, 10004, 82411,
     &  96659, 82411, 82411, 82411, 96659, 96659, 96659, 82411, 96659,
     &  51986,110913, 51986, 51986,110913, 82411, 54713, 54713, 22360,
     & 117652, 22360, 78250, 78250, 91996, 22360, 91996, 97781, 91996,
     &  97781, 91996, 97781, 97781, 91996, 97781, 97781, 36249, 39779/
C
      INFORM = 1
      INTVLS = 0
      IF ( MINVLS .GE. 0 ) THEN
         FINEST = 0
         VAREST = 0
         SAMPLS = MINSMP
         DO 100 I = 1, PLIM
            NP = I
            IF ( MINVLS .LT. 2*SAMPLS*P(I) ) GO TO 10
 100     CONTINUE
         SAMPLS = MAX( MINSMP, MINVLS/( 2*P(NP) ) )
      ENDIF
 10   VK(1) = ONE/P(NP)
      DO 200 I = 2, NDIM
         VK(I) = MOD( C(NP,NDIM-1)*VK(I-1), ONE )
 200  CONTINUE
      FINVAL = 0
      VARSQR = 0
      DO 300 I = 1, SAMPLS
         CALL KROSUM( NDIM, VALUE, P(NP), VK, FUNCTN, ALPHA, X )
         DIFINT = ( VALUE - FINVAL )/I
         FINVAL = FINVAL + DIFINT
         VARSQR = ( I - 2 )*VARSQR/I + DIFINT**2
 300  CONTINUE
      INTVLS = INTVLS + 2*SAMPLS*P(NP)
      VARPRD = VAREST*VARSQR
      FINEST = FINEST + ( FINVAL - FINEST )/( 1 + VARPRD )
      IF ( VARSQR .GT. 0 ) VAREST = ( 1 + VARPRD )/VARSQR
      ABSERR = 3*SQRT( VARSQR/( 1 + VARPRD ) )
      IF ( ABSERR .GT. MAX( ABSEPS, ABS(FINEST)*RELEPS ) ) THEN
         IF ( NP .LT. PLIM ) THEN
            NP = NP + 1
         ELSE
            SAMPLS = MIN( 3*SAMPLS/2, ( MAXVLS - INTVLS )/( 2*P(NP) ) )
            SAMPLS = MAX( MINSMP, SAMPLS )
         ENDIF
         IF ( INTVLS + 2*SAMPLS*P(NP) .LE. MAXVLS ) GO TO 10
      ELSE
         INFORM = 0
      ENDIF
      MINVLS = INTVLS
C
      RETURN
      END
      SUBROUTINE KROMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
*
*     A subroutine for computing multivariate normal probabilities.
*     This subroutine uses an algorithm given in the paper
*     "Numerical Computation of Multivariate Normal Probabilities", in
*     J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS REAL absolute error tolerance.
*     RELEPS REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 100 or N < 1.
*
      EXTERNAL MVNFNC
      INTEGER N, INFIN(*), MAXPTS, INFORM, INFIS, IVLS
      DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS,
     &       ERROR, VALUE, E, D, MVNNIT, MVNFNC,DVAL
      IF ( N .GT. 100 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
      ELSE
         DVAL = MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E)
         INFORM = INT(DVAL)
         IF ( N-INFIS .EQ. 0 ) THEN
            VALUE = 1
            ERROR = 0
         ELSE IF ( N-INFIS .EQ. 1 ) THEN
            VALUE = E - D
            ERROR = 2E-16
         ELSE
*
*        Call the lattice rule integration subroutine
*
            IVLS = 0
            CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, MVNFNC,
     &                   ABSEPS, RELEPS, ERROR, VALUE, INFORM )
         ENDIF
      ENDIF
      END
      SUBROUTINE KROMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS,
     *      ABSEPS, RELEPS, ERROR, VALUE, INFORM)
*
*     A subroutine for computing multivariate t probabilities.
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : AlanGenz@wsu.edu
*
*  Parameters
*
*     N      INTEGER, the number of variables.
*     NU     INTEGER, the number of degrees of freedom.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) < 0, Ith limits are (-infinity, infinity);
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, array of correlation coefficients; the correlation
*            coefficient in row I column J of the correlation matrix
*            should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I.
*     MAXPTS INTEGER, maximum number of function values allowed. This
*            parameter can be used to limit the time. A sensible
*            strategy is to start with MAXPTS = 1000*N, and then
*            increase MAXPTS if ERROR is too large.
*     ABSEPS    REAL absolute error tolerance.
*     RELEPS    REAL relative error tolerance.
*     ERROR  REAL estimated absolute error, with 99% confidence level.
*     VALUE  REAL estimated value for the integral
*     INFORM INTEGER, termination status parameter:
*            if INFORM = 0, normal completion with ERROR < EPS;
*            if INFORM = 1, completion with ERROR > EPS and MAXPTS
*                           function vaules used; increase MAXPTS to
*                           decrease ERROR;
*            if INFORM = 2, N > 20 or N < 1.
*
      DOUBLE PRECISION FNCMVT
      EXTERNAL FNCMVT
      INTEGER N, NU, INFIN(*), MAXPTS, INFORM, INFIS, IVLS
      DOUBLE PRECISION
     *     CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS,
     *     ERROR, VALUE, E, D, MVTNIT,DVAL
C
      IF ( N .GT. 20 .OR. N .LT. 1 ) THEN
         INFORM = 2
         VALUE = 0
         ERROR = 1
         RETURN
      ENDIF
      DVAL = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E )
      INFORM = INT(DVAL)
      IF ( N-INFIS .EQ. 0 ) THEN
         VALUE = 1
         ERROR = 0
      ELSE IF ( N-INFIS .EQ. 1 ) THEN
         VALUE = E - D
         ERROR = 2E-16
      ELSE
*
*        Call the lattice rule integration integration subroutine
*
         IVLS = 0
         CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, FNCMVT, ABSEPS, RELEPS,
     *                ERROR, VALUE, INFORM )
      ENDIF
      RETURN
      END
      SUBROUTINE KROSUM( NDIM, SUMKRO, PRIME, VK, FUNCTN, ALPHA, X )
      EXTERNAL FUNCTN
      INTEGER NDIM, PRIME, K, J
      DOUBLE PRECISION SUMKRO, VK(*), FUNCTN, ALPHA(*), X(*), ONE, UNI
      PARAMETER ( ONE = 1 )
      SUMKRO = 0
      IRESET=0
      DO 100 J = 1, NDIM
         ALPHA(J) = UNI(IRESET)
 100  CONTINUE
      DO 200 K = 1, PRIME
         DO 300 J = 1, NDIM
            X(J) = MOD( K*VK(J) + ALPHA(J), ONE )
            X(J) = ABS( 2*X(J) - 1 )
 300     CONTINUE
         SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K - 1 )
         DO 400 J = 1, NDIM
            X(J) = 1 - X(J)
 400     CONTINUE
         SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K )
 200  CONTINUE
C
      RETURN
      END
      SUBROUTINE KTRADE (W, K, WPRIME, KPRIME, WS, R)
C
C        ALGORITHM AS 304.3 APPL.STATIST. (1996), VOL.45, NO.3
C
C        Generates and sorts the sums of the R-combinations of the
C        elements of W
C
C        DATAPLOT NOTE: UTILITY ROUTINE USED BY FISHER TWO SAMPLE
C                       RANDOMIZATION TEST
C
      INTEGER K, KPRIME, WS(*), R
      REAL W(*), WPRIME(*)
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
CCCCC INTEGER COMB
CCCCC REAL SUM
CCCCC EXTERNAL COMB, SUM
      REAL BINOM
      EXTERNAL BINOM
      EXTERNAL CMPLMT, GENER, SORTSH
C
      IWRITE='OFF'
      IBUGA3='OFF'
      IERROR='OFF'
C
CCCCC KPRIME = COMB(K, R)
      KPRIME = INT(BINOM(K, R)+0.5)
      IF (R .LE. K - R .OR. R .EQ. K) THEN
         CALL GENER(W, K, WPRIME, KPRIME, WS, R)
         CALL SORTSH(WPRIME, KPRIME)
      ELSE
         CALL GENER(W, K, WPRIME, KPRIME, WS, K - R)
         CALL SORTSH(WPRIME, KPRIME)
         CALL SUMDP(W,K,IWRITE,SUMWK,IBUGA3,IERROR)
CCCCC    CALL CMPLMT(WPRIME, KPRIME, SUM(W, K))
         CALL CMPLMT(WPRIME, KPRIME, SUMWK)
      ENDIF
C
      RETURN
      END
      SUBROUTINE KUMCDF(X,ALPHA,BETA,CDF)
C
C     NOTE--KUMARASWAMY CDF IS:
C
C           F(X;ALPHA,BETA) = 1 - (1 - X**ALPHA)**BETA
C                             0 <= X <= 1; ALPHA, BETA > 0
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KUMARASWAMY (1980), "A GENERALIZED PROBABILITY
C                DENSITY FUNCTION FOR DOUBLE-BOUNDED RANDOM
C                PROCESSES", JOURNAL OF HYDROLOGY 46: 79-88.
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0D0
C
CCCCC IF(X.LT.0.0D0 .OR. X.GT.1.0D0)THEN
CCCCC   WRITE(ICOUT,101)
CC101   FORMAT('***** ERROR--THE FIRST ARGUMENT TO KUMCDF IS ',
CCCCC1         'OUTSIDE THE (0,1) INTERVAL.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,102)X
  102   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9000
CCCCC ELSEIF(ALPHA.LE.0.0D0)THEN
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KUMCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KUMCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0D0)THEN
        CDF=0.0
      ELSEIF(X.GE.1.0D0)THEN
        CDF=1.0D0
      ELSE
        CDF=1.0D0 - (1.0D0 - X**ALPHA)**BETA
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KUMPDF(X,ALPHA,BETA,PDF)
C
C     NOTE--KUMARASWAMY PDF IS:
C
C           f(X;ALPHA,BETA) = ALPHA*BETA*X**(ALPHA-1)*
C                             (1-X**ALPHA)**(BETA-1)
C                             0 <= X <= 1; ALPHA, BETA > 0
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KUMARASWAMY (1980), "A GENERALIZED PROBABILITY
C                DENSITY FUNCTION FOR DOUBLE-BOUNDED RANDOM
C                PROCESSES", JOURNAL OF HYDROLOGY 46: 79-88.
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0D0
C
      IF(X.LE.0.0D0 .OR. X.GE.1.0D0)THEN
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR--THE FIRST ARGUMENT TO KUMPDF IS ',
     1         'OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)X
  102   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KUMPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KUMPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=DLOG(ALPHA) + DLOG(BETA)
      TERM2=(ALPHA-1.0D0)*DLOG(X)
      TERM3=(BETA-1.0D0)*DLOG(1.0D0 - X**ALPHA)
      TERM4=TERM1+TERM2+TERM3
      PDF=DEXP(TERM4)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KUMPPF(P,ALPHA,BETA,PPF)
C
C     NOTE--KUMARASWAMY PPF IS:
C
C           G(P;ALPHA,BETA) = [1 - (1-P)**((1/BETA)]**(1/ALPHA)
C                             0 < P < 1; ALPHA, BETA > 0
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KUMARASWAMY (1980), "A GENERALIZED PROBABILITY
C                DENSITY FUNCTION FOR DOUBLE-BOUNDED RANDOM
C                PROCESSES", JOURNAL OF HYDROLOGY 46: 79-88.
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0D0
C
      IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR--THE FIRST ARGUMENT TO KUMPPF IS ',
     1         'OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)X
  102   FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR--THE SECOND ARGUMENT TO KUMPPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE THIRD ARGUMENT TO KUMPPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(P.LE.0.0D0)THEN
        PPF=0.0
      ELSEIF(P.GE.1.0D0)THEN
        PPF=1.0D0
      ELSE
        PPF=(1.0D0 - (1.0D0 - P)**(1.0D0/BETA))**(1.0D0/ALPHA)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE KUMRAN(N,ALPHA,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE KUMARASWAMY
C              DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION FIRST SHAPE
C                                PARAMETER
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER BETA.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE KUMARASWAMY
C             DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, KUMPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--KUMARASWAMY (1980), "A GENERALIZED PROBABILITY
C                DENSITY FUNCTION FOR DOUBLE-BOUNDED RANDOM
C                PROCESSES", JOURNAL OF HYDROLOGY 46: 79-88.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHMOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/10
C     ORIGINAL VERSION--OCTOBER   2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DTEMP
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF KUMARASWAMY')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      IF(BETA.LE.0.0)THEN
        WRITE(ICOUT,201)
  201   FORMAT('***** ERROR--THE BETA SHAPE PARAMETER IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,203)BETA
  203   FORMAT('      THE VALUE OF BETA IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,303)ALPHA
  303   FORMAT('      THE VALUE OF ALPHA IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N KUMARASWAMY DISTRIBUTION
C     RANDOM NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION
C     METHOD.
C
      DO300I=1,N
        ZTEMP=X(I)
        CALL KUMPPF(DBLE(ZTEMP),DBLE(ALPHA),DBLE(BETA),DTEMP)
        X(I)=REAL(DTEMP)
  300 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LAGUE(X,AN,ALN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LAGUERRE POLYNOMIAL OF
C              ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--ALN    = THE SINGLE PRECISION VALUE OF THE
C                                LAGUERRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    L(N+1) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DLN, DLN1, DLN2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        ALN=1.0
      ELSEIF(N.EQ.1)THEN
        ALN=-X+1.0
      ELSEIF(N.EQ.2)THEN
        ALN=0.5*(X**2 - 4.0*X + 2.0)
      ELSEIF(N.EQ.3)THEN
        DLN=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0
        ALN=REAL(DLN)
      ELSE
        DLN1=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0
        DLN2=0.5D0*(DX**2 - 4.0D0*DX + 2.0D0)
        DO1000I=4,N
          DN2=DBLE(I)-1.0D0
          DLN=(((2.0D0*DN2+1.0D0)-DX)*DLN1-DN2*DLN2)/(DN2+1.0D0)
          DLN2=DLN1
          DLN1=DLN
 1000   CONTINUE
        ALN=REAL(DLN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LAGUEL(X,AN,ALPHA,IFLAG,ALN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED LAGUERRE
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C                       ALPHA  = THE SINGLE PRECISION VALUE FOR THE
C                                PARAMETER OF THE FUNCTION (SHOULD BE
C                       IFLAG  = "NORM" FOR NORMALIZED, "UNNO" FOR
C                                UNNORMALIZED
C     OUTPUT ARGUMENTS--ALN    = THE SINGLE PRECISION VALUE OF THE
C                                LAGUERRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    L(N+1) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IFLAG
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DLN, DLN1, DLN2
      DOUBLE PRECISION AJ, BJ, CJ
      DOUBLE PRECISION DFACT
      DOUBLE PRECISION DGAMR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LAGUERRE SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DN=DBLE(N)
C
      IF(IFLAG.EQ.'NORM')GOTO2000
      IF(N.LE.0)THEN
        DLN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DLN=-DX+DALPHA+1.0D0
      ELSEIF(N.EQ.2)THEN
        DLN=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
      ELSE
        DLN1=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
        DLN2=-DX+DALPHA+1.0D0
        DO1000I=3,N
          DN2=DBLE(I)-1.0D0
          DLN=(((2.0D0*DN2+DALPHA+1.0D0)-DX)*DLN1-(DN2+DALPHA)*DLN2)/
     1        (DN2+1.0D0)
CCCCC     DN2=DBLE(I)
CCCCC     AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2
CCCCC     BJ=-1.D0/DN2
CCCCC     CJ=(DN2-1.0D0+DALPHA)/DN2
CCCCC     DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2
          DLN2=DLN1
          DLN1=DLN
 1000   CONTINUE
      ENDIF
      ALN=REAL(DLN)
      GOTO9999
C
 2000 CONTINUE
      IF(N.LE.0)THEN
        DLN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DLN=-DX+DALPHA+1.0D0
        DFACT=(-1.0D0)**1/DGAMR(2.0D0)
        DLN=DLN/DFACT
      ELSEIF(N.EQ.2)THEN
        DLN=2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX
        DFACT=(-1.0D0)**2/DGAMR(3.0D0)
        DLN=DLN/DFACT
      ELSE
        DLN1=0.5D0*
     1   (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX)
        DLN2=-DX+DALPHA+1.0D0
        DO2100I=3,N
          DN2=DBLE(I)
          AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2
          BJ=-1.D0/DN2
          CJ=(DN2-1.0D0+DALPHA)/DN2
          DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2
          DLN2=DLN1
          DLN1=DLN
 2100   CONTINUE
      ENDIF
        DFACT=(-1.0D0)**N/DGAMR(DN+1.0D0)
        DLN=DLN/DFACT
      ALN=REAL(DLN)
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LAMCDF(X,ALAMBA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X.
C                 --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA)
C                   AND (+1/ALAMBA), INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 42-44, 53-58.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALAMBA.LE.0.0)GOTO90
      XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.XMIN)CDF=0.0
      IF(X.GT.XMAX)CDF=1.0
      RETURN
   90 CONTINUE
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT')
    3 FORMAT('      TO THE LAMCDF SUBROUTINE IS OUTSIDE THE USUAL')
    4 FORMAT('      +-(1/ALAMBA) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(ALAMBA.GT.0.0)GOTO110
      GOTO120
C
  110 XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LE.XMIN)CDF=0.0
      IF(X.GE.XMAX)CDF=1.0
      IF(X.LE.XMIN.OR.X.GE.XMAX)RETURN
C
  120 CONTINUE
      IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      GOTO170
  150 IF(X.GE.0.0)GOTO160
      CDF=EXP(X)/(1.0+EXP(X))
      RETURN
  160 CDF=1.0/(1.0+EXP(-X))
      RETURN
C
  170 IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      PMIN=0.0
      PMID=0.5
      PMAX=1.0
      PLOWER=PMIN
      PUPPER=PMAX
      ICOUNT=0
  210 XCALC=(PMID**ALAMBA-(1.0-PMID)**ALAMBA)/ALAMBA
      IF(XCALC.EQ.X)GOTO240
      IF(XCALC.GT.X)GOTO220
      PLOWER=PMID
      PMID=(PMID+PUPPER)/2.0
      GOTO230
  220 PUPPER=PMID
      PMID=(PMID+PLOWER)/2.0
  230 PDEL=ABS(PMID-PLOWER)
      ICOUNT=ICOUNT+1
      IF(PDEL.LT.0.000001.OR.ICOUNT.GT.30)GOTO240
      GOTO210
  240 CDF=PMID
      RETURN
C
      END
      SUBROUTINE LAMN(N,X,NM,BL1,DL1,IERROR)
C
C       =========================================================
C       Purpose: Compute lambda functions and their derivatives
C       Input:   x --- Argument of lambda function
C                n --- Order of lambda function
C       Output:  BL(n) --- Lambda function of order n
C                DL(n) --- Derivative of lambda function
C                NM --- Highest order computed
C       Routines called:
C                MSTA1 and MSTA2 for computing the start
C                point for backward recurrence
C       =========================================================
C
        PARAMETER(MAXORD=500)
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION BL(0:MAXORD),DL(0:MAXORD)
        CHARACTER*4 IERROR
C
        F=0.0D0
C
        IF(N.GT.MAXORD)THEN
          IERROR='YES'
          RETURN
        ENDIF
C
        NM=N
        IF (DABS(X).LT.1.0D-100) THEN
           DO 10 K=0,N
              BL(K)=0.0D0
              DL(K)=0.0D0
10         CONTINUE
           BL(0)=1.0D0
           DL(1)=0.5D0
           GOTO9999
        ENDIF
        IF (X.LE.12.0D0) THEN
           X2=X*X
           DO 25 K=0,N
              BK=1.0D0
              R=1.0D0
              DO 15 I=1,50
                 R=-0.25D0*R*X2/(I*(I+K))
                 BK=BK+R
                 IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 20
15            CONTINUE
20            BL(K)=BK
              IF (K.GE.1) DL(K-1)=-0.5D0*X/K*BK
25         CONTINUE
           UK=1.0D0
           R=1.0D0
           DO 30 I=1,50
              R=-0.25D0*R*X2/(I*(I+N+1.0D0))
              UK=UK+R
              IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 35
30         CONTINUE
35         DL(N)=-0.5D0*X/(N+1.0D0)*UK
           GOTO9999
        ENDIF
        IF (N.EQ.0) NM=1
        M=MSTA1(X,200)
        IF (M.LT.NM) THEN
           NM=M
        ELSE
           M=MSTA2(X,NM,15)
        ENDIF
        BS=0.0D0
        F0=0.0D0
        F1=1.0D-100
        DO 40 K=M,0,-1
           F=2.0D0*(K+1.0D0)*F1/X-F0
           IF (K.LE.NM) BL(K)=F
           IF (K.EQ.2*INT(K/2)) BS=BS+2.0D0*F
           F0=F1
           F1=F
40      CONTINUE
        BG=BS-F
        DO 45 K=0,NM
           BL(K)=BL(K)/BG
45      CONTINUE
        R0=1.0D0
        DO 50 K=1,NM
           R0=2.0D0*R0*K/X
           BL(K)=R0*BL(K)
50      CONTINUE
        DL(0)=-0.5D0*X*BL(1)
        DO 55 K=1,NM
           DL(K)=2.0D0*K/X*(BL(K-1)-BL(K))
55      CONTINUE
C
 9999   CONTINUE
        BL1=BL(NM)
        DL1=DL(NM)
        RETURN
        END
      SUBROUTINE LAMPDF(X,ALAMBA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X.
C                 --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA)
C                   AND (+1/ALAMBA), INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--LAMCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 42-44, 53-58.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALAMBA.LE.0.0)GOTO90
      XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)X
      CALL DPWRST('XXX','BUG ')
      IF(X.LT.XMIN)PDF=0.0
      IF(X.GT.XMAX)PDF=1.0
      RETURN
   90 CONTINUE
    2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT')
    3 FORMAT('      TO THE LAMPDF SUBROUTINE IS OUTSIDE THE USUAL')
    4 FORMAT('      +-(1/ALAMBA) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      IF(ALAMBA.GT.0.0)GOTO110
      GOTO150
  110 XMAX=1.0/ALAMBA
      XMIN=-XMAX
      IF(X.GT.XMIN.AND.X.LT.XMAX)GOTO150
      IF(X.LT.XMIN.OR.X.GT.XMAX)PDF=0.0
      IF(X.EQ.XMIN.AND.ALAMBA.LT.1.0)PDF=0.0
      IF(X.EQ.XMAX.AND.ALAMBA.LT.1.0)PDF=0.0
      IF(X.EQ.XMIN.AND.ALAMBA.EQ.1.0)PDF=0.5
      IF(X.EQ.XMAX.AND.ALAMBA.EQ.1.0)PDF=0.5
      IF(X.EQ.XMIN.AND.ALAMBA.GT.1.0)PDF=1.0
      IF(X.EQ.XMAX.AND.ALAMBA.GT.1.0)PDF=1.0
      RETURN
C
  150 CALL LAMCDF(X,ALAMBA,CDF)
      SF =CDF**(ALAMBA-1.0)+(1.0-CDF)**(ALAMBA-1.0)
      PDF=1.0/SF
      RETURN
C
      END
      SUBROUTINE LAMPPF(P,ALAMBA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--IF ALAMBA IS POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C                   IF ALAMBA IS NON-POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231,
C                 PAGES 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50
      IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.GT.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LAMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150
      GOTO250
  150 PPF=LOG(P/(1.0-P))
      RETURN
C
  250 PPF= (P**ALAMBA-(1.0-P)**ALAMBA)/ALAMBA
      RETURN
C
      END
      SUBROUTINE LAMRAN(N,ALAMBA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE (TUKEY) LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      ALAMB2=ALAMBA
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LAMRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LAMBDA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      Q=X(I)
      IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)X(I)=LOG(Q/(1.0-Q))
      IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)GOTO100
      X(I)=(Q**ALAMB2-(1.0-Q)**ALAMB2)/ALAMB2
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE LAMSF(P,ALAMBA,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALAMBA.
C              IN GENERAL, THE PROBABILITY DENSITY FUNCTION
C              FOR THIS DISTRIBUTION IS NOT SIMPLE.
C              THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS
C              G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA
C              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECIPROCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA
C                                (THE TAIL LENGTH PARAMETER).
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF FOR THE TUKEY LAMBDA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER = ALAMBA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--IF ALAMBA IS POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY.
C                   IF ALAMBA IS NON-POSITIVE,
C                   THEN P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231,
C                 PAGES 53-58.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR,
C                 'LOW MOMENTS FOR SMALL SAMPLES:  A COMPARATIVE
C                 STUDY OF ORDER STATISTICS', ANNALS OF
C                 MATHEMATICAL STATISTICS, 18, 1947,
C                 PAGES 413-426.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50
      IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50
      IF(ALAMBA.GT.0.0.AND.P.GT.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LAMSF')
    2 FORMAT(
     1'      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      SF=P**(ALAMBA-1.0)+(1.0-P)**(ALAMBA-1.0)
C
      RETURN
      END
      SUBROUTINE LAMV(V,X,VM,VL1,DL1,IERROR)
C
C       =========================================================
C       Purpose: Compute lambda function with arbitrary order v,
C                and their derivative
C       Input :  x --- Argument of lambda function
C                v --- Order of lambda function
C       Output:  VL(n) --- Lambda function of order n+v0
C                DL(n) --- Derivative of lambda function
C                VM --- Highest order computed
C       Routines called:
C            (1) MSTA1 and MSTA2 for computing the starting
C                point for backward recurrence
C            (2) GAM0 for computing gamma function (|x|   1)
C                (USE SLATEC VERSION: DGAMMA)
C       =========================================================
C
      PARAMETER(MAXORD=500)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION VL(0:MAXORD),DL(0:MAXORD)
      CHARACTER*4 IERROR
C
      VL(0:MAXORD)=0.0D0
      DL(0:MAXORD)=0.0D0
      CS=0.0D0
      F=0.0D0
      BJV0=0.0D0
C
        IF(V.GT.REAL(MAXORD))THEN
          IERROR='YES'
          RETURN
        ENDIF
C
      PI=3.141592653589793D0
      RP2=0.63661977236758D0
      X=DABS(X)
      X2=X*X
      N=INT(V)
      V0=V-N
      VM=V
      IF (X.LE.12.0D0) THEN
         DO 25 K=0,N
            VK=V0+K
            BK=1.0D0
            R=1.0D0
            DO 10 I=1,50
              R=-0.25D0*R*X2/(I*(I+VK))
              BK=BK+R
              IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 15
10          CONTINUE
15          CONTINUE
            VL(K)=BK
            UK=1.0D0
            R=1.0D0
            DO 20 I=1,50
              R=-0.25D0*R*X2/(I*(I+VK+1.0D0))
              UK=UK+R
              IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 25
20          CONTINUE
            DL(K)=-0.5D0*X/(VK+1.0D0)*UK
25       CONTINUE
         GOTO9999
      ENDIF
      K0=11
      IF (X.GE.35.0D0) K0=10
      IF (X.GE.50.0D0) K0=8
      DO 40 J=0,1
         VV=4.0D0*(J+V0)*(J+V0)
         PX=1.0D0
         RP=1.0D0
         DO 30 K=1,K0
            RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV-
     &            (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2)
              PX=PX+RP
30       CONTINUE
         QX=1.0D0
         RQ=1.0D0
         DO 35 K=1,K0
            RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV-
     &            (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2)
              QX=QX+RQ
35       CONTINUE
         QX=0.125D0*(VV-1.0D0)*QX/X
         XK=X-(0.5D0*(J+V0)+0.25D0)*PI
         A0=DSQRT(RP2/X)
         CK=DCOS(XK)
         SK=DSIN(XK)
         IF (J.EQ.0) BJV0=A0*(PX*CK-QX*SK)
         IF (J.EQ.1) BJV1=A0*(PX*CK-QX*SK)
40    CONTINUE
      IF (V0.EQ.0.0D0) THEN
        GA=1.0D0
      ELSE
CCCCC USE SLATEC GAMMA FUNCTION
CCCCC   CALL GAM0(V0,GA)
        GA=DGAMMA(V0)
        GA=V0*GA
      ENDIF
      FAC=(2.0D0/X)**V0*GA
      VL(0)=BJV0
      DL(0)=-BJV1+V0/X*BJV0
      VL(1)=BJV1
      DL(1)=BJV0-(1.0D0+V0)/X*BJV1
      R0=2.0D0*(1.0D0+V0)/X
      IF (N.LE.1) THEN
         VL(0)=FAC*VL(0)
         DL(0)=FAC*DL(0)-V0/X*VL(0)
         VL(1)=FAC*R0*VL(1)
         DL(1)=FAC*R0*DL(1)-(1.0D0+V0)/X*VL(1)
         GOTO9999
      ENDIF
      IF (N.GE.2.AND.N.LE.INT(0.9*X)) THEN
         F0=BJV0
         F1=BJV1
         DO 45 K=2,N
            F=2.0D0*(K+V0-1.0D0)/X*F1-F0
            F0=F1
            F1=F
            VL(K)=F
45       CONTINUE
      ELSE IF (N.GE.2) THEN
         M=MSTA1(X,200)
         IF (M.LT.N) THEN
            N=M
         ELSE
            M=MSTA2(X,N,15)
         ENDIF
         F2=0.0D0
         F1=1.0D-100
         DO 50 K=M,0,-1
            F=2.0D0*(V0+K+1.0D0)/X*F1-F2
            IF (K.LE.N) VL(K)=F
            F2=F1
            F1=F
50       CONTINUE
         IF (DABS(BJV0).GT.DABS(BJV1)) CS=BJV0/F
         IF (DABS(BJV0).LE.DABS(BJV1)) CS=BJV1/F2
         DO 55 K=0,N
            VL(K)=CS*VL(K)
55       CONTINUE
      ENDIF
      VL(0)=FAC*VL(0)
      DO 65 J=1,N
         RC=FAC*R0
         VL(J)=RC*VL(J)
         DL(J-1)=-0.5D0*X/(J+V0)*VL(J)
         R0=2.0D0*(J+V0+1)/X*R0
65    CONTINUE
      DL(N)=2.0D0*(V0+N)*(VL(N-1)-VL(N))/X
      VM=N+V0
C
 9999 CONTINUE
      VL1=VL(N)
      DL1=DL(N)
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANCDF(X)
* From CERNLIB, remame DISLAN to LANCDF
*
* $Id: dislan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $
*
* $Log: dislan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:43  mclareni
* Mathlib gen
*
*

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION P1(0:4),P2(0:3),P3(0:3),P4(0:3),P5(0:3),P6(0:3)
      DIMENSION Q1(0:4),Q2(0:3),Q3(0:3),Q4(0:3),Q5(0:3),Q6(0:3)
      DIMENSION A1(1:3),A2(1:3)

      DATA (P1(I),I=0,4),(Q1(I),I=0,4)
     1/ 0.25140 91491D+0,-0.62505 80444D-1, 0.14583 81230D-1,
     2 -0.21088 17737D-2, 0.74112 47290D-3,
     3  1.0             ,-0.55711 75625D-2, 0.62253 10236D-1,
     4 -0.31373 78427D-2, 0.19314 96439D-2/

      DATA (P2(I),I=0,3),(Q2(I),I=0,3)
     1/ 0.28683 28584D+0, 0.35643 63231D+0, 0.15235 18695D+0,
     2  0.22513 04883D-1,
     3  1.0             , 0.61911 36137D+0, 0.17207 21448D+0,
     4  0.22785 94771D-1/

      DATA (P3(I),I=0,3),(Q3(I),I=0,3)
     1/ 0.28683 29066D+0, 0.30038 28436D+0, 0.99509 51941D-1,
     2  0.87338 27185D-2,
     3  1.0             , 0.42371 90502D+0, 0.10956 31512D+0,
     4  0.86938 51567D-2/

      DATA (P4(I),I=0,3),(Q4(I),I=0,3)
     1/ 0.10003 51630D+1, 0.45035 92498D+1, 0.10858 83880D+2,
     2  0.75360 52269D+1,
     3  1.0             , 0.55399 69678D+1, 0.19335 81111D+2,
     4  0.27213 21508D+2/

      DATA (P5(I),I=0,3),(Q5(I),I=0,3)
     1/ 0.10000 06517D+1, 0.49094 14111D+2, 0.85055 44753D+2,
     2  0.15321 53455D+3,
     3  1.0             , 0.50099 28881D+2, 0.13998 19104D+3,
     4  0.42000 02909D+3/

      DATA (P6(I),I=0,3),(Q6(I),I=0,3)
     1/ 0.10000 00983D+1, 0.13298 68456D+3, 0.91621 49244D+3,
     2 -0.96050 54274D+3,
     3  1.0             , 0.13398 87843D+3, 0.10559 90413D+4,
     4  0.55322 24619D+3/

      DATA (A1(I),I=1,3)
     1/-0.45833 33333D+0, 0.66753 47222D+0,-0.16417 41416D+1/

      DATA (A2(I),I=1,3)
     1/ 1.0             ,-0.42278 43351D+0,-0.20434 03138D+1/

      V=X
      IF(V .LT. -5.5) THEN
       U=EXP(V+1.0)
       LANCDF=0.3989422803*EXP(-1/U)*SQRT(U)*
     1        (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U)
      ELSEIF(V .LT. -1.0) THEN
       U=EXP(-V-1.0)
       LANCDF=(EXP(-U)/SQRT(U))*
     1        (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     2        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 1.0) THEN
       LANCDF=(P2(0)+(P2(1)+(P2(2)+P2(3)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+Q2(3)*V)*V)*V)
      ELSEIF(V .LT. 4.0) THEN
       LANCDF=(P3(0)+(P3(1)+(P3(2)+P3(3)*V)*V)*V)/
     1        (Q3(0)+(Q3(1)+(Q3(2)+Q3(3)*V)*V)*V)
      ELSEIF(V .LT. 12.0) THEN
       U=1.0/V
       LANCDF=(P4(0)+(P4(1)+(P4(2)+P4(3)*U)*U)*U)/
     1        (Q4(0)+(Q4(1)+(Q4(2)+Q4(3)*U)*U)*U)
      ELSEIF(V .LT. 50.0) THEN
       U=1.0/V
       LANCDF=(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/
     1        (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U)
      ELSEIF(V .LT. 300.0) THEN
       U=1.0/V
       LANCDF=(P6(0)+(P6(1)+(P6(2)+P6(3)*U)*U)*U)/
     1        (Q6(0)+(Q6(1)+(Q6(2)+Q6(3)*U)*U)*U)
      ELSE
       U=1.0/(V-V*LOG(V)/(V+1.0))
       LANCDF=1.0-(A2(1)+(A2(2)+A2(3)*U)*U)*U
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANDIF(X)
* From CERNLIB.  Rename DIFLAN to LANDIF
*
* $Id: diflan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $
*
* $Log: diflan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:43  mclareni
* Mathlib gen
*
*

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4),P7(0:5)
      DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4),Q7(0:5)
      DIMENSION A1(1:6),A2(1:3)

      DATA (P1(I),I=0,4),(Q1(I),I=0,4)
     1/-0.30620 16156E-1,-0.12514 24734E+0,-0.95514 20540E-1,
     2 -0.26943 56206E-1,-0.26175 52485E-2,
     3  1.0             , 0.11777 46655E+1, 0.61309 93990E+0,
     4  0.15727 03422E+0, 0.17262 95027E-1/

      DATA (P2(I),I=0,4),(Q2(I),I=0,4)
     1/-0.15491 26548E-1,-0.75512 22105E-1,-0.25986 23886E-1,
     2  0.54712 70049E-2, 0.21522 70275E-2,
     3  1.0             , 0.99974 60723E+0, 0.49882 64176E+0,
     4  0.12891 04987E+0, 0.16396 32530E-1/

      DATA (P3(I),I=0,4),(Q3(I),I=0,4)
     1/-0.15471 35743E-1,-0.73041 84799E-1,-0.15341 51353E-1,
     2  0.35687 80079E-2,-0.92961 96751E-4,
     3  1.0             , 0.83941 07748E+0, 0.41280 36830E+0,
     4  0.10502 22892E+0, 0.17008 94650E-1/

      DATA (P4(I),I=0,4),(Q4(I),I=0,4)
     1/-0.15462 73317E-1,-0.68561 27408E-1, 0.46112 67324E-2,
     2 -0.25499 45537E-3, 0.58761 90635E-5,
     3  1.0             , 0.54532 66037E+0, 0.28025 11577E+0,
     4  0.47491 21515E-1, 0.10962 78827E-1/

      DATA (P5(I),I=0,4),(Q5(I),I=0,4)
     1/ 0.86420 27131E-5,-0.74742 91951E-3, 0.29356 78494E-1,
     2 -0.27696 95199E+1,-0.77695 42153E+1,
     3  1.0             , 0.90003 29289E+0, 0.34619 66768E+2,
     4  0.46668 93094E+1, 0.19264 64264E+3/

      DATA (P6(I),I=0,4),(Q6(I),I=0,4)
     1/-0.20124 96309E+1,-0.27484 32206E+3,-0.57590 40086E+4,
     2 -0.16000 68673E+5, 0.53346 52087E+5,
     3  1.0             , 0.12295 70501E+3, 0.18746 82285E+4,
     4  0.56780 25130E+4, 0.52823 54475E5/

      DATA (P7(I),I=0,5),(Q7(I),I=0,5)
     1/-0.20015 84932E+1,-0.24074 20185E+4,-0.54566 69704E+6,
     2 -0.28170 17048E+8,-0.20643 92982E+9, 0.90496 05994E+9,
     3  1.0             , 0.11829 29609E+4, 0.25522 99337E+6,
     4  0.11392 05796E+8, 0.39347 02081E+8, 0.21080 69087E+9/

      DATA (A1(I),I=1,6)
     1/-0.45833 33333E+0, 0.86805 55556E-3,-0.28525 27006E-2,
     2  0.53868 92562E-2,-0.14312 07031E-1, 0.50629 96176E-1/

      DATA (A2(I),I=1,3)
     1/-0.75367 06011E+1,-0.96018 56962E+1, 0.17146 15239E+3/

      V=X
      IF(V .LT. -2.6D0) THEN
       U=EXP(V+1.0D0)
       LANDIF=0.3989422803D0*(EXP(-1.0D0/U)/U**1.5)*
     1  (1.0D0+(A1(1)+(A1(2)+(A1(3)+
     1  (A1(4)+(A1(5)+A1(6)*U)*U)*U)*U)*U)*U)
      ELSEIF(V .LT. -1.75D0) THEN
       LANDIF=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     1        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. -1.25D0) THEN
       LANDIF=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 0.5D0) THEN
       LANDIF=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/
     1        (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 5.0D0) THEN
       LANDIF=(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*V)*V)*V)*V)/
     1        (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 15.D0) THEN
       U=1.0D0/V
       LANDIF=(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/
     1        (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 50.0D0) THEN
       U=1.0D0/V
       LANDIF=U**3*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/
     1             (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 300.0D0) THEN
       U=1.0D0/V
       LANDIF=U**3*
     1       (P7(0)+(P7(1)+(P7(2)+(P7(3)+(P7(4)+P7(5)*U)*U)*U)*U)*U)/
     2       (Q7(0)+(Q7(1)+(Q7(2)+(Q7(3)+(Q7(4)+Q7(5)*U)*U)*U)*U)*U)
      ELSE
       U=V-V*LOG(V)/(V+1.0D0)
       U=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0))
       LANDIF=-U**3*(2.0D0+(A2(1)+(A2(2)+A2(3)*U)*U)*U)
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANPDF(X)
* From CERNLIB, Rename LANPDF to LANPDF
*
* $Id: denlan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $
*
* $Log: denlan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:43  mclareni
* Mathlib gen
*
*

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4)
      DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4)
      DIMENSION A1(1:3),A2(1:2)

      DATA (P1(I),I=0,4),(Q1(I),I=0,4)
     1/ 0.42598 94875D+0,-0.12497 62550D+0, 0.39842 43700D-1,
     2 -0.62982 87635D-2, 0.15111 62253D-2,
     3  1.0             ,-0.33882 60629D+0, 0.95943 93323D-1,
     4 -0.16080 42283D-1, 0.37789 42063D-2/

      DATA (P2(I),I=0,4),(Q2(I),I=0,4)
     1/ 0.17885 41609D+0, 0.11739 57403D+0, 0.14888 50518D-1,
     2 -0.13949 89411D-2, 0.12836 17211D-3,
     3  1.0             , 0.74287 95082D+0, 0.31539 32961D+0,
     4  0.66942 19548D-1, 0.87906 09714D-2/

      DATA (P3(I),I=0,4),(Q3(I),I=0,4)
     1/ 0.17885 44503D+0, 0.93591 61662D-1, 0.63253 87654D-2,
     2  0.66116 67319D-4,-0.20310 49101D-5,
     3  1.0             , 0.60978 09921D+0, 0.25606 16665D+0,
     4  0.47467 22384D-1, 0.69573 01675D-2/

      DATA (P4(I),I=0,4),(Q4(I),I=0,4)
     1/ 0.98740 54407D+0, 0.11867 23273D+3, 0.84927 94360D+3,
     2 -0.74377 92444D+3, 0.42702 62186D+3,
     3  1.0             , 0.10686 15961D+3, 0.33764 96214D+3,
     4  0.20167 12389D+4, 0.15970 63511D+4/

      DATA (P5(I),I=0,4),(Q5(I),I=0,4)
     1/ 0.10036 75074D+1, 0.16757 02434D+3, 0.47897 11289D+4,
     2  0.21217 86767D+5,-0.22324 94910D+5,
     3  1.0             , 0.15694 24537D+3, 0.37453 10488D+4,
     4  0.98346 98876D+4, 0.66924 28357D+5/

      DATA (P6(I),I=0,4),(Q6(I),I=0,4)
     1/ 0.10008 27619D+1, 0.66491 43136D+3, 0.62972 92665D+5,
     2  0.47555 46998D+6,-0.57436 09109D+7,
     3  1.0             , 0.65141 01098D+3, 0.56974 73333D+5,
     4  0.16591 74725D+6,-0.28157 59939D+7/

      DATA (A1(I),I=1,3)
     1/ 0.41666 66667D-1,-0.19965 27778D-1, 0.27095 38966D-1/

      DATA (A2(I),I=1,2)
     1/-0.18455 68670D+1,-0.42846 40743D+1/

      V=X
      IF(V .LT. -5.5) THEN
       U=EXP(V+1.0)
       LANPDF=0.3989422803*(EXP(-1.0/U)/SQRT(U))*
     1        (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U)
      ELSEIF(V .LT. -1.0) THEN
       U=EXP(-V-1.0)
       LANPDF=EXP(-U)*SQRT(U)*
     1        (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     2        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 1.0) THEN
       LANPDF=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 5.0) THEN
       LANPDF=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/
     1        (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 12.0) THEN
       U=1.0/V
       LANPDF=U**2*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/
     1             (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 50.0) THEN
       U=1.0/V
       LANPDF=U**2*(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/
     1             (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 300.0) THEN
       U=1.0/V
       LANPDF=U**2*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/
     1             (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U)
      ELSE
       U=1.0/(V-V*LOG(V)/(V+1.0))
       LANPDF=U**2*(1.0+(A2(1)+A2(2)*U)*U)
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANPPF(X)
* From CERNLIB, rename LANPPF to LANPPF
*
* $Id: ranlan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $
*
* $Log: ranlan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:43  mclareni
* Mathlib gen
*
*
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'DPCOP2.INC'
C
      DIMENSION F(6:982)

      DATA (F(I),I= 6,100)
     A/                                                  -2.244733,
     B -2.204365,-2.168163,-2.135219,-2.104898,-2.076740,-2.050397,
     C -2.025605,-2.002150,-1.979866,-1.958612,-1.938275,-1.918760,
     D -1.899984,-1.881879,-1.864385,-1.847451,-1.831030,-1.815083,
     E -1.799574,-1.784473,-1.769751,-1.755383,-1.741346,-1.727620,
     F -1.714187,-1.701029,-1.688130,-1.675477,-1.663057,-1.650858,
     G -1.638868,-1.627078,-1.615477,-1.604058,-1.592811,-1.581729,
     H -1.570806,-1.560034,-1.549407,-1.538919,-1.528565,-1.518339,
     I -1.508237,-1.498254,-1.488386,-1.478628,-1.468976,-1.459428,
     J -1.449979,-1.440626,-1.431365,-1.422195,-1.413111,-1.404112,
     K -1.395194,-1.386356,-1.377594,-1.368906,-1.360291,-1.351746,
     L -1.343269,-1.334859,-1.326512,-1.318229,-1.310006,-1.301843,
     M -1.293737,-1.285688,-1.277693,-1.269752,-1.261863,-1.254024,
     N -1.246235,-1.238494,-1.230800,-1.223153,-1.215550,-1.207990,
     O -1.200474,-1.192999,-1.185566,-1.178172,-1.170817,-1.163500,
     P -1.156220,-1.148977,-1.141770,-1.134598,-1.127459,-1.120354,
     Q -1.113282,-1.106242,-1.099233,-1.092255/

      DATA (F(I),I=101,200)
     A/-1.085306,-1.078388,-1.071498,-1.064636,-1.057802,-1.050996,
     B -1.044215,-1.037461,-1.030733,-1.024029,-1.017350,-1.010695,
     C -1.004064, -.997456, -.990871, -.984308, -.977767, -.971247,
     D  -.964749, -.958271, -.951813, -.945375, -.938957, -.932558,
     E  -.926178, -.919816, -.913472, -.907146, -.900838, -.894547,
     F  -.888272, -.882014, -.875773, -.869547, -.863337, -.857142,
     G  -.850963, -.844798, -.838648, -.832512, -.826390, -.820282,
     H  -.814187, -.808106, -.802038, -.795982, -.789940, -.783909,
     I  -.777891, -.771884, -.765889, -.759906, -.753934, -.747973,
     J  -.742023, -.736084, -.730155, -.724237, -.718328, -.712429,
     K  -.706541, -.700661, -.694791, -.688931, -.683079, -.677236,
     L  -.671402, -.665576, -.659759, -.653950, -.648149, -.642356,
     M  -.636570, -.630793, -.625022, -.619259, -.613503, -.607754,
     N  -.602012, -.596276, -.590548, -.584825, -.579109, -.573399,
     O  -.567695, -.561997, -.556305, -.550618, -.544937, -.539262,
     P  -.533592, -.527926, -.522266, -.516611, -.510961, -.505315,
     Q  -.499674, -.494037, -.488405, -.482777/

      DATA (F(I),I=201,300)
     A/ -.477153, -.471533, -.465917, -.460305, -.454697, -.449092,
     B  -.443491, -.437893, -.432299, -.426707, -.421119, -.415534,
     C  -.409951, -.404372, -.398795, -.393221, -.387649, -.382080,
     D  -.376513, -.370949, -.365387, -.359826, -.354268, -.348712,
     E  -.343157, -.337604, -.332053, -.326503, -.320955, -.315408,
     F  -.309863, -.304318, -.298775, -.293233, -.287692, -.282152,
     G  -.276613, -.271074, -.265536, -.259999, -.254462, -.248926,
     H  -.243389, -.237854, -.232318, -.226783, -.221247, -.215712,
     I  -.210176, -.204641, -.199105, -.193568, -.188032, -.182495,
     J  -.176957, -.171419, -.165880, -.160341, -.154800, -.149259,
     K  -.143717, -.138173, -.132629, -.127083, -.121537, -.115989,
     L  -.110439, -.104889, -.099336, -.093782, -.088227, -.082670,
     M  -.077111, -.071550, -.065987, -.060423, -.054856, -.049288,
     N  -.043717, -.038144, -.032569, -.026991, -.021411, -.015828,
     O  -.010243, -.004656,  .000934,  .006527,  .012123,  .017722,
     P   .023323,  .028928,  .034535,  .040146,  .045759,  .051376,
     Q   .056997,  .062620,  .068247,  .073877/

      DATA (F(I),I=301,400)
     A/  .079511,  .085149,  .090790,  .096435,  .102083,  .107736,
     B   .113392,  .119052,  .124716,  .130385,  .136057,  .141734,
     C   .147414,  .153100,  .158789,  .164483,  .170181,  .175884,
     D   .181592,  .187304,  .193021,  .198743,  .204469,  .210201,
     E   .215937,  .221678,  .227425,  .233177,  .238933,  .244696,
     F   .250463,  .256236,  .262014,  .267798,  .273587,  .279382,
     G   .285183,  .290989,  .296801,  .302619,  .308443,  .314273,
     H   .320109,  .325951,  .331799,  .337654,  .343515,  .349382,
     I   .355255,  .361135,  .367022,  .372915,  .378815,  .384721,
     J   .390634,  .396554,  .402481,  .408415,  .414356,  .420304,
     K   .426260,  .432222,  .438192,  .444169,  .450153,  .456145,
     L   .462144,  .468151,  .474166,  .480188,  .486218,  .492256,
     M   .498302,  .504356,  .510418,  .516488,  .522566,  .528653,
     N   .534747,  .540850,  .546962,  .553082,  .559210,  .565347,
     O   .571493,  .577648,  .583811,  .589983,  .596164,  .602355,
     P   .608554,  .614762,  .620980,  .627207,  .633444,  .639689,
     Q   .645945,  .652210,  .658484,  .664768/

      DATA (F(I),I=401,500)
     A/  .671062,  .677366,  .683680,  .690004,  .696338,  .702682,
     B   .709036,  .715400,  .721775,  .728160,  .734556,  .740963,
     C   .747379,  .753807,  .760246,  .766695,  .773155,  .779627,
     D   .786109,  .792603,  .799107,  .805624,  .812151,  .818690,
     E   .825241,  .831803,  .838377,  .844962,  .851560,  .858170,
     F   .864791,  .871425,  .878071,  .884729,  .891399,  .898082,
     G   .904778,  .911486,  .918206,  .924940,  .931686,  .938446,
     H   .945218,  .952003,  .958802,  .965614,  .972439,  .979278,
     I   .986130,  .992996,  .999875, 1.006769, 1.013676, 1.020597,
     J  1.027533, 1.034482, 1.041446, 1.048424, 1.055417, 1.062424,
     K  1.069446, 1.076482, 1.083534, 1.090600, 1.097681, 1.104778,
     L  1.111889, 1.119016, 1.126159, 1.133316, 1.140490, 1.147679,
     M  1.154884, 1.162105, 1.169342, 1.176595, 1.183864, 1.191149,
     N  1.198451, 1.205770, 1.213105, 1.220457, 1.227826, 1.235211,
     O  1.242614, 1.250034, 1.257471, 1.264926, 1.272398, 1.279888,
     P  1.287395, 1.294921, 1.302464, 1.310026, 1.317605, 1.325203,
     Q  1.332819, 1.340454, 1.348108, 1.355780/

      DATA (F(I),I=501,600)
     A/ 1.363472, 1.371182, 1.378912, 1.386660, 1.394429, 1.402216,
     B  1.410024, 1.417851, 1.425698, 1.433565, 1.441453, 1.449360,
     C  1.457288, 1.465237, 1.473206, 1.481196, 1.489208, 1.497240,
     D  1.505293, 1.513368, 1.521465, 1.529583, 1.537723, 1.545885,
     E  1.554068, 1.562275, 1.570503, 1.578754, 1.587028, 1.595325,
     F  1.603644, 1.611987, 1.620353, 1.628743, 1.637156, 1.645593,
     G  1.654053, 1.662538, 1.671047, 1.679581, 1.688139, 1.696721,
     H  1.705329, 1.713961, 1.722619, 1.731303, 1.740011, 1.748746,
     I  1.757506, 1.766293, 1.775106, 1.783945, 1.792810, 1.801703,
     J  1.810623, 1.819569, 1.828543, 1.837545, 1.846574, 1.855631,
     K  1.864717, 1.873830, 1.882972, 1.892143, 1.901343, 1.910572,
     L  1.919830, 1.929117, 1.938434, 1.947781, 1.957158, 1.966566,
     M  1.976004, 1.985473, 1.994972, 2.004503, 2.014065, 2.023659,
     N  2.033285, 2.042943, 2.052633, 2.062355, 2.072110, 2.081899,
     O  2.091720, 2.101575, 2.111464, 2.121386, 2.131343, 2.141334,
     P  2.151360, 2.161421, 2.171517, 2.181648, 2.191815, 2.202018,
     Q  2.212257, 2.222533, 2.232845, 2.243195/

      DATA (F(I),I=601,700)
     A/ 2.253582, 2.264006, 2.274468, 2.284968, 2.295507, 2.306084,
     B  2.316701, 2.327356, 2.338051, 2.348786, 2.359562, 2.370377,
     C  2.381234, 2.392131, 2.403070, 2.414051, 2.425073, 2.436138,
     D  2.447246, 2.458397, 2.469591, 2.480828, 2.492110, 2.503436,
     E  2.514807, 2.526222, 2.537684, 2.549190, 2.560743, 2.572343,
     F  2.583989, 2.595682, 2.607423, 2.619212, 2.631050, 2.642936,
     G  2.654871, 2.666855, 2.678890, 2.690975, 2.703110, 2.715297,
     H  2.727535, 2.739825, 2.752168, 2.764563, 2.777012, 2.789514,
     I  2.802070, 2.814681, 2.827347, 2.840069, 2.852846, 2.865680,
     J  2.878570, 2.891518, 2.904524, 2.917588, 2.930712, 2.943894,
     K  2.957136, 2.970439, 2.983802, 2.997227, 3.010714, 3.024263,
     L  3.037875, 3.051551, 3.065290, 3.079095, 3.092965, 3.106900,
     M  3.120902, 3.134971, 3.149107, 3.163312, 3.177585, 3.191928,
     N  3.206340, 3.220824, 3.235378, 3.250005, 3.264704, 3.279477,
     O  3.294323, 3.309244, 3.324240, 3.339312, 3.354461, 3.369687,
     P  3.384992, 3.400375, 3.415838, 3.431381, 3.447005, 3.462711,
     Q  3.478500, 3.494372, 3.510328, 3.526370/

      DATA (F(I),I=701,800)
     A/ 3.542497, 3.558711, 3.575012, 3.591402, 3.607881, 3.624450,
     B  3.641111, 3.657863, 3.674708, 3.691646, 3.708680, 3.725809,
     C  3.743034, 3.760357, 3.777779, 3.795300, 3.812921, 3.830645,
     D  3.848470, 3.866400, 3.884434, 3.902574, 3.920821, 3.939176,
     E  3.957640, 3.976215, 3.994901, 4.013699, 4.032612, 4.051639,
     F  4.070783, 4.090045, 4.109425, 4.128925, 4.148547, 4.168292,
     G  4.188160, 4.208154, 4.228275, 4.248524, 4.268903, 4.289413,
     H  4.310056, 4.330832, 4.351745, 4.372794, 4.393982, 4.415310,
     I  4.436781, 4.458395, 4.480154, 4.502060, 4.524114, 4.546319,
     J  4.568676, 4.591187, 4.613854, 4.636678, 4.659662, 4.682807,
     K  4.706116, 4.729590, 4.753231, 4.777041, 4.801024, 4.825179,
     L  4.849511, 4.874020, 4.898710, 4.923582, 4.948639, 4.973883,
     M  4.999316, 5.024942, 5.050761, 5.076778, 5.102993, 5.129411,
     N  5.156034, 5.182864, 5.209903, 5.237156, 5.264625, 5.292312,
     O  5.320220, 5.348354, 5.376714, 5.405306, 5.434131, 5.463193,
     P  5.492496, 5.522042, 5.551836, 5.581880, 5.612178, 5.642734,
     Q  5.673552, 5.704634, 5.735986, 5.767610/

      DATA (F(I),I=801,900)
     A/ 5.799512, 5.831694, 5.864161, 5.896918, 5.929968, 5.963316,
     B  5.996967, 6.030925, 6.065194, 6.099780, 6.134687, 6.169921,
     C  6.205486, 6.241387, 6.277630, 6.314220, 6.351163, 6.388465,
     D  6.426130, 6.464166, 6.502578, 6.541371, 6.580553, 6.620130,
     E  6.660109, 6.700495, 6.741297, 6.782520, 6.824173, 6.866262,
     F  6.908795, 6.951780, 6.995225, 7.039137, 7.083525, 7.128398,
     G  7.173764, 7.219632, 7.266011, 7.312910, 7.360339, 7.408308,
     H  7.456827, 7.505905, 7.555554, 7.605785, 7.656608, 7.708035,
     I  7.760077, 7.812747, 7.866057, 7.920019, 7.974647, 8.029953,
     J  8.085952, 8.142657, 8.200083, 8.258245, 8.317158, 8.376837,
     K  8.437300, 8.498562, 8.560641, 8.623554, 8.687319, 8.751955,
     L  8.817481, 8.883916, 8.951282, 9.019600, 9.088889, 9.159174,
     M  9.230477, 9.302822, 9.376233, 9.450735, 9.526355, 9.603118,
     N  9.681054, 9.760191, 9.840558, 9.922186,10.005107,10.089353,
     O 10.174959,10.261958,10.350389,10.440287,10.531693,10.624646,
     P 10.719188,10.815362,10.913214,11.012789,11.114137,11.217307,
     Q 11.322352,11.429325,11.538283,11.649285/

      DATA (F(I),I=901,982)
     A/11.762390,11.877664,11.995170,12.114979,12.237161,12.361791,
     B 12.488946,12.618708,12.751161,12.886394,13.024498,13.165570,
     C 13.309711,13.457026,13.607625,13.761625,13.919145,14.080314,
     D 14.245263,14.414134,14.587072,14.764233,14.945778,15.131877,
     E 15.322712,15.518470,15.719353,15.925570,16.137345,16.354912,
     F 16.578520,16.808433,17.044929,17.288305,17.538873,17.796967,
     G 18.062943,18.337176,18.620068,18.912049,19.213574,19.525133,
     H 19.847249,20.180480,20.525429,20.882738,21.253102,21.637266,
     I 22.036036,22.450278,22.880933,23.329017,23.795634,24.281981,
     J 24.789364,25.319207,25.873062,26.452634,27.059789,27.696581,
     K 28.365274,29.068370,29.808638,30.589157,31.413354,32.285060,
     L 33.208568,34.188705,35.230920,36.341388,37.527131,38.796172,
     M 40.157721,41.622399,43.202525,44.912465,46.769077,48.792279,
     N 51.005773,53.437996,56.123356,59.103894/
C
      LANPPF=0.0
C
      IF(X.LT.0.000001D0 .OR. X.GT.0.999999D0)THEN
        WRITE(ICOUT, 5)
 5      FORMAT('**** ERROR IN LANPPF: ARGUMENT NOT IN THE ',
     1         '(0.000001,0.999999) INTERVAL')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      U=1000.0D0*X
      I=INT(U)
      U=U-I
      IF(I .GE. 70 .AND. I .LE. 800) THEN
        LANPPF=F(I)+U*(F(I+1)-F(I))
      ELSEIF(I .GE.  7 .AND. I .LE. 980) THEN
        LANPPF=
     1  F(I)+U*(F(I+1)-F(I)-0.25D0*
     1  (1.0D0-U)*(F(I+2)-F(I+1)-F(I)+F(I-1)))
      ELSEIF(I. LT. 7) THEN
        V=LOG(X)
        U=1.0D0/V
        LANPPF=((0.99858950D0+(3.45213058D1+1.70854528D1*U)*U)/
     1         (1.0D0     +(3.41760202D1+4.01244582D0  *U)*U))*
     2         (-LOG(-0.91893853D0-V)-1.0D0)
      ELSE
C
C  NOTE: I HAD A BIT OF A PROBLEM WITH LAST CASE.  RECODE
C  SLIGHTLY.
C
        X=X*10**6 + 0.1
        I=INT(X)
        I=1000000-I
        U=I
        U=U/(1.0D0*10**6)
CCCCC   U=1.0D0-X
        V=U**2
        IF(X .LE. 0.999D0) THEN
          LANPPF=(1.00060006D0+2.63991156D2*U+4.37320068D3*V)/
     1    ((1.0D0     +2.57368075D2*U+3.41448018D3*V)*U)
        ELSE
CCCCC      print *,'u,v=',u,v
           D1 = 1.00001538D0
           D2 = 6.075141193D0*10**3
           D3 = 7.34266409D0*10**5
           D4 = 6.06511919D0*10**3
           D5 = 6.94021044D0*10**5
           DNUM = D1 + D2*U + D3*V
           DDEN = (1.0D0 + D4*U + D5*V)*U
           LANPPF = DNUM/DDEN
CCCCC     LANPPF=(1.00001538D0+6.07514119D3*U+7.34266409D5*V)/
CCCCC1           ((1.0D0     +6.06511919D3*U+6.94021044D5*V)*U)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LANRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LANDAU DISTRIBUTION
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LANDAU DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2003.4
C     ORIGINAL VERSION--APRIL     2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      EXTERNAL LANPPF
      DOUBLE PRECISION LANPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LANRAN IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LANDAU DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
  105   CONTINUE
        IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)THEN
          CALL UNIRAN(1,ISEED,X(I))
          IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)GOTO105
        ENDIF
        XTEMP=REAL(LANPPF(DBLE(X(I))))
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANXM1(X)
* From CERNLIB, rename XM1LAN to LANXM1
*
* $Id: xm1lan.F,v 1.1.1.1 1996/04/01 15:02:44 mclareni Exp $
*
* $Log: xm1lan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:44  mclareni
* Mathlib gen
*
*

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:3),P5(0:3)
      DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:3),Q5(0:3)
      DIMENSION A0(0:5),A1(1:3),A2(1:4)

      DATA (P1(I),I=0,4),(Q1(I),I=0,4)
     1/-0.89493 74280E+0, 0.46317 83434E+0,-0.40533 32915E-1,
     2  0.15800 75560E-1,-0.34238 74194E-2,
     3  1.0             , 0.10029 30749E+0, 0.35752 71633E-1,
     4 -0.19158 82099E-2, 0.48110 72364E-4/

      DATA (P2(I),I=0,4),(Q2(I),I=0,4)
     1/-0.89333 84046E+0, 0.11612 96496E+0, 0.12000 82940E+0,
     2  0.21856 99725E-1, 0.21288 92058E-2,
     3  1.0             , 0.49355 31886E+0, 0.10663 47067E+0,
     4  0.12501 61833E-1, 0.54942 43254E-3/

      DATA (P3(I),I=0,4),(Q3(I),I=0,4)
     1/-0.89333 22067E+0, 0.23395 44896E+0, 0.82576 53222E-1,
     2  0.14112 26998E-1, 0.28922 40953E-3,
     3  1.0             , 0.36165 38408E+0, 0.66280 26743E-1,
     4  0.48392 98984E-2, 0.52483 10361E-4/

      DATA (P4(I),I=0,3),(Q4(I),I=0,3)
     1/ 0.93584 19425E+0, 0.67168 31438E+2,-0.67650 69077E+3,
     2  0.90266 61865E+3,
     3  1.0             , 0.77525 62854E+2,-0.56378 11998E+3,
     4 -0.55131 56752E+3/

      DATA (P5(I),I=0,3),(Q5(I),I=0,3)
     1/ 0.94893 35583E+0, 0.55612 46706E+3, 0.32082 74617E+5,
     2 -0.48899 26524E+5,
     3  1.0             , 0.60282 75940E+3, 0.37169 62017E+5,
     4  0.36862 72898E+5/

      DATA (A0(I),I=0,5)
     1/-0.42278 43351E+0,-0.15443 13298E+0, 0.42278 43351E+0,
     2  0.32764 96874E+1, 0.20434 03138E+1,-0.86812 96500E+1/

      DATA (A1(I),I=1,3)
     1/-0.45833 33333E+0, 0.66753 47222E+0,-0.16417 41416E+1/

      DATA (A2(I),I=1,4)
     1/-0.19583 33333E+1, 0.55633 68056E+1,-0.21113 52961E+2,
     2  0.10069 46266E+3/

      V=X
      IF(V .LT. -4.5D0) THEN
       U=EXP(V+1.0)
       LANXM1=V-U*(1.0D0+(A2(1)+(A2(2)+(A2(3)+A2(4)*U)*U)*U)*U)/
     1            (1.0D0+(A1(1)+(A1(2)+A1(3)*U)*U)*U)
      ELSEIF(V .LT. -2.0D0) THEN
       LANXM1=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     1        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 2.0D0) THEN
       LANXM1=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 10.0D0) THEN
       LANXM1=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/
     1        (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 40.0D0) THEN
       U=1.0D0/V
       LANXM1=LOG(V)*(P4(0)+(P4(1)+(P4(2)+P4(3)*U)*U)*U)/
     1                (Q4(0)+(Q4(1)+(Q4(2)+Q4(3)*U)*U)*U)
      ELSEIF(V .LT. 200.0D0) THEN
       U=1.0D0/V
       LANXM1=LOG(V)*(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/
     1                (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U)
      ELSE
       U=V-V*LOG(V)/(V+1.0D0)
       V=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0))
       U=-LOG(V)
       LANXM1=
     1    (U+A0(0)+(-U+A0(1)+(A0(2)*U+A0(3)+(A0(4)*U+A0(5))*V)*V)*V)
     1    /(1.0D0-(1.0D0-(A0(2)+A0(4)*V)*V)*V)
      ENDIF
      RETURN
      END
      DOUBLE PRECISION FUNCTION LANXM2(X)
* From Cernlib, renam XM2LAN to LANXM2
* $Id: xm2lan.F,v 1.1.1.1 1996/04/01 15:02:45 mclareni Exp $
*
* $Log: xm2lan.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:45  mclareni
* Mathlib gen
*
*

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION P1(0:4),P2(0:4),P3(0:3),P4(0:4),P5(0:3)
      DIMENSION Q1(0:4),Q2(0:4),Q3(0:3),Q4(0:4),Q5(0:3)
      DIMENSION A0(0:6),A1(1:3),A2(0:3),A3(0:3)

      DATA (P1(I),I=0,4),(Q1(I),I=0,4)
     1/ 0.11698 37582E+1,-0.48348 74539E+0, 0.43837 74644E+0,
     2  0.32871 75228E-2, 0.18791 29206E-1,
     3  1.0             , 0.17951 54326E+0, 0.46127 95899E-1,
     4  0.21834 59337E-2, 0.72266 23623E-4/

      DATA (P2(I),I=0,4),(Q2(I),I=0,4)
     1/ 0.11579 39823E+1,-0.38428 09495E+0, 0.33175 32899E+0,
     2  0.35476 06781E-1, 0.67256 45279E-2,
     3  1.0             , 0.29168 24021E+0, 0.52598 53480E-1,
     4  0.38400 11061E-2, 0.99503 24173E-4/

      DATA (P3(I),I=0,3),(Q3(I),I=0,3)
     1/ 0.11781 91282E+1, 0.10116 23342E+2,-0.12855 85291E+2,
     2  0.36413 61437E+2,
     3  1.0             , 0.86141 60194E+1, 0.31189 29630E+2,
     4  0.15143 51300E+0/

      DATA (P4(I),I=0,4),(Q4(I),I=0,4)
     1/ 0.10307 63698E+1, 0.12167 58660E+3, 0.16374 31386E+4,
     2 -0.21714 66507E+4, 0.70101 68358E+4,
     3  1.0             , 0.10224 87911E+3, 0.13776 46350E+4,
     4  0.36991 84961E+4, 0.42513 15610E+4/

      DATA (P5(I),I=0,3),(Q5(I),I=0,3)
     1/ 0.10100 84827E+1, 0.39442 24824E+3, 0.17730 25353E+5,
     2 -0.70759 63938E+5,
     3  1.0             , 0.36059 50254E+3, 0.13927 84158E+5,
     4 -0.18816 80027E+5/

      DATA (A0(I),I=0,6)
     1/-0.20434 03138E+1,-0.84556 86702E+0,-0.30886 26596E+0,
     2  0.58213 46754E+1, 0.42278 43351E+0, 0.65529 93748E+1,
     3 -0.10767 14945E+2/

      DATA (A1(I),I=1,3)
     1/-0.45833 33333E+0, 0.66753 47222E+0,-0.16417 41416E+1/

      DATA (A2(I),I=0,3)
     1/-0.19583 33333E+1, 0.55633 68056E+1,-0.21113 52961E+2,
     2  0.10069 46266E+3/

      DATA (A3(I),I=0,3)
     1/-1.0             , 0.44583 33333E+1,-0.21167 53472E+2,
     2  0.11636 74359E+3/

      V=X
      IF(V .LT. -4.5D0) THEN
       U=EXP(V+1.0D0)
       LANXM2=V**2-2.0D0*U**2*
     1        (V/U+A2(0)*V+A3(0)+(A2(1)*V+A3(1)+(A2(2)*V+A3(2)+
     2        (A2(3)*V+A3(3))*U)*U)*U)/
     3        (1.0D0+(A1(1)+(A1(2)+A1(3)*U)*U)*U)
      ELSEIF(V .LT. -2.0D0) THEN
       LANXM2=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/
     1        (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 2.0D0) THEN
       LANXM2=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/
     1        (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V)
      ELSEIF(V .LT. 5.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P3(0)+(P3(1)+(P3(2)+P3(3)*U)*U)*U)/
     1          (Q3(0)+(Q3(1)+(Q3(2)+Q3(3)*U)*U)*U)
      ELSEIF(V .LT. 50.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/
     1          (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U)
      ELSEIF(V .LT. 200.0D0) THEN
       U=1.0D0/V
       LANXM2=V*(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/
     1          (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U)
      ELSE
       U=V-V*LOG(V)/(V+1.0D0)
       V=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0))
       U=-LOG(V)
       LANXM2=(1.0D0/V+U**2+A0(0)+A0(1)*U+(-U**2+A0(2)*U+A0(3)+
     1   (A0(4)*U**2+A0(5)*U+A0(6))*V)*V)/(1.0D0-(1.0D0-A0(4)*V)*V)
      ENDIF
      RETURN
      END
      Function lcmrnd(ix)
C
C  THIS FUNCTION USED BY THE "R250" RANDOM NUMBER GENERATOR
C
C     The minimal standard PRNG for 31 bit unsigned integers
C     designed with automatic overflow protection
C     uses ix as the seed value if it is greater than zero
C     otherwise it is ignored
      Integer*4 ix
      Integer*4 a, b, m, q, r
      Integer*4 hi, lo, test
      Integer*4 x
      SAVE x
      Parameter (a = 16807, b = 0, m = 2147483647)
      Parameter (q = 127773, r = 2836)
C
      If ( ix .gt. 0 ) x = ix
C
      hi = x / q
      lo = mod( x, q )
      test = a * lo - r * hi
      if ( test .gt. 0 ) then
          x = test
      else
          x = test + m
      endif
C
      lcmrnd = x
C
      return
      End
      SUBROUTINE LATCON(IA,IWIDTH,IB,IWIDT2,MAXWID,ISUBRO,IERROR)
C
C     PURPOSE--CONVERT DATAPLOT SPECIAL CHARACTERS (E.G., GREEK
C              CHARACTERS, SUBSCRIPTS, SUPERSCRIPTS, MATH SYMBOLS)
C              FROM DATAPLOT CODING TO COMPARABLE LATEX CODING.
C
C     INPUT  ARGUMENTS--IA     = INITIAL CHARACTER STRING
C                       IWIDTH = NUMBER OF CHARACTERS IN IA
C                       ISUBRO = BUG TRACE VARIABLE
C     OUTPUT ARGUMENTS--IB     = OUTPUT CHARACTER STRING
C                       IWIDT2 = NUMBER OF CHARACTERS IN IB
C                       IERROR = HOLLERITH VARIABLE
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/2
C     ORIGINAL VERSION--FEBRUARY  2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*(*) IA
      CHARACTER*(*) IB
C
      CHARACTER*4 ICASFL
      CHARACTER*4 IBASLC
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(ISUBRO.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LATCON--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IWIDTH,MAXWID,ISUBRO,IERROR
   52   FORMAT('IWIDTH,MAXWID,ISUBRO,IERROR = ',I8,2X,I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)(IA(I:I),I=1,MIN(100,IWIDTH))
   53   FORMAT('(IA(I),I=1,IWIDTH) = ',100A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IBASLC=CHAR(92)
C
C               *****************************************************
C               **  THE FOLLOWING CODE WILL SEARCH FOR DATAPLOT'S  **
C               **  SPECIAL CHARACTER CODES AND CONVERT THEM TO    **
C               **  EQUIVALENT LATEX CODES.                        **
C               *****************************************************
C
C
C     UC()   = UPPER CASE
C     LC()   = LOWER CASE
C     MU()   = GREEK MU
C     NU()   = GREEK NU
C     XI()   = GREEK XI
C     PI()   = GREEK PI
C     LT()   = LESS THAN
C     GT()   = GREATER THAN
C     +-()   = + OR -
C     -+()   = - OR +
C     SP()   = SPACE
C     SUB()  = ENTER SUBSCRIPT MODE
C     SUP()  = ENTER SUPERSCRIPT MODE
C     ETA()  = GREEK ETA
C     RHO()  = GREEK RHO
C     TAU()  = GREEK TAU
C     PHI()  = GREEK PHI
C     CHI()  = GREEK CHI
C     PSI()  = GREEK PSI
C     DEL()  = VECTOR PRODUCT
C     UNSB() = LEAVE SUBSCRIPT MODE
C     UNSP() = LEAVE SUPERSCRIPT MODE
C     ALPH() = GREEK ALPHA
C     BETA() = GREEK BETA
C     GAMM() = GREEK GAMMA
C     DELT() = GREEK DELTA
C     EPSI() = GREEK EPSILON
C     ZETA() = GREEK ZETA
C     THET() = GREEK THETA
C     IOTA() = GREEK IOTA
C     KAPP() = GREEK KAPPA
C     LAMB() = GREEK LAMBDA
C     OMIC() = GREEK OMICON
C     SIGM() = GREEK SIGMA
C     UPSI() = GREEK UPSILON
C     OMEG() = GREEK OMEGA
C     PART() = PARTIAL DERIVATIVE
C     INTE() = INTEGRAL
C     CINT() = CIRCULAR INTEGRAL
C     SUMM() = SUMMATION
C     PROD() = PRODUCT
C     INFI() = INFINITY
C     TIME() = TIMES
C     DOTP() = DOT PRODUCT
C     DIVI() = DIVISION
C     LTEQ() = LESS THAN OR EQUAL TO
C     GTEQ() = GREATER THAN OR EQUAL TO
C     NOT=() = NOT EQUAL
C     APPR() = APPROXIMATELY EQUAL TO
C     EQUI() = EQUIVALENCE
C     VARI() = VARIES
C     TILD() = TILDE
C     CARA() = CARAT
C     PRIM() = PRIME
C     RADI() = RADICAL
C     LRAD() = LARGE RADICAL
C     SUBS() = SUBSET
C     SUPE() = SUPERSET
C     UNIO() = UNION
C     INTR() = INTERSECTION
C     ELEM() = IS AN ELEMENT OF
C     THEX() = THERE EXISTS
C     THFO() = THEREFORE
C     LAPO() = LEFT APOSTROPHE
C     RAPO() = RIGHT APOSTROPHE
C     LBRA() = LEFT BRACKET
C     RBRA() = RIGHT BRACKET
C     LCBR() = LEFT CURLY BRACKET
C     RCBR() = RIGHT CURLY BRACKET
C     LELB() = LEFT ELBOW
C     RELB() = RIGHT ELBOW
C     LACC() = LEFT ACCENT
C     BREV() = BREVE
C     RQUO() = RIGHT QUOTE
C     LQUO() = LEFT QUOTE
C     NASP() = NORMAL ASPIRATE    (NOT CURRENTLY SUPPORTED)
C     IASP() = INVERTED ASPIRATE  (NOT CURRENTLY SUPPORTED)
C     RARR() = RIGHT ARROW
C     LARR() = LEFT ARROW
C     UARR() = UP ARROW
C     DARR() = DOWN ARROW
C     PARA() = PARAGRAPH
C     DAGG() = DAGGER
C     DDAG() = DOUBLE DAGGER
C     VBAR() = VERTICAL BAR
C     DVBA() = DOUBLE VERTICAL BAR
C     LVBA() = LONG VERTICAL BAR
C     HBAR() = HORIZONTAL BAR
C     LHBA() = LONG HORIZONTAL BAR
C     DEGR() = DEGREE
C
      IWIDT2=0
      IB(1:MAXWID)=' '
      ICASFL='UPPE'
      ISUBFL=0
      ISUPFL=0
      NSKIP=0
C
      IF(IWIDTH.GE.4)THEN
        NTEMP=IWIDTH-3
        DO100I=1,NTEMP
C
          IF(ISUBRO.EQ.'TCON')THEN
            WRITE(ICOUT,151)I,IWIDT2,NSKIP,IA(I:I)
  151       FORMAT('I,IWIDT2,NSKIP,IA(I:I) = ',3I8,A1)
            CALL DPWRST('XXX','BUG ')
          ENDIF
C
          IF(NSKIP.GT.0)THEN
            NSKIP=NSKIP-1
            GOTO100
          ENDIF
C
C         SET UPPER CASE FLAG
C
          IF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1       (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            ICASFL='UPPE'
            NSKIP=3
C
C         SET LOWER CASE FLAG
C
          ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1       (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            ICASFL='UPPE'
            NSKIP=3
C
C         SET SPACE
C
          ELSEIF((IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1       (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1       IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            IB(IWIDT2:IWIDT2)=' '
            NSKIP=3
C
C         SET GREEK MU = $\mu$
C
          ELSEIF((IA(I:I).EQ.'M'.OR.IA(I:I).EQ.'m') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mu$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK NU = $\nu$
C
          ELSEIF((IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ nu$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK XI = $\xi$ OR $\XI$
C
          ELSEIF((IA(I:I).EQ.'X'.OR.IA(I:I).EQ.'x') .AND.
     1           (IA(I+1:I+1).EQ.'i'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Xi$'
            ELSE
              IB(IWIDT2:NLAST)='$ xi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET GREEK PI = $\pi$ OR $\PI$
C
          ELSEIF((IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Pi$'
            ELSE
              IB(IWIDT2:NLAST)='$ pi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET LESS THAN = <
C
          ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'L') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='<'
            NSKIP=3
C
C         SET GREATER THAN = >
C
          ELSEIF((IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='>'
            NSKIP=3
C
C         SET +/-  = $\pm$
C
          ELSEIF(IA(I:I).EQ.'+' .AND. IA(I+1:I+1).EQ.'-' .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ pm$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET -/+  = $\mp$
C
          ELSEIF(IA(I:I).EQ.'-' .AND. IA(I+1:I+1).EQ.'+' .AND.
     1           IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mp$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=3
C
C         SET SUBSCRIPT MODE = $_{
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$_{'
            IWIDT2=IWIDT2+2
            ISUBFL=ISUBFL+1
            NSKIP=4
C
C         SET SUPERSCRIPT MODE = $^{
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$^{'
            IWIDT2=IWIDT2+2
            ISUPFL=ISUPFL+1
            NSKIP=4
C
C         SET GREEK ETA = $\eta$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ eta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK RHO = $\rho$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ rho$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK TAU = $\tau$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ tau$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK PHI = $\phi$ or $\Ph$}
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Phi$'
            ELSE
              IB(IWIDT2:NLAST)='$ phi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK CHI = $\chi$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ chi$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET GREEK PSI = $\psi$ or $\Psi$
C
          ELSEIF(I.LE.IWIDTH-4.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'S'.OR.IA(I+1:I+1).EQ.'s') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Psi$'
            ELSE
              IB(IWIDT2:NLAST)='$ psi$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=4
C
C         SET VECTOR PRODUCT = I DON'T KNOW IF THERE IS A LATEX
C                              EQUIVALENT
C
CCCCC     ELSEIF((IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ chi$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=4
C
C         SET UNSUBSCRIPT MODE = }$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+1
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}$'
            IWIDT2=IWIDT2+1
            ISUBFL=ISUBFL-1
            NSKIP=5
C
C         SET UNSUPERSCRIPT MODE = }$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+1
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}$'
            IWIDT2=IWIDT2+1
            ISUPFL=ISUPFL-1
            NSKIP=5
C
C         SET GREEK ALPHA = $\alpha$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND.
     1           (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'H'.OR.IA(I+3:I+3).EQ.'h') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ alpha$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK BETA = $\beta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ beta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK GAMMA = $\gamma$ or $\Gamma$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Gamma$'
            ELSE
              IB(IWIDT2:NLAST)='$ gamma$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK DELTA = $\delta$ or $\Delta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Delta$'
            ELSE
              IB(IWIDT2:NLAST)='$ delta$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK EPSILON = $\epsilon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ epsilon$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET GREEK ZETA = $\zeta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'Z'.OR.IA(I:I).EQ.'z') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ zeta$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK THETA = $\theta$ or $\Theta$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Theta$'
            ELSE
              IB(IWIDT2:NLAST)='$ theta$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK IOTA = $\iota$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ iota$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET GREEK KAPPA = $\kappa$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'K'.OR.IA(I:I).EQ.'k') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ kappa$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK LAMBDA = $\lambda$ or $\Lambda$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Lambda$'
            ELSE
              IB(IWIDT2:NLAST)='$ lambda$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET GREEK OMICON = $\omicon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND.
     1           (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ omicon$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET GREEK SIGMA = $\sigma$ or $\Sigma$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Sigma$'
            ELSE
              IB(IWIDT2:NLAST)='$ sigma$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET GREEK UPSILON = $\upsilon$ or $\Upsilon$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+10
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Upsilon$'
            ELSE
              IB(IWIDT2:NLAST)='$ upsilon$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+10
            NSKIP=5
C
C         SET GREEK OMEGA = $\omega$ or $\Omega$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND.
     1           (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IF(ICASFL.EQ.'UPPE')THEN
              IB(IWIDT2:NLAST)='$ Omega$'
            ELSE
              IB(IWIDT2:NLAST)='$ omega$'
            ENDIF
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET PARTIAL DERIVATIVE = $\partial$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ partial$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET INTEGRAL = $\int$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ int$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET CIRCULAR INTEGRAL = $\oint$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'N'.OR.IA(I+2:I+2).EQ.'n') .AND.
     1           (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ oint$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET SUMMATION = $\sum$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sum$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET PRODUCT = $\prod$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ prod$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET INFINITY = $\infty$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'F'.OR.IA(I+2:I+2).EQ.'f') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ infty$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET TIMES = $\times$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ times$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET DOT PRODUCT = $\cdot$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cdot$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET DIVISION = $\div$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'V'.OR.IA(I+2:I+2).EQ.'v') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ div$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LESS THAN OR EQUAL TO = $\le$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ le$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET GREATER THAN OR EQUAL TO = $\ge$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ge$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET GREATER THAN OR EQUAL TO = $\ge$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND.
     1           (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ge$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET NOT EQUAL TO = $\ne$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND.
     1           (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'='.OR.IA(I+3:I+3).EQ.'=') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ne$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET APPROXIMATELY = $\approx$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND.
     1           (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ approx$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET EQUIVALENCE = $\equiv$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+7
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ equiv$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+7
            NSKIP=5
C
C         SET VARIES = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+7
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ equiv$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+7
CCCCC       NSKIP=5
C
C         SET TILDE = ~
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND.
     1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='~'
            NSKIP=5
C
C         SET CARAT = ^
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='^'
            NSKIP=5
C
C         SET RADICAL = $\sqrt$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'D'.OR.IA(I+2:I+2).EQ.'d') .AND.
     1           (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sqrt$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET LARGE RADICAL = $\sqrt$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+6
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ sqrt$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+6
            NSKIP=5
C
C         SET SUBSET = $\subset$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'S'.OR.IA(I+3:I+3).EQ.'s') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ subset$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET SUPERSET = $\supset$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND.
     1           (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ supset$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET UNION = $\cup$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cup$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET INTERSECTION = $\cap$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND.
     1           (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND.
     1           (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ cap$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET IS AN ELEMENT OF = $\in$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND.
     1           (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ in$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET THERE EXISTS = $\exists$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
     1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ exists$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET THEREFORE = I DON'T KNOW WHAT THIS SHOULD BE
C
CCCCC     ELSEIF((IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET LEFT APOSTROPHE = `
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='`'
            NSKIP=5
C
C         SET RIGHT APOSTROPHE = '
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)="`"
            NSKIP=5
C
C         SET LEFT BRACKET = [
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='['
            NSKIP=5
C
C         SET LEFT CURLY BRACKET = {
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='{'
            NSKIP=5
C
C         SET RIGHT CURLY BRACKET = }
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='}'
            NSKIP=5
C
C         SET RIGHT BRACKET = ]
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)=']'
            NSKIP=5
C
C         SET LEFT ELBOW = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET RIGHT ELBOW = I DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+8
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ exists$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+8
CCCCC       NSKIP=5
C
C         SET LEFT ACCENT = $\`$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'C'.OR.IA(I+2:I+2).EQ.'c') .AND.
     1           (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+4
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ `$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+4
            NSKIP=5
C
C         SET BREVE = $\vee$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND.
     1           (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND.
     1           (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND.
     1           (IA(I+3:I+3).EQ.'V'.OR.IA(I+3:I+3).EQ.'v') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ vee$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LEFT QUOTE = "
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='"'
            NSKIP=5
C
C         SET RIGHT QUOTE = "
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND.
     1           (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND.
     1           (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='"'
            NSKIP=5
C
C         SET RIGHT ARROW = $\rightarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+12
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ rightarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+12
            NSKIP=5
C
C         SET LEFT ARROW = $\leftarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+11
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ leftarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+11
            NSKIP=5
C
C         SET DOWN ARROW = $\downarrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+11
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ downarrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+11
            NSKIP=5
C
C         SET UP ARROW = $\uparrow$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ uparrow$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET PARAGRAP = NOT SURE ABOUT THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+9
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ uparrow$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+9
CCCCC       NSKIP=5
C
C         SET DAGGER = $\dagger$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+8
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ dagger$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+8
            NSKIP=5
C
C         SET DOUBLE DAGGER = $\ddagger$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'D'.OR.IA(I+1:I+1).EQ.'d') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+9
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ ddagger$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+9
            NSKIP=5
C
C         SET VERTICAL BAR = $\mid$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'V'.OR.IA(I:I).EQ.'v') .AND.
     1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
     1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mid$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET LONG VERTICAL BAR = $\mid$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
     1           (IA(I+1:I+1).EQ.'V'.OR.IA(I+1:I+1).EQ.'v') .AND.
     1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
     1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ mid$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
C
C         SET HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'H'.OR.IA(I:I).EQ.'h') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ mid$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=5
C
C         SET LONG HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE
C
CCCCC     ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND.
CCCCC1           (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND.
CCCCC1           (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND.
CCCCC1           (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND.
CCCCC1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
CCCCC       IWIDT2=IWIDT2+1
CCCCC       NLAST=IWIDT2+5
CCCCC       IF(NLAST.GT.MAXWID)GOTO8010
CCCCC       IB(IWIDT2:NLAST)='$ mid$'
CCCCC       IB(IWIDT2+1:IWIDT2+1)=IBASLC
CCCCC       IWIDT2=IWIDT2+5
CCCCC       NSKIP=5
C
C         SET DEGREE = $\deg$
C
          ELSEIF(I.LE.IWIDTH-5.AND.
     1           (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND.
     1           (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND.
     1           (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND.
     1           (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND.
     1           IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN
            IWIDT2=IWIDT2+1
            NLAST=IWIDT2+5
            IF(NLAST.GT.MAXWID)GOTO8010
            IB(IWIDT2:NLAST)='$ deg$'
            IB(IWIDT2+1:IWIDT2+1)=IBASLC
            IWIDT2=IWIDT2+5
            NSKIP=5
          ELSE
            IWIDT2=IWIDT2+1
            IB(IWIDT2:IWIDT2)=IA(I:I)
          ENDIF
  100   CONTINUE
      ELSE
        DO190I=1,IWIDTH
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2)=IA(I:I)
  190   CONTINUE
        GOTO9000
      ENDIF
C
      ISTRT=IWIDTH-2
      ISTRT=ISTRT+NSKIP
      IF(ISTRT.LE.IWIDTH)THEN
        DO200I=ISTRT,IWIDTH
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2)=IA(I:I)
  200   CONTINUE
      ENDIF
C
      IF(ISUBFL.GT.0)THEN
        DO300I=1,ISUBFL
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2+1)='}$'
          IWIDT2=IWIDT2+1
  300   CONTINUE
      ENDIF
C
      IF(ISUPFL.GT.0)THEN
        DO400I=1,ISUPFL
          IWIDT2=IWIDT2+1
          IB(IWIDT2:IWIDT2+1)='}$'
          IWIDT2=IWIDT2+1
  400   CONTINUE
      ENDIF
C
      GOTO9000
C
 8010 CONTINUE
      WRITE(ICOUT,8011)
 8011 FORMAT('***** ERROR IN CONVERTING DATAPLOT SPECIAL ',
     1       'CHARACTERS TO EQUIVALENT LATEX--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,8013)
 8013 FORMAT('      MAXIMUM NUMBER OF CHARACTERS, ',I5,',',
     1       'IN LATEX STRING EXCEEDED.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(ISUBRO.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LATCON--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IWIDTH,ISUBRO,IERROR
 9012   FORMAT('IWIDTH,ISUBRO,IERROR = ',I8,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)(IB(I:I),I=1,MIN(100,IWIDT2))
 9014   FORMAT('(IB(I:I),I=1,IWIDT2) = ',100A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LBECDF(X,ALPHA,BETA,C,D,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION.
C              THE LOG-BETA CDF IS COMPUTED AS:
C
C              LBECDF(X;ALPHA,BETA,C,D) = BETCDF(Z;ALPHA,BETA,C,D)
C                                         0 < C <= X <= D
C                                         ALPHA, BETA > 0
C
C              WHERE
C
C                  Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C))
C
C              AND BETCDF IS THE BETA CUMULATIVE DISTRIBUTION
C              FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                THIRD (LOWER LIMIT) SHAPE PARAMETER
C                     --D      = THE SINGLE PRECISION VALUE OF THE
C                                FOURTH (UPPER LIMIT) SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG-BETA DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE > C.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BETCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--NADARAJAH AND GUPTA (2004).  "APPLICATIONS OF THE
C                 BETA DISTRIBUTION" in "HANDBOOK OF THE BETA
C                 DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH,
C                 MARCEL-DEKKER, PP.100-102.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-----------------
C
C-----COMMON--------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ',
     1         'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ',
     1       'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,6)
    6   FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ',
     1         'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.LE.C)THEN
        CDF=0.0
CCCCC   WRITE(ICOUT,7)
CCCC7 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBECDF ',
CCCCC1       'IS LESS THAN THE LOWER LIMIT.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,48)C
CCCCC   CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(D.LE.C)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR--THE UPPER LIMIT TO LBECDF ',
     1         'IS LESS THAN THE LOWER LIMIT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)D
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.GE.D)THEN
CCCCC   WRITE(ICOUT,9)
CCCC9   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBECDF ',
CCCCC1         'IS GREATER THAN THE UPPER LIMIT.')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,49)D
CCCCC   CALL DPWRST('XXX','BUG ')
        CDF=1.0
        GOTO9999
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7)
C
C-----START POINT---------------------------------------------------
C
      CDF=0.0
      Z=(LOG(X) - LOG(C))/(LOG(D) - LOG(C))
      CALL BETCDF(Z,ALPHA,BETA,CDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LBEPDF(X,ALPHA,BETA,C,D,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION.
C              THE LOG-BETA PDF IS COMPUTED AS:
C
C              LBEPDF(X;ALPHA,BETA,C,D) = BETPDF(Z;ALPHA,BETA,C,D)
C                                         0 < C <= X <= D
C                                         ALPHA, BETA > 0
C
C              WHERE
C
C                  Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C))
C
C              AND BETPDF IS THE BETA PROBABILITY DENSITY
C              FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                THIRD (LOWER LIMIT) SHAPE PARAMETER
C                     --D      = THE SINGLE PRECISION VALUE OF THE
C                                FOURTH (UPPER LIMIT) SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-BETA DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE > C.
C     OTHER DATAPAC   SUBROUTINES NEEDED--BETPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--NADARAJAH AND GUPTA (2004).  "APPLICATIONS OF THE
C                 BETA DISTRIBUTION" in "HANDBOOK OF THE BETA
C                 DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH,
C                 MARCEL-DEKKER, PP.100-102.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-----------------
C
C-----COMMON--------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ',
     1         'LBEPDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ',
     1         'LBEPDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,6)
    6   FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ',
     1         'LBEPDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.LE.C)THEN
        WRITE(ICOUT,7)
    7   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBEPDF ',
     1         'IS LESS THAN THE LOWER LIMIT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(D.LE.C)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR--THE UPPER LIMIT TO LBEPDF ',
     1         'IS LESS THAN THE LOWER LIMIT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)D
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(X.GE.D)THEN
        WRITE(ICOUT,9)
    9   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBEPDF ',
     1         'IS GREATER THAN THE UPPER LIMIT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)D
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7)
C
C-----START POINT---------------------------------------------------
C
      PDF=0.0
      Z=(LOG(X) - LOG(C))/(LOG(D) - LOG(C))
      CALL BETPDF(Z,ALPHA,BETA,PDF)
      PDF=PDF/(X*(LOG(D)-LOG(C)))
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LBEPPF(P,ALPHA,BETA,C,D,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION.
C              THE LOG-BETA PPF IS COMPUTED AS:
C
C              LBEPPF(P;ALPHA,BETA,C,D) = EXP(LOG(C)+
C                    (LOG(D) - LOG(C))*BETPPF(P;ALPHA,BETA,C,D))
C                                         0 < C <= X <= D
C                                         ALPHA, BETA > 0
C
C              BETPPF IS THE BETA PERCENT POINT FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                THIRD (LOWER LIMIT) SHAPE PARAMETER
C                     --D      = THE SINGLE PRECISION VALUE OF THE
C                                FOURTH (UPPER LIMIT) SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE CDF FOR THE LOG-BETA DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 < P < 1, ALPHA, BETA, C > 0, D > C
C     OTHER DATAPAC   SUBROUTINES NEEDED--BETPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--NADARAJAH AND GUPTA (2004).  "APPLICATIONS OF THE
C                 BETA DISTRIBUTION" in "HANDBOOK OF THE BETA
C                 DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH,
C                 MARCEL-DEKKER, PP.100-102.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-----------------
C
C-----COMMON--------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ',
     1         'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ',
     1         'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(C.LT.0.0)THEN
        WRITE(ICOUT,6)
    6   FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ',
     1         'LBECDF IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)C
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(D.LE.C)THEN
        WRITE(ICOUT,8)
    8   FORMAT('***** ERROR--THE UPPER LIMIT PARAMETER TO LBECDF ',
     1         'IS LESS THAN THE LOWER LIMIT.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)D
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(P.LE.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,7)
    7   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBECDF ',
     1         'IS OUTSIDE THE (0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7)
C
C-----START POINT---------------------------------------------------
C
      PPF=0.0
      CALL BETPPF(P,ALPHA,BETA,PPF)
      PPF=EXP(LOG(C) + PPF*(LOG(D)-LOG(C)))
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LBERAN(N,ALPHA,BETA,C,D,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-BETA DISTRIBUTION WITH SINGLE PRECISION
C              SHAPE PARAMETERS ALPHA AND BETA AND LOWER AND UPPER
C              LIMIT PARAMETERS C AND D.
C              THE LOG-BETA PDF IS COMPUTED AS:
C
C              LBEPDF(X;ALPHA,BETA,C,D) = BETPDF(Z;ALPHA,BETA,C,D)
C                                         0 < C <= X <= D
C                                         ALPHA, BETA > 0
C
C              WHERE
C
C                  Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C))
C
C              AND BETPDF IS THE BETA PROBABILITY DENSITY
C              FUNCTION.
C
C              LIKEWISE, LOG-BETA RANDOM NUMBERS ARE GENERATED
C              BY APPLYING THE APPROPRIATE TRANSFORMATION TO
C              BETA RANDOM NUMBERS.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER
C                     --C      = THE SINGLE PRECISION VALUE OF THE
C                                THIRD (LOWER LIMIT) SHAPE PARAMETER
C                     --D      = THE SINGLE PRECISION VALUE OF THE
C                                FOURTH (UPPER LIMIT) SHAPE PARAMETER
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-BETA DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES ALPHA, BETA, C, AND D.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA > 0
C                 --BETA > 0
C                 --C > 0
C                 --D > C
C     OTHER DATAPAC   SUBROUTINES NEEDED--BETRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--NADARAJAH AND GUPTA (2004).  "APPLICATIONS OF THE
C                 BETA DISTRIBUTION" in "HANDBOOK OF THE BETA
C                 DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH,
C                 MARCEL-DEKKER, PP.100-102.
C     WRITTEN BY--ALAN HECKERT
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006.6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG-BETA ',
     1         'RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER ',
     1         'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE BETA SHAPE PARAMETER ',
     1         'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(C.LE.0.0)THEN
        WRITE(ICOUT,13)
   13   FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER C ',
     1         'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(D.LE.C)THEN
        WRITE(ICOUT,16)
   16   FORMAT('***** ERROR--THE UPPER LIMIT PARAMETER D ',
     1         'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)C
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)D
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      CALL BETRAN(N,ALPHA,BETA,ISEED,X)
      DO100I=1,N
        X(I)=EXP(LOG(C) + (LOG(D)-LOG(C))*X(I))
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LCTCDF(X,N,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LEADS IN COIN TOSSING
C              DISTRIBUTION ON THE INTERVAL (0,N).
C              THIS DISTRIBUTION HAS MEAN = N/2
C              AND STANDARD DEVIATION = SQRT(N(N+1)/8)
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              MASS FUNCTION:
C
C                P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/
C                         X!*X!*(N-X)!*(N-X)!
C                         X = 0, 1, ..., N
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                       N      = THE INTEGER VALUE THAT SPECIFIES
C                                THE MAXIMUM VALUE
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
C                 PAGES 274-275.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DENOM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DLNGAM
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
C
      IF(N.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1       'LCTCDF SUBROUTINE IS LESS THAN 0.')
C
      IX=INT(X+0.5)
      IF(IX.LT.0 .OR. IX.GT.N)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)IX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1       'LCTCDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
C
      DCDF=0.0D0
      DO100I=0,IX
        DX=DBLE(I)
        DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1)
     1       -2.0D0*DN*DLOG(2.0D0)
        DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1))
        DPDF=DEXP(DNUM-DENOM)
        DCDF=DCDF + DPDF
  100 CONTINUE
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LCTPDF(X,N,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LEADS IN COIN TOSSING
C              DISTRIBUTION ON THE INTERVAL (0,N).
C              THIS DISTRIBUTION HAS MEAN = N/2
C              AND STANDARD DEVIATION = SQRT(N(N+1)/8)
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              MASS FUNCTION:
C
C                P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/
C                         X!*X!*(N-X)!*(N-X)!
C                         X = 0, 1, ..., N
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                       N      = THE INTEGER VALUE THAT SPECIFIES
C                                THE MAXIMUM VALUE
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, INCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
C                 PAGES 274-275.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DENOM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
C
      IF(N.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1       'LCTPDF SUBROUTINE IS LESS THAN 0.')
C
      IX=INT(X+0.5)
      IF(IX.LT.0 .OR. IX.GT.N)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)IX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1       'LCTPDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(IX)
      DN=DBLE(N)
      DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1)
     1     -2.0D0*DN*DLOG(2.0D0)
      DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1))
      DPDF=DEXP(DNUM-DENOM)
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LCTPPF(P,N,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LEADS IN COIN TOSSING
C              DISTRIBUTION ON THE INTERVAL (0,N).
C              THIS DISTRIBUTION HAS MEAN = N/2
C              AND STANDARD DEVIATION = SQRT(N(N+1)/8)
C              THIS DISTRIBUTION HAS THE PROBABILITY
C              MASS FUNCTION:
C
C                P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/
C                         X!*X!*(N-X)!*(N-X)!
C                         X = 0, 1, ..., N
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                       N      = THE INTEGER VALUE THAT SPECIFIES
C                                THE MAXIMUM VALUE
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P <= 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS" SECOND EDITION,
C                 PAGES 274-275.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNUM
      DOUBLE PRECISION DENOM
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLNGAM
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
C
      IF(N.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   12 FORMAT('***** ERROR--THE SECOND ARGUMENT TO ',
     1       'LCTPPF IS LESS THAN 0.')
C
      IF(P.LT.0.0 .OR. P.GT.1.0)THEN
        WRITE(ICOUT,2)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    2 FORMAT('***** ERROR--THE FIRST ARGUMENT TO ',
     1       'LCTPPF IS OUTSIDE THE (0,1) INTERVAL')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
C     P = 0 AND P = 1 CASES
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9000
      ELSEIF(P.GE.1.0)THEN
        PPF=REAL(N)
        GOTO9000
      ENDIF
C
      DP=DBLE(P)
      DN=DBLE(N)
C
      DEPS=1.0D-7
      DCDF=0.0D0
      DO100I=0,N
        DX=DBLE(I)
        DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1)
     1       -2.0D0*DN*DLOG(2.0D0)
        DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1))
        DPDF=DEXP(DNUM-DENOM)
        DCDF=DCDF + DPDF
C
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9000
        ENDIF
C
  100 CONTINUE
C
      PPF=REAL(N)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LCTRAN(N,NPAR,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LEADS IN COIN TOSSING DISTRIBUTION
C              WITH SHAPE PARAMETERS NPAR.
C              THIS DISTRIBUTION IS DEFINED FOR
C              NON-NEGATIVE INTEGERS IN THE RANGE 0 TO NPAR.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C
C                P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/
C                         X!*X!*(N-X)!*(N-X)!
C                         X = 0, 1, ..., N
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NPAR   = THE INTEGER VALUE
C                                OF THE SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LEADS IN COIN TOSSING DISTRIBUTION
C             WITH SHAPE PARAMETERS N AND NPAR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --NPAR > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LCTPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 242-244.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER N
      INTEGER NPAR
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
      IF(NPAR.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NPAR
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1'LEADS IN COIN TOSSING RANDOM NUMBERS IS NON-POSITIVE')
   12 FORMAT('***** ERROR--THE NPAR PARAMETER FOR THE ',
     1'LEADS IN COIN TOSSING RANDOM NUMBERS IS NON-POSITIVE')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C 100 CONTINUE
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        XTEMP=X(I)
        CALL LCTPPF(XTEMP,NPAR,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE LDECDF(X,ALPHA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE CUMULATIVE DISTRIBUTION FUNCTION
C              F(X) = 0.5*X**ALPHA           0 < X < 1
C                   = 1.0 - 0.5*X**ALPHA     X >= 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DCDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
      CDF=0.0
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'LDECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDECDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
C
      IF(X.LT.1.0)THEN
        DCDF=0.5D0*DX**DALPHA
      ELSE
        DCDF=1.0D0 - 0.5D0*DX**(-DALPHA)
      ENDIF
      CDF=REAL(DCDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LDEPDF(X,ALPHA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (ALPHA/2)*X**(ALPHA-1)   0 < X < 1
C                   = (ALPHA/2)*X**(-ALPHA-1)   X>= 1
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--XX
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTWO
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C
      PDF=0.0
C
      IF(X.LE.0.0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1         'LDEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDEPDF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      DX=DBLE(X)
      DALPHA=DBLE(ALPHA)
      DTWO=DLOG(2.0D0)
C
      IF(X.LT.1.0)THEN
        DTERM=DLOG(DALPHA) - DTWO + (DALPHA-1.0D0)*DLOG(DX)
        DPDF=DEXP(DTERM)
      ELSE
        DTERM=DLOG(DALPHA) - DTWO + (-DALPHA-1.0D0)*DLOG(DX)
        DPDF=DEXP(DTERM)
      ENDIF
      PDF=REAL(DPDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LDEPPF(P,ALPHA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL
C              (LAPLACE) DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND
C              HAS THE PERCENT POINT FUNCTION
C              G(P) = SQRT(2*P)
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALPHA  = THE SINLE PRECISION SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
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 (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001/9
C     ORIGINAL VERSION--SEPTEMBER 2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LDEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1         'LDEPPF SUBROUTINE IS NON-POSITIVE *****')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      AONE=1.0
      DP=DBLE(P)
      DALPHA=DBLE(ALPHA)
      CALL LDECDF(AONE,ALPHA,CDF)
C
      IF(P.LT.CDF)THEN
        DPPF=(2.0D0*DP)**(1.0D0/DALPHA)
      ELSE
        DPPF=(2.0D0*(1.0D0-DP))**(-1.0D0/DALPHA)
      ENDIF
      PPF=REAL(DPPF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LDERAN(N,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG DOUBLE EXPONENTIAL DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = ALPHA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                ALPHA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG DOUBLE EXPONENTIAL DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALPHA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--KOZUBOWSKI AND PODGORSKI, "LOG-LAPLACE
C                 DISTRIBUTIONS", PAPER DOWNLOADED FROM THEIR
C                 WEB SITE.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED         --MARCH     2006. COMPUTE RANDOM NUMBERS
C                                       AS RATIO OF UNIFORMS
C                                       NOTE: THIS SEEMS TO GENERATE
C                                       EXCESIVELY LARGE NUMBERS, SO
C                                       REVERT BACK TO PPF ALGORITHM
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DY1
      DOUBLE PRECISION DY2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG DOUBLE ',
     1'EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE LOG DOUBLE',
     1' EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N LOG DOUBLE EXPONENTIAL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
C     NOTE 3/2006: LOG DOUBLE EXPONENTIAL CAN BE REPRESENTED AS
C                  U1**(1/ALPHA)/U2**(1/ALPHA)
C
C     RUNNING SOME SIMULATIONS SEEMS TO SHOW THAT THE RATIO OF
C     UNIFORM METHOD RESULTS IN SOME EXCESSIVELY LARGE RANDOM
C     NUMBERS.
C
      IALG=0
      IF(IALG.EQ.0)THEN
        CALL UNIRAN(N,ISEED,X)
        DO100I=1,N
          CALL LDEPPF(X(I),ALPHA,XTEMP)
          X(I)=XTEMP
  100   CONTINUE
      ELSE
        NTEMP=2
        DALPHA=DBLE(ALPHA)
        DO200I=1,N
          CALL UNIRAN(NTEMP,ISEED,Y)
          DY1=DBLE(Y(1))
          DY2=DBLE(Y(2))
          X(I)=REAL(DY1**(1.0D0/DALPHA)/DY2**(1.0D0/DALPHA))
  200   CONTINUE
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEGNDR(X,AN,PN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LEGENDRE
C              POLYNOMIAL OF ORDER N.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--PN    = THE SINGLE PRECISION VALUE OF THE
C                                LEGENDRE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    P(N+1) = X*P(N)+(N/N+1)*(X*P(N)-P(N-1))
C                 FIRST FEW TERMS ARE FROM TABLE 22.9 OF ABRAMOWITZ
C                 AND STEGUM.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DPN, DPN1, DPN2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN
CCCCC   WRITE(ICOUT,4)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,46)X
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   GOTO9999
CCCCC ENDIF
CCCC4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ',
CCCCC1'TO THE LEGNDR SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****')
CCC46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LEGNDR SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        PN=1.0
      ELSEIF(N.EQ.1)THEN
        PN=X
      ELSEIF(N.EQ.2)THEN
        PN=1.5*X**2-0.5
      ELSEIF(N.EQ.3)THEN
        DPN=2.5D0*DX**3-1.5D0*DX
        PN=REAL(DPN)
      ELSE
        DPN1=2.5D0*DX**3-1.5D0*DX
        DPN2=1.5D0*DX**2-0.5D0
        DO1000I=4,N
          DN=DBLE(I)-1.0D0
          DPN=DX*DPN1+(DN/(DN+1.0D0))*(DX*DPN1-DPN2)
          DPN2=DPN1
          DPN1=DPN
 1000   CONTINUE
        PN=REAL(DPN)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LEXCDF(X,BETA,CDF)
C
C     NOTE--LOGISTIC-EXPONENTIAL CDF IS:
C
C           F(X;ALPHA,BETA) = 1 - 1/[1 + EXP(ALPHA*X) -1)**BETA]
C                             X > 0; ALPHA, BETA > 0
C
C           WITH (1/ALPHA) DENOTING THE SCALE PARAMETER AND
C           BETA DENOTING THE SHAPE PARAMETER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXCDF IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXCDF IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LEXCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(X.LE.0.0D0)THEN
        CDF=0.0D0
      ELSE
        CDF=1.0D0 - 1.0D0/(1.0D0 + (DEXP(X) - 1.0D0)**BETA)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEXCHA(X,BETA,HAZ)
C
C     NOTE--LOGISTIC-EXPONENTIAL CUMULATIVE HAZARD IS:
C
C           H(X;ALPHA,BETA) = -LOG(1/[1 + EXP(ALPHA*X) -1)**BETA])
C                             X >= 0; ALPHA, BETA > 0
C
C           WITH (1/ALPHA) DENOTING THE SCALE PARAMETER AND
C           BETA DENOTING THE SHAPE PARAMETER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXCHAZ IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXCHAZ IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LEXCHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=1.0D0/(1.0D0 + (DEXP(X) - 1.0D0)**BETA)
      IF(TERM1.GT.0.0D0)THEN
        HAZ=-DLOG(TERM1)
      ELSE
        HAZ=0.0D0
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEXFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE-THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C             LOGISTIC-EXPONENTIAL MAXIMUM LIKELIHOOD EQUATIONS.
C
C             (N/BETA) + SUM[i=1 to N][LOG(EXP(ALPHA*X(i)) - 1) -
C             2*SUM[i=1 to N][(EXP(ALPHA*X(I) - 1)**BETA*
C             LOG(EXP(ALPHA*X(i)) -1)/{1 + (EXP(ALPHA*X(i)) - 1)**BETA}
C             = 0
C
C             (N/ALPHA) + SUM[i=1 to N][(BETA-1)*X(i)*EXP(ALPHA*X(i))/
C             (EXP(ALHA*X(i)) - 1) + SUM[i=1 to N][X(i)] -
C             2*SUM[i=1 to N][BETA*(EXP(ALPHA*X(I) - 1)**(BETA - 1)*
C             X9I)*EXP(ALPHA*X(i))/{1 + (EXP(ALPHA*X(i)) - 1)**BETA}
C             = 0
C
C             WHERE
C
C               BETA     = SHAPE PARAMETER
C               ALPHA    = SCALE PARAMETER
C
C             CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C             NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C             DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C             OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--LOGISTIC-EXPONENTIAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DSUM5
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DN=DBLE(NOBS)
      DBETA=DBLE(X(1))
      DALPHA=DBLE(X(2))
C
      DTERM1=DN/DBETA
      DTERM2=DN/DALPHA
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DSUM5=0.0D0
C
      DO200I=1,NOBS
C
        DX=DBLE(XDATA(I))
        DTERM4=DEXP(DALPHA*DX)
        DTERM3=DTERM4 - 1.0D0
C
        DSUM1=DSUM1 + DLOG(DTERM3)
        DSUM2=DSUM2 + DTERM3**DBETA*DLOG(DTERM3)/(1.0D0 + DTERM3**DBETA)
        DSUM3=DSUM3 + (DBETA-1.0D0)*DX*DTERM4/DTERM3
        DSUM4=DSUM4 + DBETA*DTERM3**(DBETA-1.0D0)*DX*DTERM4/
     1        (1.0D0 + DTERM3**DBETA)
        DSUM5=DSUM5 + DX
C
  200 CONTINUE
C
      FVEC(1)=DTERM1 + DSUM1 - 2.0D0*DSUM2
      FVEC(2)=DTERM2 + DSUM3 + DSUM5 - 2.0D0*DSUM4
C
      RETURN
      END
      SUBROUTINE LEXFU2 (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE-THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C             STARTING VALUES OF THE LOGISTIC-EXPONENTIAL
C             MAXIMUM LIKELIHOOD EQUATIONS.
C
C             G(P1) = (1/ALPHA)*LOG(1 + (P1/(1 - P1)**(1/BETA))
C             G(P2) = (1/ALPHA)*LOG(1 + (P2/(1 - P2)**(1/BETA))
C
C             WHERE
C
C               BETA     = SHAPE PARAMETER
C               ALPHA    = SCALE PARAMETER
C
C             THAT IS, WE EQUATE TWO PERCENTILES OF THE DATA
C             (USUALLY 0.25 AND 0.75) WITH THE THEORETICAL
C             PERCENTILES.
C
C             CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C             NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C             DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C             OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--LOGISTIC-EXPONENTIAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     WRITTEN BY--ALAN HECKERT
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DBETA
      DOUBLE PRECISION DALPHA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION DP1
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DGP1
      DOUBLE PRECISION DGP2
      COMMON/LEXCO2/DP1,DP2,DGP1,DGP2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=2
      IFLAG=0
C
      IF(ISUBG4.EQ.'XFU2')THEN
        WRITE(ICOUT,52)NOBS,XDATA(1)
   52   FORMAT('NOBS,XDATA(1) = ',I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      DBETA=X(1)
      DALPHA=X(2)
      DTERM1=DP1/(1.0D0 - DP1)
      DTERM2=DP2/(1.0D0 - DP2)
C
      FVEC(1)=(1.0D0/DALPHA)*DLOG(1.0D0 + DTERM1**(1.0D0/DBETA)) - DGP1
      FVEC(2)=(1.0D0/DALPHA)*DLOG(1.0D0 + DTERM2**(1.0D0/DBETA)) - DGP2
C
      RETURN
      END
      SUBROUTINE LEXHAZ(X,BETA,HAZ)
C
C     NOTE--LOGISTIC-EXPONENTIAL HAZARD IS:
C
C           h(X;BETA) = BETA*(EXP(X) - 1)**(BETA-1)*EXP(X)/
C                       [1 + (EXP(X) - 1)**BETA]
C                             X >= 0; BETA > 0
C
C           WITH BETA DENOTING THE SHAPE PARAMETER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXHAZ IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXHAZ IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LEXHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=DLOG(BETA) + X + (BETA - 1.0D0)*DLOG(DEXP(X) - 1.0D0)
      TERM2=DLOG(1.0D0 + (DEXP(X) - 1.0D0)**BETA)
      HAZ=DEXP(TERM1 - TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEXML1(Y,N,MAXNXT,
     1                  TEMP1,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,XSUM,
     1                  SCALSV,SHAPSV,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES FOR
C              THE 2-PARAMETER LOGISTIC-EXPONENTIAL DISTRIBUTION FOR THE
C              RAW DATA CASE (I.E., NO CENSORING AND NO GROUPING).  THIS
C              ROUTINE RETURNS ONLY THE POINT ESTIMATES (CONFIDENCE
C              INTERVALS WILL BE COMPUTED IN A SEPARATE ROUTINE).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMB10 WILL GENERATE THE OUTPUT
C              FOR THE LOGISTIC-EXPONENTIAL MLE COMMAND).
C
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2010/2
C     ORIGINAL VERSION--FEBRUARY  2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMB10)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
C
      DOUBLE PRECISION DP1
      DOUBLE PRECISION DP2
      DOUBLE PRECISION DGP1
      DOUBLE PRECISION DGP2
C
      EXTERNAL LEXFUN
      EXTERNAL LEXFU2
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='B10M'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LEXML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'XML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C               *****************************************************
C               **  STEP 2--                                       **
C               **  CARRY OUT CALCULATIONS                         **
C               **  FOR LOGISTIC-EXPONENTIAL MLE ESTIMATE          **
C               *****************************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='LOGISTIC-EXPONENTIAL'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      CALL SUMDP(Y,N,IWRITE,XSUM,IBUGA3,IERROR)
C
      SHAPML=CPUMIN
      SCALML=CPUMIN
C
      IF(SCALSV.GT.0.0)THEN
        XPAR(2)=DBLE(SCALSV)
      ELSE
        AN=REAL(N)
        XPAR(2)=DBLE(AN*LOG(2.0)/XSUM)
      ENDIF
      IF(SHAPSV.GT.0.0)THEN
        XPAR(1)=DBLE(SHAPSV)
      ELSE
        AN=REAL(N)
        ATEMP=AN*LOG(2.0)/XSUM
        DSUM=0.0D0
        DO2109I=1,N
          DSUM=DSUM + DBLE(ABS(LOG(EXP(ATEMP*Y(I)) - 1.0)))
 2109   CONTINUE
        XPAR(1)=DBLE(N)/DSUM
      ENDIF
C
C               *************************************
C               **  STEP 22--                      **
C               **  IF NO STARTING VALUES GIVEN,   **
C               **  USE PERCENTILES METHOD TO      **
C               **  OBTAIN THEM.                   **
C               *************************************
C
C
        P1=25.0
        CALL PERCEN(P1,Y,N,IWRITE,TEMP1,MAXNXT,P1OUT,IBUGA3,IERROR)
        P2=75.0
        CALL PERCEN(P2,Y,N,IWRITE,TEMP1,MAXNXT,P2OUT,IBUGA3,IERROR)
        DP1=DBLE(P1)/100.0D0
        DP2=DBLE(P2)/100.0D0
        DGP1=DBLE(P1OUT)
        DGP2=DBLE(P2OUT)
C
        IOPT=2
        TOL=1.0D-6
        NVAR=2
        NPRINT=-1
        INFO=0
        LWA=MAXNXT
        CALL DNSQE(LEXFU2,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1             DTEMP1,MAXNXT,Y,N)
C
C               *************************************
C               **  STEP 23--                      **
C               **  NOW COMPUTE THE MAXIMUM        **
C               **  LIKELIHOOD ESTIMATES.          **
C               *************************************
C
CCCCC NOTE: ALPHA IN LEEMIS PARAMETERIZATION IS ACTUALLY
CCCCC       (1/SCALE).  FOR DATAPLOT, GENERATE TRUE SCALE
CCCCC        PARAMETER.
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      CALL DNSQE(LEXFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      SHAPML=REAL(XPAR(1))
      SCALML=1.0/REAL(XPAR(2))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LEXML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX,XSUM
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX,XSUM = ',I8,5G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHAPSV,SCALSV,SHAPML,SCALML
 9017   FORMAT('SHAPSV,SCALSV,SHAPML,SCALML =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LEXPDF(X,BETA,PDF)
C
C     NOTE--LOGISTIC-EXPONENTIAL PDF IS:
C
C           f(X;ALPHA,BETA) = ALPHA*BETA*(EXP(ALPHA*X)-1)**(BETA-1)*
C                             EXP(ALPHA*X)/
C                             {(1+(EXP(ALPHA*X)-1)**BETA)**2}
C                             X > 0; ALPHA, BETA > 0
C
C           WITH (1/ALPHA) DENOTING THE SCALE PARAMETER AND
C           BETA DENOTING THE SHAPE PARAMETER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     VERSION NUMBER--2008/1
C     ORIGINAL VERSION--JANUARY   2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LE.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXPDF IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LEXPDF IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LEXPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=DLOG(BETA)
      TERM2=(BETA-1.0D0)*DLOG(DEXP(X) - 1.0D0)
      TERM3=2.0D0*DLOG(1.0D0 + (DEXP(X) - 1.0D0)**BETA)
      TERM4=TERM1 + TERM2 + X - TERM3
      PDF=DEXP(TERM4)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEXPPF(P,BETA,PPF)
C
C     NOTE--LOGISTIC-EXPONENTIAL PPF IS:
C
C           G(P;BETA) = LOG[1 + (1/(1-P) - 1)**(1/BETA)]
C                       0 <= P < 1; BETA > 0
C
C           WITH BETA DENOTING THE SHAPE PARAMETER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
C     VERSION NUMBER--2008/2
C     ORIGINAL VERSION--FEBRUARY  2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(P.LE.0.0D0 .OR. P.GT.1.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** ERROR--THE FIRST ARGUMENT TO LEXPPF IS ',
     1           'OUTSIDE THE ALLOWABLE [0,1] INTERVAL.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)P
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** ERROR--THE FIRST ARGUMENT TO LEXPPF IS ',
     1           'OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)P
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LEXPPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(P.LE.0.0D0)THEN
        PPF=0.0D0
      ELSE
        TERM1=P/(1.0D0 - P)
        PPF=DLOG(1.0D0 + TERM1**(1.0D0/BETA))
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LEXRAN(N,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOGISTIC-EXPONENTIAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOGISTIC-EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --BETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LEXPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.1
C     ORIGINAL VERSION--JANUARY   2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1       'LOGISTIC-EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER, BETA, FOR THE ',
     1       'LOGISTIC-EXPONENTIAL DISTRIBUTION')
   16 FORMAT('      IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOGISTIC-EXPONENTIAL DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LEXPPF(DBLE(X(I)),DBLE(BETA),DTEMP)
        X(I)=REAL(DTEMP)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3CDF(X,BETA,THETA,ALPHA,CDF)
C
C     NOTE--3-PARAMETER LOGISTIC-EXPONENTIAL CDF IS:
C
C           F(X;ALPHA,BETA,THETA) = 1 -
C           [1 + (EXP(ALPHA*THETA) - 1)**BETA]/
C           [1 + (EXP(ALPHA*(X+THETA) - 1)**BETA]
C           X > 0; ALPHA, BETA > 0, THETA >= 0
C
C           WITH ALPHA, BETA AND THETA DENOTING THE SHAPE
C           PARAMETERS.  NOTE THAT ALTHOUGH (1/ALPHA) IS A
C           SCALE PARAMETER FOR THE LOGISTIC-EXPONENTIAL, IT
C           IS NOT A SCALE PARAMETER FOR THE 3-PARAMETER
C           LOGISTIC-EXPONENTIAL IN THE SENSE THAT THE
C           RELATION
C
C           F(X;BETA,THETA,LOC,SCALE) = F((X-LOC)/SCALE;BETA,THETA,0,1)
C
C           DOES NOT HOLD.  THEREFORE, WE TREAT IT AS A SHAPE
C           PARAMETER IN DATAPLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3CDF IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3CDF IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LE3CDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(THETA.LT.0.0D0)THEN
        WRITE(ICOUT,401)
  401   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LE3CDF IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,501)
  501   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LE3CDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=1.0D0 + (DEXP(ALPHA*THETA) - 1.0D0)**BETA
      TERM2=1.0D0 + (DEXP(ALPHA*(X+THETA)) - 1.0D0)**BETA
      CDF=1.0D0 - (TERM1/TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3CHA(X,BETA,THETA,ALPHA,HAZ)
C
C     NOTE--3-PARAMETER LOGISTIC-EXPONENTIAL CUMULATIVE HAZARD IS:
C
C           H(X;ALPHA,BETA,THETA) =
C           -LOG{[1 + (EXP(ALPHA*THETA) - 1)**BETA]/
C           [1 + (EXP(ALPHA*(X+THETA) - 1)**BETA]}
C           X > 0; ALPHA, BETA > 0, THETA >= 0
C
C           WITH ALPHA, BETA AND THETA DENOTING THE SHAPE
C           PARAMETERS.  NOTE THAT ALTHOUGH (1/ALPHA) IS A
C           SCALE PARAMETER FOR THE LOGISTIC-EXPONENTIAL, IT
C           IS NOT A SCALE PARAMETER FOR THE 3-PARAMETER
C           LOGISTIC-EXPONENTIAL IN THE SENSE THAT THE
C           RELATION
C
C           H(X;BETA,THETA,LOC,SCALE) = H((X-LOC)/SCALE;BETA,THETA,0,1)
C
C           DOES NOT HOLD.  THEREFORE, WE TREAT IT AS A SHAPE
C           PARAMETER IN DATAPLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3CHAZ IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3CHAZ IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LE3CHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(THETA.LT.0.0D0)THEN
        WRITE(ICOUT,401)
  401   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LE3CHAZ IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,501)
  501   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LE3CHAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=1.0D0 + (DEXP(ALPHA*THETA) - 1.0D0)**BETA
      TERM2=1.0D0 + (DEXP(ALPHA*(X+THETA)) - 1.0D0)**BETA
      HAZ=-DLOG(TERM1/TERM2)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3HAZ(X,BETA,THETA,ALPHA,HAZ)
C
C     NOTE--3-PARAMETER LOGISTIC-EXPONENTIAL HAZARD IS:
C
C           h(X;ALPHA,BETA,THETA) =
C           ALHA*BETA*(EXP(ALPHA*(X+THETA) - 1)**(BETA-1)*
C           EXP(ALPHA*(X+THETA))/
C           [1 + (EXP(ALPHA*(X+THETA) - 1)**BETA]
C           X > 0; ALPHA, BETA > 0, THETA >= 0
C
C           WITH ALPHA, BETA AND THETA DENOTING THE SHAPE
C           PARAMETERS.  NOTE THAT ALTHOUGH (1/ALPHA) IS A
C           SCALE PARAMETER FOR THE LOGISTIC-EXPONENTIAL, IT
C           IS NOT A SCALE PARAMETER FOR THE 3-PARAMETER
C           LOGISTIC-EXPONENTIAL IN THE SENSE THAT THE
C           RELATION
C
C           h(X;BETA,THETA,LOC,SCALE) = h((X-LOC)/SCALE;BETA,THETA,0,1)/
C                                       SCALE
C
C           DOES NOT HOLD.  THEREFORE, WE TREAT IT AS A SHAPE
C           PARAMETER IN DATAPLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      HAZ=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3HAZ IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3HAZ IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LE3HAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(THETA.LT.0.0D0)THEN
        WRITE(ICOUT,401)
  401   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LE3HAZ IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,501)
  501   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LE3HAZ IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=DLOG(ALPHA) + DLOG(BETA)
      TERM2=(BETA - 1.0D0)*DLOG(EXP(ALPHA*(X+THETA)) - 1.0D0)
      TERM3=ALPHA*(X+THETA)
      TERM4=DLOG(1.0D0 + (EXP(ALPHA*(X+THETA)) - 1.0D0)**BETA)
      HAZ=DEXP(TERM1 + TERM2 + TERM3 - TERM4)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3PDF(X,BETA,THETA,ALPHA,PDF)
C
C     NOTE--LOGISTIC-EXPONENTIAL PDF IS:
C
C           f(X;ALPHA,BETA,THETA) =
C           ALPHA*BETA*(1 + EXP(ALPHA*THETA) - 1)**BETA*
C           (EXP(ALPHA*(X+THETA))-1)**(BETA-1)*
C           EXP(ALPHA*(X+THETA))/
C           {(1+(EXP(ALPHA*(X+THETA))-1)**BETA)**2}
C           X > 0; ALPHA, BETA > 0, THETA >= 0
C
C           WITH ALPHA, BETA AND THETA DENOTING THE SHAPE
C           PARAMETERS.  NOTE THAT ALTHOUGH (1/ALPHA) IS A
C           SCALE PARAMETER FOR THE LOGISTIC-EXPONENTIAL, IT
C           IS NOT A SCALE PARAMETER FOR THE 3-PARAMETER
C           LOGISTIC-EXPONENTIAL IN THE SENSE THAT THE
C           RELATION
C
C           f(X;BETA,THETA,LOC,SCALE) = F((X-LOC)/SCALE;BETA,THETA)/SCALE
C
C           DOES NOT HOLD.  THEREFORE, WE TREAT IT AS A SHAPE
C           PARAMETER IN DATAPLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3PDF IS ',
     1           'NON-POSITIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(X.LT.0.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** WARNING--THE FIRST ARGUMENT TO LE3PDF IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)X
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LE3PDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(THETA.LT.0.0D0)THEN
        WRITE(ICOUT,401)
  401   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LE3PDF IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,501)
  501   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LE3PDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      TERM1=DLOG(ALPHA) + DLOG(BETA)
      TERM2=DLOG(1.0D0 + (DEXP(ALPHA*THETA) - 1.0D0)**BETA)
      TERM3=(BETA-1.0D0)*DLOG(DEXP(ALPHA*(X+THETA)) - 1.0D0)
      TERM4=ALPHA*(X + THETA)
      ANUM=TERM1 + TERM2 + TERM3 + TERM4
C
      ADEN=2.0D0*DLOG(1.0D0 + (DEXP(ALPHA*(X+THETA)) - 1.0D0)**BETA)
      PDF=DEXP(ANUM - ADEN)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3PPF(P,BETA,THETA,ALPHA,PPF)
C
C     NOTE--LOGISTIC-EXPONENTIAL PPF IS:
C
C           G(P;BETA,THETA) =
C           LOG[1 + {((EXP(THETA)-1)**BETA + P)/(1-P)}**(1/BETA)]
C           - THETA
C           0 <= P < 1; BETA > 0, THETA >= 0
C
C           WITH ALPHA, BETA AND THETA DENOTING THE SHAPE
C           PARAMETERS.  NOTE THAT ALTHOUGH (1/ALPHA) IS A
C           SCALE PARAMETER FOR THE LOGISTIC-EXPONENTIAL, IT
C           IS NOT A SCALE PARAMETER FOR THE 3-PARAMETER
C           LOGISTIC-EXPONENTIAL IN THE SENSE THAT THE
C           RELATION
C
C           G(P;BETA,THETA,LOC,SCALE) = LOC + SCALE*F(P;BETA,THETA,0,1)
C
C           DOES NOT HOLD.  THEREFORE, WE TREAT IT AS A SHAPE
C           PARAMETER IN DATAPLOT.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
C     VERSION NUMBER--2008/3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0D0
C
      IF(BETA.LT.1.0D0)THEN
        IF(P.LE.0.0D0 .OR. P.GT.1.0D0)THEN
          WRITE(ICOUT,106)
  106     FORMAT('***** ERROR--THE FIRST ARGUMENT TO LE3PPF IS ',
     1           'OUTSIDE THE ALLOWABLE [0,1] INTERVAL.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)P
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ELSE
        IF(P.LT.0.0D0 .OR. P.GT.1.0D0)THEN
          WRITE(ICOUT,101)
  101     FORMAT('***** ERROR--THE FIRST ARGUMENT TO LE3PPF IS ',
     1           'OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,102)P
  102     FORMAT('      THE VALUE OF THE ARGUMENT IS ',G15.7)
          CALL DPWRST('XXX','BUG ')
          GOTO9000
        ENDIF
      ENDIF
C
      IF(BETA.LE.0.0D0)THEN
        WRITE(ICOUT,301)
  301   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LE3PPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(THETA.LT.0.0D0)THEN
        WRITE(ICOUT,401)
  401   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LE3PPF IS ',
     1         'NEGATIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(ALPHA.LE.0.0D0)THEN
        WRITE(ICOUT,501)
  501   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LE3PPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,102)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
      IF(P.LE.0.0D0)THEN
        PPF=0.0D0
      ELSE
        ANUM=(DEXP(ALPHA*THETA) - 1.0D0)**BETA + P
        ADEN=1.0D0 - P
        PPF=(1.0D0/ALPHA)*DLOG(1.0D0 + (ANUM/ADEN)**(1.0D0/BETA))
     1      - THETA
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LE3RAN(N,BETA,THETA,ALPHA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE 3-PARAMETER LOGISTIC-EXPONENTIAL DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = BETA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --BETA   = THE SINGLE PRECISION VALUE OF THE
C                                FIRST SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE OF THE
C                                SECOND SHAPE PARAMETER.
C                     --ALPHA  = THE SINGLE PRECISION VALUE OF THE
C                                THIRD SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE 3-PARAMETER LOGISTIC-EXPONENTIAL DISTRIBUTION
C             WITH SHAPE PARAMETER VALUES = BETA, THETA AND ALPHA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --BETA > 0; THETA >= 0.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LE3PPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCE--LEEMIS AND MCQUESTION (2008), "UNIVARIATE DISTRIBUTION
C                RELATIONSHIPS", THE AMERICAN STATISTICIAN, VOL. 62,
C                NO. 1, PP. 45-53.
C              --LAN AND LEEMIS (2007), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", TECHNICAL REPORT, THE
C                COLLEGE OF WILLIAM AND MARY, DEPARTMENT OF
C                MATHEMATICS.
C              --LAN AND LEEMIS (2008), "THE LOGISTIC-EXPONENTIAL
C                SURVIVAL DISTRIBUTION", NAVAL RESEARCH LOGISTICS,
C                VOL. xx, NO. xx, PP. xx.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2008.3
C     ORIGINAL VERSION--MARCH     2008.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DTEMP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,16)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(THETA.LT.0.0)THEN
        WRITE(ICOUT,25)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,26)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(ALPHA.LE.0.0)THEN
        WRITE(ICOUT,35)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,36)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)ALPHA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1       '3-PARAMETER LOGISTIC-EXPONENTIAL ')
    6 FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER, BETA, FOR THE ',
     1       '3-PARAMETER LOGISTIC-EXPONENTIAL DISTRIBUTION')
   16 FORMAT('      IS NON-POSITIVE.')
   25 FORMAT('***** ERROR--THE LOCATION PARAMETER, THETA, FOR ',
     1       'THE 3-PARAMETER LOGISTIC-EXPONENTIAL')
   26 FORMAT('      DISTRIBUTION IS NON-POSITIVE.')
   35 FORMAT('***** ERROR--THE SCALE PARAMETER, ALPHA, FOR ',
     1       'THE 3-PARAMETER LOGISTIC-EXPONENTIAL')
   36 FORMAT('      DISTRIBUTION IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N 3-PARAMETER LOGISTIC-EXPONENTIAL DISTRIBUTION
C     RANDOM NUMBERS USING THE PERCENT POINT FUNCTION
C     TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LE3PPF(DBLE(X(I)),DBLE(BETA),DBLE(THETA),
     1              DBLE(ALPHA),DTEMP)
        X(I)=REAL(DTEMP)
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LG1FUN (NPAR, XPAR, FVEC, IFLAG, XDATA, R)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LOGNORMAL MAXIMUM LIKELIHOOD EQUATIONS FOR THE
C              SINGLY TIME CENSORED CASE (FROM PP. 161-162 OF BURY).
C
C      SUM[i=1 to r][Z(I)] + M*H(Z(I)) = 0
C
C      SUM[i=1 to r][Z(I)**2] + M*Z*H(Z) - R = 0
C
C      WHERE
C
C
C         R        = NUMBER OF FAILURES
C         M        = NUMBER OF CENSORING TIMES
C         C        = CENSORING TIME (ALL CENSORED DATA WILL HAVE
C                    THE SAME CENSORING TIME)
C         Z(I)     = [LOG(X(I) - UHAT]/SHAT
C         UHAT     = FVEC(1) = CURRENT ESTIMATE OF MU PARAMETER
C         SHAT     = FVEC(2) = CURRENT ESTIMATE OF SIGMA PARAMETER
C         Z        = [LOG(C) - UHAT]/SHAT
C         H(Z)     = NORPDF(Z)/(1 - NOCDF(Z))
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, (1999). "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                PP. 161-162.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER  2004.
C
C---------------------------------------------------------------------
C
      INTEGER R
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DH
      DOUBLE PRECISION DX
      DOUBLE PRECISION UHAT
      DOUBLE PRECISION SHAT
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      DOUBLE PRECISION C
      INTEGER N
      INTEGER M
      COMMON/LG1COM/C,N,M
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      NPAR=2
      IFLAG=0
C
      DN=DBLE(N)
      DR=DBLE(R)
      DM=DBLE(M)
      UHAT=XPAR(1)
      SHAT=XPAR(2)
      DZ=(DLOG(C)-UHAT)/SHAT
      CALL NODPDF(DZ,DTERM1)
      CALL NODCDF(DZ,DTERM2)
      DH=DTERM1/(1.0D0 - DTERM2)
C
      DTERM1=DM*DH
      DTERM2=DTERM1*DZ - DR
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      IF(R.GT.0)THEN
        DO100I=1,R
          DX=DBLE(XDATA(I))
          DX=(DLOG(DX) - UHAT)/SHAT
          DSUM1=DSUM1 + DX
          DSUM2=DSUM2 + DX*DX
  100   CONTINUE
      ENDIF
C
      FVEC(1) = DTERM1 + DSUM1
      FVEC(2) = DTERM2 + DSUM2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG2FUN (DU,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE)
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(U,S(U)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT GUESS FOR U, WE NEED TO
C              SOLVE THE FOLLOWING EQUATION FOR S:
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] +
C                 M*(LOG(C)-U)/S)*H(Z) - R
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U)
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DU
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSIGMA
      COMMON/LG2COM/DLLUS,DC,DK,DSIGMA,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DU2
      DOUBLE PRECISION DC2
      COMMON/LG3COM/DU2,DC2,N2,IR2,IM2
C
      DOUBLE PRECISION LG3FUN
      EXTERNAL LG3FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE
C          THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).

      N2=N
      IR2=IR
      IM2=IM
      DC2=DC
      DU2=DU
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DSIGMA
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(LG3FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DS=XLOW
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DZ=(DLOG(DC) - DU)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG2FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG3FUN (DS,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE)
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  IT IS CALLED BY
C              LG2FUN TO SOLVE THE EQUATION
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] +
C                 M*(LOG(C)-U)/S)*H(Z) - R
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DS
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DU
      DOUBLE PRECISION DC
      COMMON/LG3COM/DU,DC,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC)-DU)/DS
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DX(I)
        DZ=(DLOG(DZ) - DU)/DS
        DSUM1=DSUM1 + DZ*DZ
  100 CONTINUE
C
      LG3FUN=DSUM1 + DM*DTERM1*DTERM2/(1.0D0-DTERM3) - DR
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG4FUN (DSIGMA,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SIGMA
C              PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(G(S),S) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT GUESS FOR SIGMA, WE NEED TO
C              SOLVE THE FOLLOWING EQUATION FOR U:
C
C                 SUM[i=1 to r][(LOG(X(I)-U)/S] + M*H(Z)
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE G(S) AND S
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DU
      COMMON/LG4COM/DLLUS,DC,DK,DU,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION DC2
      COMMON/LG5COM/DS2,DC2,N2,IR2,IM2
C
      DOUBLE PRECISION LG5FUN
      EXTERNAL LG5FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF SHAPE PARAMETER (DSIGMA), NEED TO COMPUTE
C          THE SCALE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).

      N2=N
      IR2=IR
      IM2=IM
      DC2=DC
      DS2=DSIGMA
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DU
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(LG5FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DU=XLOW
      DS=DSIGMA
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DZ=(DLOG(DC) - DU)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG4FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG5FUN (DU,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE SHAPE PARAMETER,
C              SIGMA, OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  IT IS CALLED BY
C              LG4FUN TO SOLVE THE EQUATION
C
C                 SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] + M*H(Z)
C
C              WITH
C
C                 Z    = (LOG(X(I))-U)/S
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DU
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DS
      DOUBLE PRECISION DC
      COMMON/LG5COM/DS,DC,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC)-DU)/DS
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DX(I)
        DZ=(DLOG(DZ) - DU)/DS
        DSUM1=DSUM1 + DZ
  100 CONTINUE
C
      LG5FUN=DSUM1 + DM*DTERM2/(1.0D0-DTERM3)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG6FUN (DXQ,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR A GIVEN PERCENTILE
C              OF A 2-PARAMETER LOGNORMAL MODEL
C              (SINGLY TIME CENSORED SAMPLE).  THE FOLLOWING
C              EQUATION NEEDS TO BE SOLVED.
C
C                 2*LL(UHAT,SHAT) - 2*LL(g(xq),s(xq)) - CHSPPF(alpha,1)
C
C              WITH
C
C                 LL(UHAT,SHAT) = -R*LOG(SHAT) -
C                                 SUM[i=1 tp r][LOG(X(I))] -
C                                 0.5*SUM[i=1 to r]
C                                 [((LOG(X(I)) - UHAT)/SHAT)**2] +
C                                 DM*LOG(1 - NORCDF(
C
C              LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE
C              AND PASSED VIA COMMON BLOCK.
C
C              THEN GIVEN THE CURRENT MAXIMUM LIKELIHOOD ESTIMATE OF
C              SIGMA, WE NEED TO SOLVE THE FOLLOWING EQUATION FOR
C              XQ:
C
C
C                 (1/B**2)*SUM[i=1 to r]
C                 [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) +
C                 (M/B)*(LOG(C)/X05)*H(Z) - R
C
C              WITH
C
C                 Z05  = NORPPF(1 - ALPHA/2)
C                 X05  = LGNPPF(P) (P IS THE DESIRED PERCENTILE)
C                 Z    = LOG(C/XQ)/B + Z05
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD
C              ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ.
C              WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U)
C              VALUES.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DXQ
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DLLUS
      DOUBLE PRECISION DC
      DOUBLE PRECISION DK
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DU
      DOUBLE PRECISION DX05
      DOUBLE PRECISION DZ05
      DOUBLE PRECISION SEXQP
      COMMON/LG6COM/DLLUS,DC,DK,DSIGMA,DU,DX05,DZ05,SEXQP,N,IR,IM
C
      INTEGER N2
      INTEGER IR2
      INTEGER IM2
      DOUBLE PRECISION DX052
      DOUBLE PRECISION DZ052
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      COMMON/LG7COM/DX052,DZ052,DC2,DS2,N2,IR2,IM2
C
      DOUBLE PRECISION LG7FUN
      EXTERNAL LG7FUN
C
      DOUBLE PRECISION AE
      DOUBLE PRECISION RE
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION XSTRT
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU2
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE
C          THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A
C          ROOT).
C
      DX052=DX05
      DZ052=DZ05
      DC2=DC
      DS2=DSIGMA
      N2=N
      IR2=IR
      IM2=IM
C
      AE=1.D-7
      RE=1.D-7
      XSTRT=DXQ
      XLOW=XSTRT/5.0D0
      XUP=XSTRT*5.0D0
      CALL DFZER3(LG7FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX)
      DSXQ=XLOW
C
C  COMPUTE LL(S,G)
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DU2=DLOG(DXQ) - DZ05*DSXQ
      DS=DSXQ
      DZ=(DLOG(DC) - DU2)/DS
      CALL NODCDF(DZ,DTERM2)
      DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I))
        DSUM1=DSUM1 + DZ
        DSUM2=DSUM2 + ((DZ - DU2)/DS)**2
  100 CONTINUE
      DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2
C
      LG6FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LG7FUN (DXQ,DX)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO
C              BASED CONFIDENCE INTERVAL FOR THE PERCENTILE FUNCTION
C              OF A 2-PARAMETER LOGNORMAL MODEL (SINGLY TIME CENSORED
C              SAMPLE).  IT IS CALLED BY LG6FUN TO SOLVE THE EQUATION
C
C                 (1/B**2)*SUM[i=1 to r]
C                 [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) +
C                 (M/B)*(LOG(C)/X05)*H(Z) - R
C
C              WITH
C
C                 Z05  = NORPPF(1 - ALPHA/2)
C                 X05  = LGNPPF(P) (P IS THE DESIRED PERCENTILE)
C                 Z    = LOG(C/XQ)/B + Z05
C                 HZ   = NORPDF(Z)/(1-NORCDF(Z))
C
C              WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD
C              ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ.
C
C              THE VALUES OF Z05 AND X05 ARE CALCULATED IN DPMLL2
C              AND STORED IN A COMMON BLOCK.
C
C     EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE
C                EXAMPLE 11.5).
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/11
C     ORIGINAL VERSION--NOVEMBER   2004.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DXQ
      DOUBLE PRECISION DX(*)
C
      INTEGER N
      INTEGER IR
      INTEGER IM
      DOUBLE PRECISION DX05
      DOUBLE PRECISION DZ05
      DOUBLE PRECISION DC
      DOUBLE PRECISION DS
      COMMON/LG7COM/DX05,DZ05,DC,DS,N,IR,IM
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
C
      DTERM1=(DLOG(DC/DXQ)/DS) + DZ05
      CALL NODPDF(DTERM1,DTERM2)
      CALL NODCDF(DTERM1,DTERM3)
C
      DSUM1=0.0D0
      DO100I=1,IR
        DZ=DLOG(DX(I)/DXQ)
        DSUM1=DSUM1 + (DZ + DS*DZ05)*DZ
  100 CONTINUE
C
      LG7FUN=(1.0D0/DS**2)*DSUM1 +
     1       (DM/DS)*DLOG(DC/DXQ)*DTERM2/(1.0D0-DTERM3) - DR
C
      RETURN
      END
      SUBROUTINE LGACDF(X,GAMMA,ILGADF,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER GAMMA
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,G) = EXP(G*X-EXP(X))/GAMMA(G)
C              WHERE GAMMA IS THE GAMMA FUNCTION.
C              THE CORRESPONDING CDF IS:
C                  F(X,G) = I(EXP(Y)(GAMMA)
C              WHERE I(X)(GAMMA) IS THE INCOMPLETE GAMMA FUNCTION RATIO
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE A POSITIVE NUMBER.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 89-90.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ILGADF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DGAMIP
      DOUBLE PRECISION DTERM1
C
      EXTERNAL DGAMIP
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGACDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
      IF(ILGADF.EQ.'DEFA')THEN
        DCDF=DGAMIP(DGAMMA,DEXP(DX))
      ELSE
        DTERM1=DGAMMA*DEXP(DX/DSQRT(DGAMMA))
        DCDF=DGAMIP(DGAMMA,DTERM1)
      ENDIF
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGAPDF(X,GAMMA,ILGADF,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION
C              WITH POSITIVE SHAPE PARAMETER GAMMA
C              THIS DISTRIBUTION IS DEFINED FOR ALL REAL X.
C              THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS
C                  F(X,G) = EXP(G*X-EXP(X))/GAMMA(G)
C              WHERE GAMMA IS THE GAMMA FUNCTION.
C
C              FOR FITTING PURPOSES, THE FOLLOWING REPARAMETERIZED
C              PDF IS OFTEN PREFERRED:
C                  F(X,G) = (G**(G-0.5)/GAMMA(G)*
C                           EXP(SQRT(G)*X-G*EXP(X/SQRT(G)))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --GAMMA  = A POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG GAMMA DISTRIBUTION
C             WITH SHAPE PARAMETER GAMMA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE NON-NEGATIVE.
C                 --GAMMA SHOULD BE A POSITIVE NUMBER.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1994, PAGE 89-90.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C                                       FITTING
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ILGADF
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DGAMMA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGAPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
      DX=DBLE(X)
      DGAMMA=DBLE(GAMMA)
C
      IF(ILGADF.EQ.'DEFA')THEN
        DTERM1=DGAMMA*DX - DEXP(DX)
        DTERM2=DTERM1-DLNGAM(DGAMMA)
        DPDF=0.0D0
        IF(DTERM2.GE.-80.0D0)DPDF=DEXP(DTERM2)
        PDF=REAL(DPDF)
      ELSE
        DTERM1=(DGAMMA - 0.5D0)*DLOG(DGAMMA) - DLNGAM(DGAMMA)
        DTERM2=DSQRT(DGAMMA)*DX - DGAMMA*DEXP(DX/DSQRT(DGAMMA))
        DTERM3=DTERM1 + DTERM2
        DPDF=0.0D0
        IF(DTERM3.GE.-80.0D0)DPDF=DEXP(DTERM3)
        PDF=REAL(DPDF)
      ENDIF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGAPPF(P,GAMMA,ILGADF,PPF)
C
C     PURPOSE   --PERCENT POINT FUNCTION FOR THE LOG-GAMMA
C                 DISTRIBUTION.  USES A BISECTION METHOD.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--95/10
C     ORIGINAL VERSION--OCTOBER   1995.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ILGADF
C
      INCLUDE 'DPCOP2.INC'
C
      DATA EPS /0.0001/
      DATA SIG /1.0E-5/
      DATA ZERO /0./
      DATA MAXIT /2000/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
      IF(GAMMA.LE.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ',
     1' LGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1'LGAPPF SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C
C  FIND BRACKETING INTERVAL.
C
      XL=-50.0
      XINC=25.0
      ICOUNT=0
      MAXCNT=10000
C
   91 CONTINUE
      XR=XL+XINC
      CALL LGACDF(XL,GAMMA,ILGADF,CDFL)
      CALL LGACDF(XR,GAMMA,ILGADF,CDFR)
      IF(CDFL.LT.P .AND. CDFR.LT.P)THEN
        XL=XR
      ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN
        XL=XL-XINC
      ELSE
        GOTO99
      ENDIF
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.MAXCNT)THEN
        WRITE(ICOUT,96)
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   96 FORMAT('***** ERROR--LGAPPF UNABLE TO FIND A BRACKETING ',
     *      'INTERVAL. *****')
      GOTO91
C
C  BISECTION METHOD
C
   99 CONTINUE
      IC = 0
      FXL = -P
      FXR = 1.0 - P
  105 CONTINUE
      X = (XL+XR)*0.5
      CALL LGACDF(X,GAMMA,ILGADF,CDF)
      P1=CDF
      PPF=X
      FCS = P1 - P
      IF(FCS*FXL.GT.ZERO)GOTO110
      XR = X
      FXR = FCS
      GOTO115
  110 CONTINUE
      XL = X
      FXL = FCS
  115 CONTINUE
      XRML = XR - XL
      IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999
      IC = IC + 1
      IF(IC.LE.MAXIT)GOTO105
      WRITE(ICOUT,130)
      CALL DPWRST('XXX','BUG ')
  130 FORMAT('***** ERROR--THE LGAPPF ROUTINE DID NOT CONVERGE. ***')
      GOTO9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LGARAN(N,GAMMA,ILGADF,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG GAMMA DISTRIBUTION
C              WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --GAMMA  = THE SINGLE PRECISION VALUE OF THE
C                                TAIL LENGTH PARAMETER.
C                                GAMMA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG GAMMA DISTRIBUTION
C             WITH TAIL LENGTH PARAMETER VALUE = GAMMA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --GAMMA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 2ND. ED., 1994.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C     UPDATED         --JULY      2005. SUPPORT FOR RE-PARAMETERIZED
C                                       DEFINITION THAT IS USEFUL FOR
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
      CHARACTER*4 ILGADF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(GAMMA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)GAMMA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG GAMMA RANDOM',
     1' NUMBERS IS NON-POSITIVE.')
   15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR LOG GAMMA RANDOM',
     1' NUMBERS IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,'.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOG GAMMA DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LGAPPF(X(I),GAMMA,ILGADF,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGDCDF(DX,DSD,DCDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOGNORMAL DISTRIBUTION.
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE CUMULATIVE DISTRIBUTION FUNCTION IS
C                                TO BE EVALUATED (DX > 0).
C                    --DSD    = THE DOUBLE PRECISION VALUE FOR THE
C                               SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DCDF  = THE DOUBLE PRECISION CUMULATIVE
C                               DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION VALUE
C             DCDF FOR THE LOGNORMAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--DX SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MARCH     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DARG
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DCDF=0.0
      IF(DX.LE.0.0D0)THEN
        GOTO9000
      ELSEIF(DSD.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DSD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LGNCDF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(DSD.EQ.1.0D0)THEN
        DARG=DLOG(DX)
        CALL NODCDF(DARG,DCDF)
      ELSE
        DARG=DLOG(DX)/DSD
        CALL NODCDF(DARG,DCDF)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNLI1(Y,N,ALOC,SCALE,SHAPE,
     1                  ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE LOGNORMAL DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING",
C                CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11.
C     WRITTEN BY--ALAN HECKERT
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--2014/3
C     ORIGINAL VERSION--MARCH     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DPDF
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNL'
      ISUBN2='I1  '
      IWRITE='OFF'
      IERROR='NO'
C
      ALIK=CPUMIN
      AIC=CPUMIN
      AICC=CPUMIN
      BIC=CPUMIN
C
      IF(ALOC.EQ.CPUMIN)THEN
        ALOCT=0.0
      ELSE
        ALOCT=ALOC
      ENDIF
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE,SHAPE
   55   FORMAT('N,ALOC,SCALE,SHAPE = ',I8,3G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I)
   57     FORMAT('I,Y(I) = ',I8,G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
      DO110I=1,N
        IF(Y(I).LE.ALOC)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,111)
  111     FORMAT('**** AT THE BEGINNING OF LGNLI1--')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,113)I,Y(I),ALOC
  113     FORMAT('     THE VALUE FOR ROW ',I8,'(',G15.7,') IS LESS ',
     1           'THAN THE LOCATION (',G15.7,')')
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
  110 CONTINUE
C
C               ******************************************
C               **  STEP 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DLIK=0.0D0
      DLOC=DBLE(ALOC)
      DSCALE=DBLE(SCALE)
      DSHAPE=DBLE(SHAPE)
      DN=DBLE(N)
C
      DO1020I=1,N
        DX=DBLE(Y(I))
        DX=(DX-DLOC)/DSCALE
        CALL LGDPDF(DX,DBLE(SHAPE),DPDF)
        DPDF=DPDF/DSCALE
        IF(DPDF.GT.0.0D0)THEN
          DLIK=DLIK + DLOG(DPDF)
        ELSE
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1023)I
 1023     FORMAT('     FOR ROW ',I8,' A NON-POSITIVE PDF VALUE ',
     1           'WAS ENCOUNTERED.')
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,1025)Y(I),DLOC
 1025     FORMAT('     Y(I),LOCATION VALUE = ',2G15.7)
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
 1020 CONTINUE
C
      ALIK=REAL(DLIK)
      DNP=2.0D0
      EPS=1.0E-7
      IF(ABS(ALOCT).GT.EPS)DNP=3.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGDPDF(DX,DSD,DPDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOGNORMAL DISTRIBUTION
C              (DOUBLE PRECISION VERSION).
C     INPUT  ARGUMENTS--DX     = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE PROBABILITY DENSITY FUNCTION IS
C                                TO BE EVALUATED (DX > 0).
C                    --DSD    = THE DOUBLE PRECISION VALUE FOR THE
C                               SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF  = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION VALUE
C             DPDF FOR THE LOGNORMAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--DX SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--MARCH     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DARG
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPDF=0.0D0
      IF(DX.LT.0.0D0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DX
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DSD.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DSD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LGNPDF IS NEGATIVE.')
    5 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LGNPDF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(DX.GT.0.0D0)THEN
        IF(DSD.EQ.1.0D0)THEN
          DARG=DLOG(DX)
          CALL NODPDF(DARG,DPDF)
          DPDF=(1.0D0/DX)*DPDF
        ELSE
          DARG=DLOG(DX)/DSD
          CALL NODPDF(DARG,DPDF)
          DPDF=(1.0D0/(DSD*DX))*DPDF
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGDPPF(DP,DSD,DPPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT FUNCTION FOR
C              FOR THE LOGNORMAL DISTRIBUTION.
C     INPUT  ARGUMENTS--DP     = THE DOUBLE PRECISION VALUE AT WHICH
C                                THE PERCENT POINT FUNCTION IS
C                                TO BE EVALUATED (0 <= DP < 1).
C                    --DSD    = THE DOUBLE PRECISION VALUE FOR THE
C                               SHAPE PARAMETER
C     OUTPUT ARGUMENTS--DPDF  = THE DOUBLE PRECISION PERCENT POINT
C                               FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION VALUE
C             DPPF FOR THE LOGNORMAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--MARCH     2014.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DP
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DPPF
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      DPPF=0.0D0
      IF(DP.LT.0.0D0 .OR. DP.GE.1.0D0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DP
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(DSD.LE.0.0D0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DSD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LGNPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL.')
    5 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LGNPDF IS ',
     1       'NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(DP.GT.0.0D0)THEN
        IF(DSD.EQ.1.0D0)THEN
          CALL NODPPF(DP,DPPF)
          DPPF=DEXP(DPPF)
        ELSE
          CALL NODPPF(DP,DPPF)
          DPPF=DEXP(DPPF*DSD)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNAFR(X1,X2,SIGMA,ALOC,SCALE,AFR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE AVERAGE FAILURE RATE
C              (AFR) FUNCTION VALUE FOR THE LOGNORMAL DISTRIBUTION.
C              THE AFR IS DEFINED AS:
C
C              AFR(X1,X2,SHAPE,LOC,SCALE) = (H(X2,SHAPE,LOC,SCALE) -
C                                            H(X1,LOC,SCALE))/(X2-X1)
C
C              WHERE
C
C              H(X,SHAPE,LOC,SCALE) = H((X-LOC)/SCALE,SHAPE)
C
C              FOR THE LOGNORMAL, WE USE THE LGNCHA FUNCTION.
C
C     INPUT  ARGUMENTS--X1     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C                     --X2     = THE SINGLE PRECISION VALUE AT
C                                WHICH THE AFR FUNCTION IS TO BE
C                                EVALUATED.
C                     --SIGMA  = THE (POSITIVE) SHAPE PARAMETER
C                     --ALOC   = THE LOCATION PARAMETER
C                     --SCALE  = THE (POSITIVE) SCALE PARAMETER
C     OUTPUT ARGUMENTS--AFR    = THE SINGLE PRECISION AVERAGE
C                                FAILURE RATE FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION AVERAGE FAILURE RATE FOR THE
C             LOGNORMAL DISTRIBUTION.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--SIGMA AND SCALE SHOULD BE POSITIVE, X2 NOT EQUAL X1.
C     OTHER DATAPAC   SUBROUTINES NEEDED--LGNCHA.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOBIAS AND TRINDALE, "APPLIED RELIABILITY", SECOND
C                 EDITION, CHAPMAN AND HALL/CRC, 1995.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2005.3
C     ORIGINAL VERSION--MARCH     2005.
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      X1MN=MIN(X1,X2)
      X1MX=MAX(X1,X2)
      IF(X1MN.EQ.X1MX)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)X1MN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)X1MX
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(X1MN.LT.ALOC)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X1MN
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)ALOC
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(SIGMA.LE.0.0)THEN
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SIGMA
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ELSEIF(SCALE.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)SCALE
        CALL DPWRST('XXX','BUG ')
        AFR=0.0
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO LGNAFR ',
     1       'IS LESS THAN THE LOCATION')
    5 FORMAT('***** ERROR--THE FIRST AND SECOND INPUT ARGUMENTS TO ',
     1       'LGNAFR ARE EQUAL')
    6 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO LGNAFR ',
     1       '(THE SCALE) IS NON-POSITIVE')
    8 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO LGNAFR ',
     1       '(THE SHAPE) IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',G15.7)
   48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',G15.7)
   49 FORMAT('***** THE VALUE OF THE LOCATION PARAMETER IS ',G15.7)
C
      IF(X1MN.LT.ALOC)THEN
         AFR=0.0
      ELSE IF(X1MN.EQ.ALOC)THEN
         TERM1=(X1MX-ALOC)/SCALE
         CALL LGNCHA(TERM1,SIGMA,CHAZ1)
         AFR=CHAZ1/(X1MX - X1MN)
      ELSE
         TERM1=(X1MX-ALOC)/SCALE
         CALL LGNCHA(TERM1,SIGMA,CHAZ1)
         TERM2=(X1MN-ALOC)/SCALE
         CALL LGNCHA(TERM2,SIGMA,CHAZ2)
         AFR=(CHAZ1 - CHAZ2)/(X1MX - X1MN)
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNCDF(X,SD,CDF)
CCCCC SUBROUTINE LGNCDF(X,CDF)
CCCCC APRIL 1995.  SUPPORT SHAPE PARAMETER
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORCDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C     UPDATED         --JANUARY   1995. DEFINE X = 0 CASE AS 0
C     UPDATED         --APRIL     1995. SHAPE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      CDF=0.0
      IF(X.LT.0.0)THEN
CCCCC   WRITE(ICOUT,4)
CCCC4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO LGNCDF IS NEGATIVE.')
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.0.0)THEN
        IF(SD.EQ.1.0)THEN
          ARG=LOG(X)
          CALL NORCDF(ARG,CDF)
        ELSE
          ARG=LOG(X)/SD
          CALL NORCDF(ARG,CDF)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNCHA(X,SD,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DHAZ
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO LGNCHA IS NEGATIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.0.0)THEN
        DX=DBLE(X)
        DSD=DBLE(SD)
        CALL NODCDF(DLOG(DX)/DSD,DCDF)
        DCDF=1.0D0-DCDF
        IF(DCDF.GT.0.0D0)THEN
          DHAZ=-DLOG(DCDF)
          HAZ=REAL(DHAZ)
        ELSE
          HAZ=0.0
          WRITE(ICOUT,901)X
  901     FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ',
     1           'VALUE IS ESSENTIALLY 1.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION LGNFU3 (DLOCML,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE MAXIMUM LIKELIHOOD
C              ESTIMATE OF THE LOCATION PARAMETER FOR THE 3-PARAMETER
C              LOGNORMAL MODEL FOR FULL SAMPLE DATA (NO CENSORING).  THIS
C              FUNCTION FINDS THE ROOT OF THE EQUATION:
C
C                 SUM[1/(X(i) - LOC)]*{SUM[LOG(X(i) - LOC] -
C                 SUM[LOG((X(i) - LOC)**2] +
C                 (1/N)*{SUM[LOG(X(i)) - LOC)]**2] -
C                 N*SUM[LOG(X(i) - LOC)/(X(i) - LOC)] = 0
C
C              WHERE ALL SUMMATIONS ARE FROM 1 TO N AND WITH LOC
C              DENOTING THE ESTIMATE OF THE LOCATION PARAMETER.
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--3-PARAMETER LOGNORMAL MAXIMUM LIKELIHOOD Y
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 4.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2014/04
C     ORIGINAL VERSION--APRIL      2014.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DLOCML
      DOUBLE PRECISION X(*)
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DSUM4
      DOUBLE PRECISION DS11
      DOUBLE PRECISION DS22
      DOUBLE PRECISION DX
      DOUBLE PRECISION DL
      DOUBLE PRECISION DN
C
      INTEGER IN
      COMMON/LGNMLE/IN
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DSUM4=0.0D0
      DN=DBLE(IN)
C
      DO100I=1,IN
        DX=X(I) - DLOCML
        DL=DLOG(DX)
        DSUM1=DSUM1 + DL
        DSUM2=DSUM2 + DL**2
        DSUM3=DSUM3 + (1.0D0/DX)
        DSUM4=DSUM4 + DL/DX
  100 CONTINUE
C
      DS11=DSUM1/DN
      DS22=(DSUM2/DN) - DS11**2
      LGNFU3=DSUM3*(DS11-DS22) - DSUM4
C
      RETURN
      END
      SUBROUTINE LGNHAZ(X,SD,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LOGNORMAL
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE PDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DXLOG
      DOUBLE PRECISION DHAZ
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DTERM4
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      HAZ=0.0
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO LGNHAZ IS NEGATIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.0.0)THEN
        DX=DBLE(X)
        DXLOG=DLOG(DX)
        DTERM1=-DXLOG/DBLE(SD)
        CALL NODCDF(DTERM1,DTERM2)
        IF(DTERM2.NE.0.0D0)THEN
          DTERM3=DXLOG/DBLE(SD)
          CALL NODPDF(DTERM3,DTERM4)
          DHAZ=1.D0/(DX*DBLE(SD))*DTERM4/DTERM2
          HAZ=REAL(DHAZ)
        ELSE
          HAZ=0.0
          WRITE(ICOUT,901)X
  901     FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ',
     1           'VALUE IS ESSENTIALLY 1.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNML1(Y,N,MAXNXT,
     1                  TEMP1,
     1                  XMEAN,XMED,XSD,XVAR,XMIN,XMAX,XMEANL,XSDL,
     1                  SCALML,SCALSE,SHAPML,SHAPSE,UHATML,UHATSE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER LOGNORMAL DISTRIBUTION FOR THE RAW DATA
C              CASE (I.E., NO CENSORING AND NO GROUPING).  THIS ROUTINE
C              RETURNS ONLY THE POINT ESTIMATES (CONFIDENCE INTERVALS
C              WILL BE COMPUTED IN A SEPARATE ROUTINE).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLL1 WILL GENERATE THE OUTPUT
C              FOR THE LOGNORMAL MLE COMMAND).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --"STATISTICAL DISTRIBUTIONS", THIRD EDITION,
C                EVANS, HASTINGS, AND PEACOCK, WILEY, 2001.
C              --"METHODS FOR STATISTICAL ANALYSIS OF RELIABILITY
C                AND LIFE DATA", MANN, SCHAFER, AND SINGPURWALLA,
C                WILEY, 1974, PP. 264-268.
C     WRITTEN BY--ALAN HECKERT
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--2010/2
C     ORIGINAL VERSION--FEBRUARY  2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLE1)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TEMP1(*)
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='L1  '
      IERROR='NO'
      IWRITE='OFF'
C
      AN=REAL(N)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR LOGNORMAL MLE ESTIMATE          **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='LOGNORMAL'
C
      IFLAG=2
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,XMED,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      SHAPML=CPUMIN
      SHAPSE=CPUMIN
      SCALML=CPUMIN
      SCALSE=CPUMIN
      UHATML=CPUMIN
      UHATSE=CPUMIN
C
C     THE MAXIMUM LIKELIHOOD ESTIMATES ARE:
C
C     NOTE THAT A COMMON PARAMETERIZATION USES
C
C         U = LOG(SCALE)
C
C     UHAT      = (1/N)*SUM[i=1 to N][LOG(Y(I))]
C     SCALEHAT  = EXP(UHAT)
C     SIGMAHAT  = SQRT((1/N)*SUM[i=1 to N][(LOG(Y(I)) - UHAT)**2]
C
C     COMPUTE SOME SAMPLE STATISTICS ON LOG OF DATA
C
      DO4103I=1,N
        TEMP1(I)=LOG(Y(I))
 4103 CONTINUE
C
      CALL MEAN(TEMP1,N,IWRITE,XMEANL,IBUGA3,IERROR)
      CALL SD(TEMP1,N,IWRITE,XSDL,IBUGA3,IERROR)
C
C     COMPUTE MLE ESTIMATES
C
      UHATML=XMEANL
      SCALML=EXP(XMEANL)
      SHAPML=XSDL
C
C     COMPUTE STANDARD ERRORS
C
      UHATSE=SHAPML/SQRT(AN)
      SCALSE=EXP(UHATML + UHATSE) - EXP(UHATML)
      SHAPSE=SHAPML/SQRT(2.0*(AN-1.0))
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XMED,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XMED,XSD,XMIN,XMAX = ',I8,5G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9015)XMEANL,XSDL
 9015   FORMAT('XMEANL,XSDL = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHAPML,SCALML,SHAPSE,SCALSE
 9017   FORMAT('SHAPML,SCALML,SHAPSE,SCALSE =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9019)UHATML,UHATSE
 9019   FORMAT('UHATML,UHATSE =  ',2G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGNML2(Y,TAG,N,MAXNXT,
     1                  ICASE,IDIST,
     1                  TEMP1,XTEMP,DTEMP1,ITEMP,
     1                  XMEANF,XSDF,XVARF,XMINF,XMAXF,XMEDF,
     1                  XMEANC,XSDC,XVARC,XMINC,XMAXC,XMEDC,
     1                  SCALML,UHATML,UHATSE,SHAPML,SHAPSE,COVSE,
     1                  IRSAV,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 2-PARAMETER LOGNORMAL DISTRIBUTION FOR THE RAW DATA
C              CASE WITH CENSORING (BUT NO GROUPING).  THIS ROUTINE
C              RETURNS ONLY THE POINT ESTIMATES (CONFIDENCE INTERVALS
C              WILL BE COMPUTED IN A SEPARATE ROUTINE).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLL2 WILL GENERATE THE OUTPUT
C              FOR THE LOGNORMAL MLE COMMAND).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 11.
C     WRITTEN BY--ALAN HECKERT
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--2010/7
C     ORIGINAL VERSION--JULY      2010. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLL2)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION TAG(*)
      DIMENSION TEMP1(*)
      DIMENSION XTEMP(*)
      DOUBLE PRECISION DTEMP1(*)
      INTEGER ITEMP(*)
C
      CHARACTER*4 ICASE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
      CHARACTER*4 IWRITE
C
      DOUBLE PRECISION LG1FUN
      EXTERNAL LG1FUN
C
      DOUBLE PRECISION C
      INTEGER IN
      INTEGER IM
      COMMON/LG1COM/C,IN,IM
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
C
      DIMENSION FISH(2,2)
      DIMENSION COV(2,2)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DR
      DOUBLE PRECISION DM
      DOUBLE PRECISION DX
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DZ
      DOUBLE PRECISION DH
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='L2  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNML2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',3(A4,2X),2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(N,100)
          WRITE(ICOUT,57)I,Y(I),TAG(I)
   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','WRIT')
   56   CONTINUE
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR CENSORD LOGNORMAL MLE ESTIMATE  **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='LOGNORMAL'
C
      CALL CKCENS(TAG,TEMP1,N,IDIST,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      IFLAG=1
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEANF,XVARF,XSDF,XMINF,XMAXF,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXNXT,XMEDF,IBUGA3,IERROR)
C
      CALL SORTC(Y,TAG,N,Y,TAG)
      IR=0
      DO2120I=1,N
        IF(TAG(I).EQ.1.0)IR=IR+1
 2120 CONTINUE
      IRSAV=IR
C
      ICNT=0
      DO2122I=1,N
        IF(TAG(I).EQ.1.0)THEN
          ICNT=ICNT+1
          XTEMP(ICNT)=Y(I)
        ENDIF
 2122 CONTINUE
      DO2124I=1,N
        IF(TAG(I).EQ.0.0)THEN
          ICNT=ICNT+1
          XTEMP(ICNT)=Y(I)
        ENDIF
 2124 CONTINUE
      DO2126I=1,N
        Y(I)=XTEMP(I)
        IF(I.LE.IR)THEN
          TAG(I)=1.0
        ELSE
          TAG(I)=0.0
        ENDIF
 2126 CONTINUE
      IM=N-IR
C
      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'NML2')THEN
        WRITE(ICOUT,2127)N,IR,IM
 2127   FORMAT(1X,'N,IR,IM = ',3I8)
        CALL DPWRST('XXX','BUG ')
        DO2128I=1,MIN(100,N)
          WRITE(ICOUT,2129)I,Y(I),TAG(I)
 2129     FORMAT(1X,'I,Y(I),TAG(I)=',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 2128   CONTINUE
      ENDIF
C
      IR1=IR
      IR2=IR
      IR3=IR
C
      AR=REAL(IR)
      DR=DBLE(IR)
      AN=REAL(N)
      AM=REAL(IM)
C
      IF(IM.EQ.0)THEN
        ICASE='NONE'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2131)
 2131   FORMAT('***** WARNING FROM LOGNORMAL MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2133)
 2133   FORMAT('      NO CENSORING TIMES DETECTED.  IT IS RECOMMENDED')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2135)
 2135   FORMAT('      THAT THE FULL SAMPLE SYNTAX BE USED:')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2137)
 2137   FORMAT('      LOGNORMAL MAXIMUM LIKELIHOOD  Y')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
      ELSE
        ICASE='SING'
        AHOLD=Y(IR+1)
        DO2140I=IR+1,N
          IF(Y(I).NE.AHOLD)THEN
            ICASE='MULT'
            GOTO2149
          ENDIF
 2140   CONTINUE
 2149   CONTINUE
        C=DBLE(AHOLD)
      ENDIF
C
      IF(ICASE.EQ.'MULT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2141)
 2141   FORMAT('***** ERROR FROM LOGNORMAL MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2143)
 2143   FORMAT('      CURRENTLY, ONLY SINGLY CENSORED DATA IS ',
     1         'SUPPORTED FOR THE LOGNORMAL DISTRIBUTION.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,2145)
 2145   FORMAT('      MULTIPLY CENSORED DATA WAS DETECTED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ************************************
C               **  STEP 41--                     **
C               **  CARRY OUT CALCULATIONS        **
C               **  FOR LOGNORMAL MLE             **
C               **  ESTIMATE (TIME CENSORED CASE) **
C               ************************************
C
C     THE MAXIMUM LIKELIHOOD EQUATIONS ARE SOLVED USING THE DNSQE
C     ROUTINE.
C
C
      ISTEPN='31'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERROR='NO'
      IWRITE='OFF'
C
C     COMPUTE STATISTICS FOR FAILURE ONLY DATA
C
      ISTEPN='32'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MLL2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL MEAN(Y,IR,IWRITE,AMEAN,IBUGA3,IERROR)
      CALL MEDIAN(Y,IR,IWRITE,XTEMP,MAXNXT,XMEDC,IBUGA3,IERROR)
      CALL SD(Y,IR,IWRITE,ASD,IBUGA3,IERROR)
      CALL MINIM(Y,IR,IWRITE,AMIN,IBUGA3,IERROR)
      CALL MAXIM(Y,IR,IWRITE,AMAX,IBUGA3,IERROR)
      XMEANC=AMEAN
      XSDC=ASD
      XVARC=SQRT(ASD)
      XMINC=AMIN
      XMAXC=AMAX
C
      ISTEPN='32B'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML2')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C  USE PARAMETERS ESTIMATED FROM FAILURE DATA AS STARTING VALUES
C  FOR EQUATION SOLVER.
C
      DO3103I=1,IR
        XTEMP(I)=LOG(Y(I))
 3103 CONTINUE
C
      CALL MEAN(XTEMP,IR,IWRITE,XMEAN,IBUGA3,IERROR)
      CALL SD(XTEMP,IR,IWRITE,XSD,IBUGA3,IERROR)
C
      XPAR(1)=DBLE(XMEAN)
      XPAR(2)=DBLE(XSD)
C
      IN=N
      JAC=0
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      LWA=MAXNXT
      FVEC(1)=0.0D0
      FVEC(2)=0.0D0
      CALL DNSQE(LG1FUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,IR)
C
      UHATML=REAL(XPAR(1))
      SCALML=EXP(UHATML)
      SIGMML=REAL(XPAR(2))
      SHAPML=SIGMML
C
      ISTEPN='33'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MLL2')THEN
        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
        WRITE(ICOUT,2201)UHATML,SCALML,SIGMML
 2201   FORMAT('UHATML,SCALML,SIGMML = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C  COMPUTE STANDARD ERRORS.  FORMULAS FOR LOCAL FISHER INFORMATION
C  MATRIX GIVEN ON PAGE 162 OF BURY.
C
      DN=DBLE(N)
      DR=DBLE(IR)
      DM=DBLE(IM)
      DS=DBLE(SIGMML)
      DU=DBLE(UHATML)
      DZ=(DLOG(C)-DU)/DS
      CALL NODPDF(DZ,DTERM1)
      CALL NODCDF(DZ,DTERM2)
      DH=DTERM1/(1.0D0 - DTERM2)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO100I=1,IR
        DX=DBLE(Y(I))
        DX=(DLOG(DX) - DU)/DS
        DSUM1=DSUM1 + DX
        DSUM2=DSUM2 + DX*DX
  100 CONTINUE
C
      DTERM1=(1.0D0/DS**2)*(DR + DM*DH*(DH-DZ))
      FISH(1,1)=REAL(DTERM1)
      DTERM1=(1.0D0/DS**2)*(2.0D0*DSUM1 +DM*DH*(1.0D0 + DZ*(DH-DZ)))
      FISH(2,1)=REAL(DTERM1)
      FISH(1,2)=FISH(2,1)
      DTERM1=(1.0D0/DS**2)*
     1       (3.0D0*DSUM2 +DM*DZ*DH*(2.0D0 + DZ*DH -DZ**2) - DR)
      FISH(2,2)=REAL(DTERM1)
C
      NDIM=2
      CALL SGECO(FISH,NDIM,NDIM,ITEMP,RCOND,XTEMP)
      IJOB=1
      CALL SGEDI(FISH,NDIM,NDIM,ITEMP,XTEMP,XTEMP(MAXNXT/2),IJOB)
      DO2410J=1,NDIM
        DO2415I=1,NDIM
          COV(I,J)=FISH(I,J)
 2415   CONTINUE
 2410 CONTINUE
C
      SCALSE=0.0
      SIGMSE=0.0
      IF(COV(1,1).GE.0.0)SCALSE=SQRT(COV(1,1))
      IF(COV(2,2).GE.0.0)SIGMSE=SQRT(COV(2,2))
      COVSE=COV(2,1)
      UHATSE=SCALSE
      SHAPSE=SIGMSE
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNML2--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)N,XMEAN,XSD,XMIN,XMAX
 9013   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9017)SHAPML,SCALML,SHAPSE,SCALSE
 9017   FORMAT('SHAPML,SCALML,SHAPSE,SCALSE =  ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGNML3(Y,N,DTEMP1,
     1                  XMEAN,XSD,XVAR,XMIN,XMAX,XSKEW,
     1                  ALOCML,SCALML,SHAPML,UHATML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE 3-PARAMETER LOGNORMAL DISTRIBUTION FOR THE RAW DATA
C              CASE (I.E., NO CENSORING AND NO GROUPING).
C
C              THIS USES THE METHOD DESCRIBED IN COHEN AND WHITTEN (AND
C              ALSO IN BURY).
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLL3 WILL GENERATE THE OUTPUT
C              FOR THE 3-PARAMATER LOGNORMAL MLE COMMAND).
C
C     REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C              --COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 4.
C     WRITTEN BY--ALAN HECKERT
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--2014/04
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION LGNFU3
      EXTERNAL LGNFU3
C
      INTEGER IN
      COMMON/LGNMLE/IN
C
      DOUBLE PRECISION XSTART
      DOUBLE PRECISION XLOW
      DOUBLE PRECISION XUP
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION BOUND
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION DINC
C
      CHARACTER*4 IWRITE
      CHARACTER*40 IDIST
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='L3  '
C
      IDIST='LOGNORMAL'
      IWRITE='OFF'
      IERROR='NO'
      ALOCML=CPUMIN
      SCALML=CPUMIN
      SHAPML=CPUMIN
      UHATML=CPUMIN
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNML3--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR LOGNORMAL MLE ESTIMATE          **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML3')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N.LE.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN 3-PARAMETER LOGNORMAL MAXIMUM ',
     1         'LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 5.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,113)N
  113   FORMAT('      SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IFLAG=1
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
      CALL STMOM3(Y,N,IWRITE,XSKEW,IBUGA3,IERROR)
C
C     STEP 1: SOLVE EQUATION IN LGNFU3 TO ESTIMATE THE LOCATION
C             PARAMETER.
C
C             FIRST NEED TO FIND A BRACKETING INTERVAL.  USE
C             MINIMUM VALUE AS UPPER LIMITS.  DESCEND IN SMALL
C             INCREMENTS UNTIL "MEAN - 60*SD".  IF NO BRACKETING
C             INTERVAL FOUND AT THAT POINT, THEN NO ML SOLUTION.
C
      DO210I=1,N
        DTEMP1(I)=DBLE(Y(I))
  210 CONTINUE
      IN=N
C
      BOUND=DBLE(XMEAN) - 60.0D0*DBLE(XSD)
      IF((DBLE(XMIN)-BOUND).GT.100.)THEN
        DINC=(DBLE(XMIN)-BOUND)/100.0D0
      ELSEIF((DBLE(XMIN)-BOUND).GT.50.)THEN
        DINC=0.5D0
      ELSEIF((DBLE(XMIN)-BOUND).GT.10.)THEN
        DINC=0.1D0
      ELSE
        DINC=0.01D0
      ENDIF
C
      XUP=DBLE(XMIN) - 1.0D-06
      FU=LGNFU3(XUP,DTEMP1)
      XLOW=DBLE(XMIN)
      FL=FU
C
  290 CONTINUE
      IF(XLOW.GT.BOUND .AND. (FL*FU).GT.0.0D0)THEN
        XLOW=XLOW - DINC
        FL=LGNFU3(XLOW,DTEMP1)
        GOTO290
      ELSE
        IF(XLOW.LT.BOUND)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,111)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,292)
  292     FORMAT('      NO LOCAL MAXIMIM LIKELIHOOD ESTIMATE CAN ',
     1           'BE FOUND.')
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
      ENDIF
C
      XSTART=(XLOW+XUP)/2.0D0
      DAE=1.0D-7
      DRE=1.0D-7
      IFLAG=0
      ITBRAC=0
C
      CALL DFZER2(LGNFU3,XLOW,XUP,XSTART,DRE,DAE,IFLAG,DTEMP1)
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,3111)
C3111   FORMAT('***** WARNING FROM LOGNORMAL MAXIMUM LIKELIHOOD--')
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,3113)
C3113   FORMAT('      ESTIMATE OF LOCATION MAY NOT BE COMPUTED TO ',
CCCCC1         'DESIRED TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3121)
 3121   FORMAT('***** WARNING FROM LOGNORMAL MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3123)
 3123   FORMAT('      ESTIMATE OF LOCATION MAY BE NEAR A SINGULAR ',
     1         'POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3133)
 3133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,3143)
 3143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     ONCE LOCATION ESTIMATE DETERMINED
C
C         UHAT = (1/N*SUM[i=1 to N][LOG(X(i) - LOC]
C
C         SIGMA**2 = (1/N)*SUM[i=1 to N][LOG(X(i) - LOC]**2 -
C                    [(1/N)*SUM[i=1 to N][LOG(X(i) - LOC)]]**2
C
      ALOCML=REAL(XLOW)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DN=DBLE(N)
      DO4000I=1,N
        DX=DBLE(Y(I) - ALOCML)
        DSUM1=DSUM1 + DLOG(DX)
        DSUM2=DSUM2 + DLOG(DX)**2
 4000 CONTINUE
      UHATML=REAL(DSUM1/DN)
      SCALML=EXP(UHATML)
      DTERM1=DSQRT((DSUM2/DN) - (DSUM1/DN)**2)
      SHAPML=REAL(DTERM1)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNML3--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1
 9013   FORMAT('DSUM1,DSUM2,DTERM1 = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGNML5(ALOC,SCALE,SHAPE,N,COV,UHATSE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE PARAMETER VARIANCE-COVARIANCE
C              MATRIX FOR THE 3-PARAMETER LOGNORMAL DISTRIBUTION.  NOTE
C              THAT THESE ARE ONLY APPROXIMATE SINCE THE 3-PARAMETER
C              LOGNORMAL HAS REGULARITY PROBLEMS.  HOWEVER, ACCORDING
C              TO COHEN AND WHITTEN, SIMULATION STUDIES HAVE SHOWN
C              THAT THESE ARE REASONABLE ESTIMATES.  THE FORMULAS
C              FOR THE VARIANCE-COVARIANCE TERMS ARE GIVEN ON
C              PAGE 64 OF COHEN AND WHITTEN.
C
C     REFERENCE--COHEN AND WHITTEN (1988), "PARAMETER ESTIMATION IN
C                RELIABILITY AND LIFE SPAN MODELS", MARCEL DEKKER, INC.,
C                CHAPTER 4.
C              --KARL BURY, "STATISTICAL DISTRIBUTIONS IN
C                ENGINEERING", CAMBRIDGE UNIVERSITY PRESS,
C                1999, CHAPTER 13.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
      REAL COV(3,3)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DLOC
      DOUBLE PRECISION DSCALE
      DOUBLE PRECISION DSHAPE
      DOUBLE PRECISION DH
      DOUBLE PRECISION DW
      DOUBLE PRECISION DSIGMA
      DOUBLE PRECISION DBETA2
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='L5  '
C
      IWRITE='OFF'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNML5--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,54)ALOC,SCALE,SHAPE
   54   FORMAT('ALOC,SCALE,SHAPE = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR VARIANCE-COVARIANCE MATRIX      **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO101J=1,3
        DO103I=1,3
          COV(I,J)=CPUMIN
  103   CONTINUE
  101 CONTINUE
C
      DN=REAL(N)
      DLOC=DBLE(ALOC)
      DSCALE=DBLE(SCALE)
      DSHAPE=DBLE(SHAPE)
      DSIGMA=DSHAPE**2
      DBETA2=DSCALE**2
      DW=DEXP(DSHAPE**2)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')THEN
        WRITE(ICOUT,111)DN,DLOC,DSCALE,DSHAPE
  111   FORMAT('LGNML5: DN,DLOC,DSCALE,DSHAPE=',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)DSIGMA,DBETA2,DW
  112   FORMAT('        DSIGMA,DBETA2,DW=',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C     FORMULAS ARE (P. 64 OF COHEN AND WHITTEN):
C
C        VAR(LOC)         = (SHAPE**2/N)*(SCALE**2/W)*H
C        VAR(SCALE)       = (SHAPE**2/N)*SCALE**2*(1 + H)
C        VAR(SHAPE)       = (SHAPE**2/(2*N))*(1 + 2*SHAPE**2*H)
C        COV(LOC,SCALE)   = (-SHAPE**3/N)*(SCALE**2/SQRT(w))*H
C        COV(LOC,SHAPE)   = (SHAPE**3/N)*(SCALE**2/SQRT(W))*H
C        COV(SCALE,SHAPE) = (-SHAPE**3/N)*SCALE**2*H
C        VAR(UHAT)        = (SHAPE**2/N)*(1 + H)
C
C        H = 1/[W*(1+SHAPE**2) - (1+2*SHAPE**2)]
C
      DH=1.0D0/(DW*(1.0D0+DSIGMA) - (1.0D0+2.0D0*DSIGMA))
      COV(1,1)=REAL((DSIGMA/DN)*(DBETA2/DW)*DH)
      COV(2,2)=REAL((DSIGMA/DN)*DBETA2*(1.0D0+DH))
      COV(3,3)=REAL((DSIGMA/(2.0D0*DN))*(1.0D0+2.0D0*DSIGMA*DH))
      COV(1,3)=REAL((DSHAPE**3/DN)*(DBETA2/DSQRT(DW))*DH)
      COV(1,2)=-COV(1,3)
      COV(2,3)=REAL(-(DSHAPE**3/DN)*DBETA2*DH)
      COV(3,1)=COV(1,3)
      COV(2,1)=COV(1,2)
      COV(3,2)=COV(2,3)
      UHATSE=REAL(DSQRT((DSIGMA/DN)*(1.0D0+DH)))
C
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IML5')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNML5--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)DH,UHATSE
 9012   FORMAT('DH,UHATSE = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGNML8(Y,N,MAXNXT,P3LNMI,IOPFLG,
     1                  TEMP1,Y2,
     1                  ALOCML,SCALML,SHAPML,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--USE THE LAWLESS "PROFILE LIKELIHOOD" METHOD (THIS WAS
C              DEVELOPED FOR THE 3-PARAMETER WEIBULL DISTRIBUTION, BUT
C              THE SAME IDEA CAN BE APPLIED TO THE 3-PARAMETER LOGNORMAL
C              DISTRIBUTION.  THIS CAN BE USEFUL AS THE COHEN-WHITTEN
C              ALGORITHM CAN SOMETIMES FAIL.
C
C     PURPOSE--THIS SUBROUTINE IMPLEMENTS THE PROFILE LOG-LIKELIHOOD
C              METHOD ORIGINALLY PROPOSED BY LAWLESS FOR THE 3-PARAMETER
C              WEIBULL.  THIS METHOD DOES THE FOLLOWING:
C
C                1. CREATE A GRID FOR THE LOCATION PARAMETER FROM 0 TO
C                   THE DATA MINIMUM (MINUS AN EPSILON) VALUE.
C
C                2. ITERATE THROUGH THE GRID AND DO THE FOLLOWING:
C
C                    A. SET THE LOCATION PARAMETER TO THE GRID VALUE.
C                       CALL THIS VALUE A0.
C
C                    B. LET Y2 = Y - A0.
C
C                    C. ESTIMATE THE SCALE AND SHAPE PARAMETER USING
C                       STANDARD 2-PARAMETER LOGNORMAL ML METHODS.
C
C                    D. COMPUTE THE LOG-LIKELIHOOD OF THE 3-PARAMETER
C                       LOGNORMAL BASED ON THESE PARAMETER ESTIMATES.
C
C              THE PARAMETER ESTIMATES THAT GENERATE THE MAXIMUM
C              LIKELIHOOD VALUE ARE THE ESTIMATES USED.
C
C     REFERENCES--LAWLESS (2003), "STATISTICAL MODELS AND METHODS FOR
C                 LIFETIME DATA", SECOND EDITION, WILEY, PP. 187-190.
C              --COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DIMENSION Y(*)
      DIMENSION Y2(*)
      DIMENSION TEMP1(*)
C
      CHARACTER*4 IOPFLG
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IOP
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='L8  '
      IWRITE='OFF'
      IERROR='NO'
      EPS=0.1E-5
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML8')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNML8--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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               **************************************************
C               **  STEP 0--OPEN THE STORAGE FILES              **
C               **************************************************
C
      ISTEPN='1.1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML8')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(IOPFLG.EQ.'ON' .OR. IOPFLG.EQ.'YES')THEN
        IOP='OPEN'
        IFLAG1=0
        IFLAG2=1
        IFLAG3=0
        IFLAG4=0
        IFLAG5=0
        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
     1              IBUGA3,ISUBRO,IERROR)
        IF(IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR LOGNORMAL MLE ESTIMATE          **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML8')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='LOGNORMAL'
C
      IF(N.LE.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LOGNORMAL MAXIMUM LIKELIHOOD--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE IS LESS THAN 5.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,113)N
  113   FORMAT('      SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     THIS METHOD ASSUMES LOCATION IS NON-NEGATIVE (IT CAN BE EXTENDED
C     TO A NEGATIVE LOWER LIMITS, BUT DEFER ON IMPLEMENTING THAT FOR
C     NOW).
C
      DO120I=1,N
        IF(Y(I).LE.0.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,111)IDIST(1:16)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,127)I,Y(I)
  127     FORMAT('      ROW ',I8,' IS NON-POSITIVE (',G15.7,')')
          CALL DPWRST('XXX','WRIT')
          IERROR='YES'
          GOTO9000
        ENDIF
  120 CONTINUE
C
C     STEP 1: COMPUTE 2-PARAMETER ML ESTIMATES FOR ORIGINAL DATA SET
C
      CALL LGNML1(Y,N,MAXNXT,
     1            TEMP1,
     1            XMEAN,XMED,XSD,XVAR,XMIN,XMAX,XMEANL,XSDL,
     1            SCALML,SCALSE,SHAPML,SHAPSE,UHATML,UHATSE,
     1            ISUBRO,IBUGA3,IERROR)
      YMIN=P3LNMI
      IF(YMIN.GE.XMIN)YMIN=0.0
      ALOCML=YMIN
      CALL LGNLI1(Y,N,ALOCML,SCALML,SHAPML,
     1            ALIK,AIC,AICC,BIC,
     1            ISUBRO,IBUGA3,IERROR)
C
      IF(IOPFLG.EQ.'ON' .OR. IOPFLG.EQ.'YES')THEN
        WRITE(IOUNI2,151)ALOCML,ALIK,SCALML,SHAPML
  151   FORMAT(4E15.7)
      ENDIF
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML8')THEN
        WRITE(ICOUT,131)SCALML,SHAPML,ALIK
  131   FORMAT('ZERO CASE: SCALML,SHAPML,ALIK = ',3G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C     STEP 2: NOW ITERATE THROUGH VALUES OF THE LOCATION PARAMETER
C
C             IF MINIMUM VALUE IS SUFFICIENTLY SMALL, JUST DEFINE A
C             SINGLE GRID.  IF IT IS LARGE, THEN DO 2 PASSES.  ONCE
C             WITH A BROAD GRID AND THEN WITH A FINER GRID.
C
      XMINT=XMIN - EPS
      IF(XMIN.LE.100.0)THEN
        NITER=1
        IPASS=1
        IF(XMIN.LE.10)THEN
          AINC=0.001
        ELSE
          AINC=0.01
        ENDIF
        NLOOP=INT(((XMINT-YMIN)/AINC)+0.1)
      ELSE
        NITER=2
        IPASS=1
        NLOOP=100
        AINC=(XMIN-YMIN)/REAL(NLOOP)
      ENDIF
C
 1000 CONTINUE
C
      IF(IPASS.EQ.2)THEN
        XSTRT=ALOCML - AINC
        IF(XSTRT.LE.0.0)XSTRT=0.0
        XSTOP=ALOCML + AINC
        NLOOP=100
        AINC=XMIN/REAL(NLOOP)
      ELSE
        XSTRT=YMIN
      ENDIF
C
      ALIK=CPUMIN
      ALIKT=CPUMIN
      DO1100ILOOP=1,NLOOP
C
C       STEP 2A: SUBTRACT OFF CONDITIONAL VALUE OF LOCATION
C
        ALOC=XSTRT + REAL(ILOOP)*AINC
        IF(ALOC.GE.XMIN)GOTO1100
        DO1110I=1,N
          Y2(I)=Y(I) - ALOC
 1110   CONTINUE
C
C       STEP 2B: COMPUTE 2-PARAMETER ML ESTIMATES FOR MODIFIED DATA SET
C                (BUT NOT THAT LIKELIHOOD IS COMPUTED FOR ORIGINAL DATA)
C
        CALL LGNML1(Y2,N,MAXNXT,
     1              TEMP1,
     1              XMEAN,XMED,XSD,XVAR,XMIN,XMAX,XMEANL,XSDL,
     1              SCALMT,SCALSE,SHAPMT,SHAPSE,UHATMT,UHATSE,
     1              ISUBRO,IBUGA3,IERROR)
        CALL LGNLI1(Y,N,ALOC,SCALMT,SHAPMT,
     1              ALIKT,AIC,AICC,BIC,
     1              ISUBRO,IBUGA3,IERROR)
C
      IF(IOPFLG.EQ.'ON' .OR. IOPFLG.EQ.'YES')THEN
        WRITE(IOUNI2,151)ALOC,ALIKT,SCALMT,SHAPMT
      ENDIF
C
C
C       STEP 2C: COMPARE LIKELIHOOD TO CURRENT MAXIMUM
C
        IF(ALIKT.GT.ALIK)THEN
          ALIK=ALIKT
          ALOCML=ALOC
          SCALML=SCALMT
          SHAPML=SHAPMT
          ITEMP=ILOOP
        ENDIF
C
 1100 CONTINUE
C
      IF(NITER.EQ.2 .AND. IPASS.EQ.1)THEN
        IPASS=2
        GOTO1000
      ENDIF
C
 9000 CONTINUE
C
      IF(IOPFLG.EQ.'ON' .OR. IOPFLG.EQ.'YES')THEN
        IOP='CLOS'
        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
     1              IBUGA3,ISUBRO,IERROR)
      ENDIF
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NML8')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNML8--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)NITER,NLOOP,IPASS,IERROR
 9013   FORMAT('NITER,NLOOP,IPASS,IERROR = ',3I8,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9021)ALOCML,SCALML,SHAPML,ALIK
 9021   FORMAT('MLE: ALOCML,SCALML,SHAPML,ALIK = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LGNMO1(XMEAN,XSD,XMIN,XSKEW,N,PSTAMV,
     1                  ALOCMO,SCALMO,SHAPMO,UHATMO,
     1                  ALOCMM,SCALMM,SHAPMM,UHATMM,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES MOMENT ESTIMATES FOR THE 3-PARAMETER
C              LOGNORMAL DISTRIBUTION.  THE INPUT VALUES ARE:
C
C                 XMEAN   - THE SAMPLE MEAN
C                 XSD     - THE SAMPLE STANDARD DEVIATION
C                 XSKEW   - THE SAMPLE SKEWNESS
C                 XMIN    - THE SAMPLE MINIMUM
C
C              THIS IS FOR THE UNCENSORED CASE.
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., P. 61 AND
C                PP. 352-354.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION AMOM(3)
      DOUBLE PRECISION VMOM(8)
      DOUBLE PRECISION VMMOM(8)
      DOUBLE PRECISION DW
      DOUBLE PRECISION DWL
      DOUBLE PRECISION DWU
      DOUBLE PRECISION FL
      DOUBLE PRECISION FU
      DOUBLE PRECISION F
      DOUBLE PRECISION EPS
      DOUBLE PRECISION BETA
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DPPF
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      DOUBLE PRECISION LGNMO2
      DOUBLE PRECISION LGNMO3
      DOUBLE PRECISION LGNMO4
      EXTERNAL LGNMO2
      EXTERNAL LGNMO3
      EXTERNAL LGNMO4
C
      REAL LININ3
      EXTERNAL LININ3
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LGNM'
      ISUBN2='O1  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMO1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LGNMO1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,54)XMEAN,XSD,XMIN,XSKEW
   54   FORMAT('XMEAN,XSD,XMIN,XSKEW = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
C               ******************************************
C               **  STEP 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR LOGNORMAL MOMENT ESTIMATE       **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMO1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(XMEAN.EQ.CPUMIN .OR. XMEAN.EQ.PSTAMV)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN LOGNORMAL MOMENT ESTIMATION--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,102)
  102   FORMAT('      THE SAMPLE MEAN IS UNDEFINED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(XSD.EQ.CPUMIN .OR. XSD.EQ.PSTAMV)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,107)
  107   FORMAT('      THE SAMPLE STANDARD DEVIATION IS UNDEFINED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(XSD.LE.0.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,112)
  112   FORMAT('      THE SAMPLE STANDARD DEVIATION IS NON-POSTIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,113)XSD
  113   FORMAT('      STANDARD DEVIATION = ',G15.7)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ELSEIF(N.LT.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,122)
  122   FORMAT('      THE SAMPLE SIZE IS LESS THAN FIVE.')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,123)N
  123   FORMAT('      SAMPLE SIZE  = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      DEPS=0.1D-7
C
      ALOCMO=CPUMIN
      SCALMO=CPUMIN
      SHAPMO=CPUMIN
      UHATMO=CPUMIN
C
      ALOCMM=CPUMIN
      SCALMM=CPUMIN
      UHATMM=CPUMIN
      SHAPMM=CPUMIN
C
      VMMOM(1)=CPUMIN
      VMMOM(2)=CPUMIN
      VMMOM(3)=CPUMIN
      VMMOM(4)=CPUMIN
      VMMOM(5)=CPUMIN
      VMMOM(6)=CPUMIN
      VMMOM(7)=CPUMIN
      VMMOM(8)=CPUMIN
C
C               ******************************************
C               **  STEP 2--                            **
C               **  MOMENT ESTIMATES                    **
C               ******************************************
C
      ISTEPN='2'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NMO1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     IN CODE BELOW:
C
C        VMOM(1) = ESTIMATE OF LOCATION
C        VMOM(2) = ESTIMATE OF U
C        VMOM(3) = ESTIMATE OF SHAPE (SIGMA)
C        VMOM(4) = DW = EXP(SIGMA**2)
C        VMOM(5) = BETA = SCALE = EXP(U)
C        VMOM(6) = A3 = = SQRT(PEARSON'S BETA1) (SKEWNESS)
C                = (DW + 2.0)*SQRT(DW-1.0)
C        VMOM(7) = E(X) = V(1) + BETA*SQRT(DW)
C        VMOM(8) = SD(X) = BETA*SQRT(DW*(DW-1.0))
C
C     FOR OUR PURPOSES, WE ARE PRIMARILY INTERESTED IN THE PARAMETER
C     ESTIMATES.
C
      AMOM(1)=DBLE(XMEAN)
      AMOM(2)=DBLE(XSD)
      AMOM(3)=DBLE(XSKEW)
      DW=LGNMO4(AMOM(3))
C
      IERR=0
      KOUNT=1
  100 CONTINUE
      IF(DABS(LGNMO2(DW,AMOM)).GE.1.0D-9 .AND. KOUNT.LT.500)THEN
        DW=DW - LGNMO2(DW,AMOM)/LGNMO3(DW)
        KOUNT=KOUNT+1
        GOTO100
      ELSE
        IF(KOUNT.LT.500)THEN
          VMOM(1)=AMOM(1) - AMOM(2)/DSQRT(DW - 1.0)
          IF(VMOM(1).LE.AMOM(1) - 50.0D0*AMOM(2))THEN
            IERR=1
            WRITE(ICOUT,999)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,101)
            CALL DPWRST('XXX','WRIT')
            WRITE(ICOUT,132)
  132       FORMAT('      NO MOMENT ESTIMATOR FOUND.')
            CALL DPWRST('XXX','WRIT')
            GOTO199
          ELSE
            BETA=AMOM(2)/DSQRT(DW*(DW-1.0D0))
            VMOM(2)=DLOG(BETA)
            VMOM(3)=DSQRT(DLOG(DW))
            VMOM(4)=DW
            VMOM(5)=BETA
            VMOM(6)=(DW+2.0D0)*DSQRT(DW-1.0D0)
            VMOM(7)=VMOM(1) + BETA*DSQRT(DW)
            VMOM(8)=BETA*DSQRT(DW*(DW-1.0D0))
          ENDIF
        ELSE
          IERR=1
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,101)
          CALL DPWRST('XXX','WRIT')
          WRITE(ICOUT,132)
          CALL DPWRST('XXX','WRIT')
          GOTO199
        ENDIF
      ENDIF
C
      ALOCMO=REAL(VMOM(1))
      SCALMO=REAL(VMOM(5))
      SHAPMO=REAL(VMOM(3))
      UHATMO=REAL(VMOM(2))
C
  199 CONTINUE
C
C     IN CODE BELOW:
C
C        VMMOM(1) = ESTIMATE OF LOCATION
C        VMMOM(2) = ESTIMATE OF U
C        VMMOM(3) = ESTIMATE OF SHAPE (SIGMA)
C        VMMOM(4) = DW = EXP(SIGMA**2)
C        VMMOM(5) = BETA = SCALE = EXP(U)
C        VMMOM(6) = A3 = = SQRT(PEARSON'S BETA1) (SKEWNESS)
C                 = (DW + 2.0)*SQRT(DW-1.0)
C        VMMOM(7) = E(X) = V(1) + BETA*SQRT(DW)
C        VMMOM(8) = SD(X) = BETA*SQRT(DW*(DW-1.0))
C
C     COMPUTE MODIFIED MOMENT ESTIMATORS USING CODE FOUND ON
C     PP. 352-354 OF COHEN/WHITTEN BOOK.
C
C     IF XMIN PARAMETER NOT GIVEN, THEN SKIP THIS CASE.
C
      IF(XMIN.EQ.CPUMIN)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,212)
  212   FORMAT('      MINIMUM VALUE NOT SPECIFIED.  MODIFIED ',
     1         'MOMENTS WILL NOT BE COMPUTED.')
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     FIRST OBTAIN VALUE OF EXPECTED VALUE OF FIRST ORDER
C     STATISTIC.
C
      SI=0.0
      IF(N.GE.1000)THEN
        DTERM1=1.0D0/DBLE(N+1)
        CALL NODPPF(DTERM1,DPPF)
        SI=REAL(DPPF)
      ELSEIF(N.EQ.5)THEN
        SI=-1.16296
      ELSEIF(N.GT.5 .AND. N.LT.10)THEN
        AY1=-1.16296
        AY2=-1.53875
        AX1=5.0
        AX2=10.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.10)THEN
        SI=-1.53875
      ELSEIF(N.EQ.11)THEN
        SI=(-1.53875 + (-1.62923))/2.0
      ELSEIF(N.EQ.12)THEN
        SI=-1.62923
      ELSEIF(N.EQ.13)THEN
        SI=(-1.62923 + (-1.70338))/2.0
      ELSEIF(N.EQ.14)THEN
        SI=-1.70338
      ELSEIF(N.EQ.15)THEN
        SI=(-1.70338 + (-1.75699))/2.0
      ELSEIF(N.EQ.16)THEN
        SI=-1.75699
      ELSEIF(N.EQ.17)THEN
        SI=(-1.75699 + (-1.82003))/2.0
      ELSEIF(N.EQ.18)THEN
        SI=-1.82003
      ELSEIF(N.EQ.19)THEN
        SI=(-1.82003 + (-1.86748))/2.0
      ELSEIF(N.EQ.20)THEN
        SI=-1.86748
      ELSEIF(N.EQ.21)THEN
        SI=(-1.86748 + (-1.90969))/2.0
      ELSEIF(N.EQ.22)THEN
        SI=-1.90969
      ELSEIF(N.EQ.23)THEN
        SI=(-1.90969 + (-1.94767))/2.0
      ELSEIF(N.EQ.24)THEN
        SI=-1.94767
      ELSEIF(N.EQ.25)THEN
        SI=(-1.94767 + (-1.98216))/2.0
      ELSEIF(N.EQ.26)THEN
        SI=-1.98216
      ELSEIF(N.EQ.27)THEN
        SI=(-1.98216 + (-2.01371))/2.0
      ELSEIF(N.EQ.28)THEN
        SI=-2.01371
      ELSEIF(N.EQ.29)THEN
        SI=(-2.01371 + (-2.04276))/2.0
      ELSEIF(N.EQ.30)THEN
        SI=-2.04276
      ELSEIF(N.EQ.31)THEN
        SI=(-2.04276 + (-2.06967))/2.0
      ELSEIF(N.EQ.32)THEN
        SI=-2.06967
      ELSEIF(N.EQ.33)THEN
        SI=(-2.06967 + (-2.09471))/2.0
      ELSEIF(N.EQ.34)THEN
        SI=-2.09471
      ELSEIF(N.EQ.35)THEN
        SI=(-2.09471 + (-2.11812))/2.0
      ELSEIF(N.EQ.36)THEN
        SI=-2.11812
      ELSEIF(N.EQ.37)THEN
        SI=(-2.11812 + (-2.14009))/2.0
      ELSEIF(N.EQ.38)THEN
        SI=-2.14009
      ELSEIF(N.EQ.39)THEN
        SI=(-2.14099 + (-2.16078))/2.0
      ELSEIF(N.EQ.40)THEN
        SI=-2.16078
      ELSEIF(N.GT.40 .AND. N.LT.45)THEN
        AY1=-2.16078
        AY2=-2.20772
        AX1=40.0
        AX2=45.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.45)THEN
        SI=-2.20772
      ELSEIF(N.GT.45 .AND. N.LT.50)THEN
        AY1=-2.20772
        AY2=-2.24907
        AX1=45.0
        AX2=50.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.50)THEN
        SI=-2.24907
      ELSEIF(N.GT.50 .AND. N.LT.55)THEN
        AY1=-2.24907
        AY2=-2.28598
        AX1=50.0
        AX2=55.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.55)THEN
        SI=-2.28598
      ELSEIF(N.GT.55 .AND. N.LT.60)THEN
        AY1=-2.28598
        AY2=-2.31928
        AX1=55.0
        AX2=60.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.60)THEN
        SI=-2.31928
      ELSEIF(N.GT.60 .AND. N.LT.65)THEN
        AY1=-2.31928
        AY2=-2.34958
        AX1=60.0
        AX2=65.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.65)THEN
        SI=-2.34958
      ELSEIF(N.GT.65 .AND. N.LT.70)THEN
        AY1=-2.34958
        AY2=-2.37736
        AX1=65.0
        AX2=70.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.70)THEN
        SI=-2.37736
      ELSEIF(N.GT.70 .AND. N.LT.75)THEN
        AY1=-2.37736
        AY2=-2.40299
        AX1=70.0
        AX2=75.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.75)THEN
        SI=-2.40299
      ELSEIF(N.GT.75 .AND. N.LT.80)THEN
        AY1=-2.40299
        AY2=-2.42677
        AX1=75.0
        AX2=80.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.80)THEN
        SI=-2.42677
      ELSEIF(N.GT.80 .AND. N.LT.85)THEN
        AY1=-2.42677
        AY2=-2.44894
        AX1=80.0
        AX2=85.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.85)THEN
        SI=-2.44894
      ELSEIF(N.GT.85 .AND. N.LT.90)THEN
        AY1=-2.44894
        AY2=-2.46970
        AX1=85.0
        AX2=90.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.90)THEN
        SI=-2.46970
      ELSEIF(N.GT.90 .AND. N.LT.95)THEN
        AY1=-2.46970
        AY2=-2.48920
        AX1=90.0
        AX2=95.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.95)THEN
        SI=-2.48920
      ELSEIF(N.GT.95 .AND. N.LT.100)THEN
        AY1=-2.48920
        AY2=-2.50759
        AX1=95.0
        AX2=100.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.100)THEN
        SI=-2.50759
      ELSEIF(N.GT.100 .AND. N.LT.125)THEN
        AY1=-2.50759
        AY2=-2.58634
        AX1=100.0
        AX2=125.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.125)THEN
        SI=-2.58634
      ELSEIF(N.GT.125 .AND. N.LT.150)THEN
        AY1=-2.58634
        AY2=-2.64925
        AX1=125.0
        AX2=150.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.150)THEN
        SI=-2.64925
      ELSEIF(N.GT.150 .AND. N.LT.175)THEN
        AY1=-2.64925
        AY2=-2.70148
        AX1=150.0
        AX2=175.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.175)THEN
        SI=-2.70148
      ELSEIF(N.GT.175 .AND. N.LT.200)THEN
        AY1=-2.70148
        AY2=-2.74604
        AX1=175.0
        AX2=200.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.200)THEN
        SI=-2.74604
      ELSEIF(N.GT.200 .AND. N.LT.225)THEN
        AY1=-2.74604
        AY2=-2.74845
        AX1=200.0
        AX2=225.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.225)THEN
        SI=-2.78485
      ELSEIF(N.GT.225 .AND. N.LT.250)THEN
        AY1=-2.74845
        AY2=-2.81918
        AX1=225.0
        AX2=250.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.250)THEN
        SI=-2.81918
      ELSEIF(N.GT.250 .AND. N.LT.280)THEN
        AY1=-2.81918
        AY2=-2.85572
        AX1=250.0
        AX2=280.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.280)THEN
        SI=-2.85572
      ELSEIF(N.GT.280 .AND. N.LT.300)THEN
        AY1=-2.85572
        AY2=-2.87777
        AX1=280.0
        AX2=300.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.300)THEN
        SI=-2.87777
      ELSEIF(N.GT.300 .AND. N.LT.315)THEN
        AY1=-2.87777
        AY2=-2.89327
        AX1=300.0
        AX2=315.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.315)THEN
        SI=-2.89327
      ELSEIF(N.GT.315 .AND. N.LT.350)THEN
        AY1=-2.89327
        AY2=-2.92651
        AX1=315.0
        AX2=350.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.350)THEN
        SI=-2.92651
      ELSEIF(N.GT.350 .AND. N.LT.375)THEN
        AY1=-2.92651
        AY2=-2.94810
        AX1=350.0
        AX2=375.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.375)THEN
        SI=-2.94810
      ELSEIF(N.GT.375 .AND. N.LT.400)THEN
        AY1=-2.94810
        AY2=-2.96818
        AX1=375.0
        AX2=400.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ELSEIF(N.EQ.400)THEN
        SI=-2.96818
      ELSEIF(N.GT.400)THEN
        AY1=-2.96818
        AY2=-3.09053
        AX1=400.0
        AX2=1000.0
        AX3=REAL(N)
        SI=LININ3(AX1,AY1,AX2,AY2,AX3,IBUGA3,ISUBRO,IERROR)
      ENDIF
C
      IERR=0
C
C     SET LOWER AND UPPER BOUNDS FOR DW AND CALCULATE FUNCTION AT
C     THESE VALUES
C
      DWL=1.00004D0
      FL=DWL*(DWL-1.0D0)-((DSQRT(DWL)-DEXP(DBLE(SI)*DSQRT(DLOG(DWL))))*
     1   AMOM(2)/(AMOM(1) - XMIN))**2
C
      DWU=1.0D0+(AMOM(2)/(AMOM(1)-XMIN))**2 - 0.1D-7
      FU=DWU*(DWU-1.0D0)-((DSQRT(DWU)-DEXP(DBLE(SI)*DSQRT(DLOG(DWU))))*
     1   AMOM(2)/(AMOM(1) - XMIN))**2
C
C     SET THE TOLERANCE LEVEL
C
      EPS=0.1D-10
      IF(FL*FU.GT.0.0)THEN
        IERR=1
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,101)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,222)
  222   FORMAT('      NO MODIFIED MOMENT ESTIMATOR FOUND.')
        CALL DPWRST('XXX','WRIT')
      ELSE
        DW=(DWL+DWU)/2.0D0
        F=FL
300     CONTINUE
        IF(DABS(DW-DWL).GT.EPS)THEN
          F=DW*(DW-1.0D0)-((DSQRT(DW)-DEXP(DBLE(SI)*DSQRT(DLOG(DW))))*
     1      AMOM(2)/(AMOM(1) - XMIN))**2
          IF(F*FL.LT.0.0D0)THEN
            DWU=DW
          ELSE
            DWL=DW
            FL=F
          ENDIF
          DW=(DWL+DWU)/2.0D0
          GOTO300
        ELSE
          VMMOM(1)=AMOM(1) - AMOM(2)/DSQRT(DW-1.0D0)
          BETA=AMOM(2)/DSQRT(DW*(DW-1.0D0))
          VMMOM(2)=DLOG(BETA)
          VMMOM(3)=DSQRT(DLOG(DW))
          VMMOM(4)=DW
          VMMOM(5)=BETA
          VMMOM(6)=(DW+2.0D0)*DSQRT(DW-1.0D0)
          VMMOM(7)=VMMOM(1) + BETA*DSQRT(DW)
          VMMOM(8)=BETA*DSQRT(DW*(DW-1.0D0))
        ENDIF
      ENDIF
C
      ALOCMM=VMMOM(1)
      SCALMM=VMMOM(5)
      SHAPMM=VMMOM(3)
      UHATMM=VMMOM(2)
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'IMO1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LGNMO1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9012)ALOCMO,SCALMO,SHAPMO,UHATMO
 9012   FORMAT('ALOCMO,SCALMO,SHAPMO,UHATMO = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)ALOCMM,SCALMM,SHAPMM,UHATMM
 9013   FORMAT('ALOCMM,SCALMM,SHAPMM,UHATMM = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LGNMO2(DW,AMOM)
C
C     PURPOSE--COMPUTE A FUNCTION NEEDED BY LGNMO1 (USED TO COMPUTE
C              MOMENT ESTIMATES FOR THE 3-PARAMETER WEIBULL
C              DISTRIBUTION).
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., PP. 352-352.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION AMOM(*)
      DOUBLE PRECISION DW
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      LGNMO2=DW**3 + 3.0D0*DW**2 - 4.0D0 - DBLE(AMOM(3))**2
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LGNMO3(DW)
C
C     PURPOSE--COMPUTE A FUNCTION NEEDED BY LGNMO1 (USED TO COMPUTE
C              MOMENT ESTIMATES FOR THE 3-PARAMETER WEIBULL
C              DISTRIBUTION).
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., PP. 352-352.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DW
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      LGNMO3=3.0D0**2 + 6.0D0*DW
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LGNMO4(DW)
C
C     PURPOSE--COMPUTE A FUNCTION NEEDED BY LGNMO1 (USED TO COMPUTE
C              MOMENT ESTIMATES FOR THE 3-PARAMETER WEIBULL
C              DISTRIBUTION).
C
C     REFERENCE--COHEN AND WHITTEN, "PARAMETER ESTIMATION IN RELIABILITY
C                AND LIFE SPAN MODELS", MARCEL DEKKER, INC., PP. 352-352.
C     WRITTEN BY--ALAN HECKERT
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--2014/4
C     ORIGINAL VERSION--APRIL     2014
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DW
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      LGNMO4=0.2000D0*DW + 1.0D0
C
      RETURN
      END
      SUBROUTINE LGNPDF(X,SD,PDF)
CCCCC SUBROUTINE LGNPDF(X,PDF)
CCCCC APRIL 1995.  ADD SD PARAMETER (THIS IS SHAPE PARAMETER FOR
CCCCC LOGNORMAL).
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOGNORMAL
C             DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPDF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1994.
C     UPDATED         --JANUARY   1995. X=0 CASE EXPLICITLY 0
C     UPDATED         --APRIL     1995. SUPPORT SHAPE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PDF=0.0
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LGNPDF IS NEGATIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GT.0.0)THEN
        IF(SD.EQ.1.0)THEN
          ARG=LOG(X)
          CALL NORPDF(ARG,PDF)
          PDF=(1.0/X)*PDF
        ELSE
          ARG=LOG(X)/SD
          CALL NORPDF(ARG,ARG2)
          PDF=(1.0/(SD*X))*ARG2
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNPPF(P,SD,PPF)
CCCCC SUBROUTINE LGNPPF(P,PPF)
CCCCC APRIL 1995.  SUPPORT SCALE PARAMETER
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOGNORMAL
C              DISTRIBUTION.
C              THE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C             VALUE PPF FOR THE LOGNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C     UPDATED         --JANUARY   1995.
C     UPDATED         --APRIL     1995. SUPPORT SCALE PARAMETER
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LGNPPF IS OUTSIDE ',
     1       'THE ALLOWABLE (0,1) INTERVAL.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C-----START POINT-----------------------------------------------------
C
      IF(P.GT.0.0)THEN
        IF(SD.EQ.1.0)THEN
          CALL NORPPF(P,PPF)
          PPF=EXP(PPF)
        ELSE
          CALL NORPPF(P,PPF)
          PPF=EXP(PPF*SD)
        ENDIF
      ENDIF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LGNRAN(N,SIGMA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOGNORMAL DISTRIBUTION.
C              THE PROTOTYPE LOGNORMAL DISTRIBUTION USED
C              HEREIN HAS MEAN = SQRT(E) = 1.64872127
C              AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/(X*SQRT(2*PI))) * EXP(-LOG(X)*LOG(X)/2)
C              THE PROTOTYPE LOGNORMAL DISTRIBUTION USED HEREIN
C              IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE
C              THE VARIATE Z IS NORMALLY DISTRIBUTED
C              WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOGNORMAL DISTRIBUTION
C             WITH MEAN = SQRT(E) = 1.64872127
C             AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, SQRT, SIN, COS, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --CRAMER, MATHEMATICAL METHODS OF STATISTICS,
C                 1946, PAGES 219-220.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 112-136.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGE 88.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--NOVEMBER  1975.
C     UPDATED         --JULY      1976.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --APRIL     2003. ADD SHAPE PARAMETER SIGMA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA PI/3.14159265359/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LGNRAN IS ',
     1       'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C     THEN GENERATE 2 ADDITIONAL UNIFORM (0,1) RANDOM NUMBERS
C     (TO BE USED BELOW IN FORMING THE N-TH NORMAL
C     RANDOM NUMBER WHEN THE DESIRED SAMPLE SIZE N
C     HAPPENS TO BE ODD).
C
      CALL UNIRAN(N,ISEED,X)
      CALL UNIRAN(2,ISEED,Y)
C
C     GENERATE N NORMAL RANDOM NUMBERS
C     USING THE BOX-MULLER METHOD.
C
      DO200I=1,N,2
        IP1=I+1
        U1=X(I)
        IF(I.EQ.N)THEN
          U2=Y(2)
        ELSE
          U2=X(IP1)
        ENDIF
        ARG1=-2.0*LOG(U1)
        ARG2=2.0*PI*U2
        SQRT1=SQRT(ARG1)
        Z1=SQRT1*COS(ARG2)
        Z2=SQRT1*SIN(ARG2)
        X(I)=Z1
        IF(I.EQ.N)GOTO200
        X(IP1)=Z2
  200 CONTINUE
C
C     GENERATE N LOGNORMAL RANDOM NUMBERS USING THE DEFINITION THAT
C     A LOGNORMAL VARIATE EQUALS AN EXPONETIATED NORMAL VARIATE.
C
      DO400I=1,N
        X(I)=EXP(SIGMA*X(I))
  400 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LIBFD1(IHLF1,IHLF2,I1,I2,ITYPE,
     1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2)
C
C     PURPOSE--COMPUTE DERIVATIVES FOR
C              SQUARE ROOT, EXPONENTIAL, AND LOGS.
C
C     ORIGINAL VERSION--JANUARY   1979.
C     UPDATED         --FEBRUARY  1979.
C     UPDATED         --JANUARY   1981.
C
C---------------------------------------------------------------------
C
      CHARACTER*4 IHLF1
      CHARACTER*4 IHLF2
      CHARACTER*4 ITYPE
      CHARACTER*4 IFUNZ1
      CHARACTER*4 IFUNZ2
      CHARACTER*4 IDERZ1
      CHARACTER*4 IDERZ2
C
      DIMENSION IFUNZ1(*)
      DIMENSION IFUNZ2(*)
      DIMENSION IDERZ1(*)
      DIMENSION IDERZ2(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      I1P1=I1+1
      I1P2=I1+2
C
      IF(IHLF1.EQ.'SQRT'.AND.IHLF2.EQ.'    ')GOTO510
      IF(IHLF1.EQ.'EXP '.AND.IHLF2.EQ.'    ')GOTO520
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'E   ')GOTO530
      IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'10  ')GOTO540
      IF(IHLF1.EQ.'LOG '.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'LOGE'.AND.IHLF2.EQ.'    ')GOTO530
      IF(IHLF1.EQ.'LOG1'.AND.IHLF2.EQ.'0   ')GOTO540
C
C     TREAT THE SQUARE ROOT CASE
C
  510 CONTINUE
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='5   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)='**  '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='-   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='5   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE EXPONENTIAL CASE
C
  520 CONTINUE
      I2=I2+1
      IDERZ1(I2)='EXP '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE NATURAL LOGARITHM CASE
C
  530 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
C     TREAT THE LOGARITHM (TO THE BASE 10) CASE
C
  540 CONTINUE
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='/   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='(   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=IFUNZ1(I1P1)
      IDERZ2(I2)=IFUNZ2(I1P1)
      IF(ITYPE.EQ.'EXP ')I2=I2+1
      IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2)
      IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2)
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)=')   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='*   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='0   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='.   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='3   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='2   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='9   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='4   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='8   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='1   '
      IDERZ2(I2)='    '
      I2=I2+1
      IDERZ1(I2)='9   '
      IDERZ2(I2)='    '
      IF(ITYPE.EQ.'EXP ')GOTO980
      GOTO985
C
  980 CONTINUE
  985 CONTINUE
C
      RETURN
      END
      SUBROUTINE LIBPTR(ICTEXT,NCTEXT,ICTEX2,NCTEX2,ICASE,
     1                  ISUBRO,IBUGG3)
C
C     PURPOSE--FOR LIBPLOT OUTPUT, TRANSLATE BETWEEN DATAPLOT'S
C              SPECIAL CHARACTERS AND LIBPLOT SPECIAL CHARACTERS.
C              NOTE THAT THIS MAPPING MAY NOT BE 1-TO-1.  SPECIFICALLY,
C              WE ARE LOOKING THE TRANSLATE THE DATAPLOT SPECIAL
C              SYMBOLS.  LIBPLOT MAY SUPPORT ADDITIONAL SYMBOLS
C              BEYOND WHAT DATAPLOT SUPPORTS.  THE USER CAN ENTER
C              THESE ADDITIONAL LIBPLOT SPECIAL SYMBOLS, BUT THEY
C              THEY WILL BE PLOTTED "AS IS" ON NON-LIBPLOT DEVICES.
C
C              NOTE THAT THIS ROUTINE IS SIMPLER THAN THE POSTSCRIPT
C              ROUTINE IN THAT WE DO NOT NEED TO SPLIT THE STRING
C              INTO MULTIPLE STRINGS.  RATHER WE ARE JUST DOING A
C              STRAIGHT TRANSLATION FROM ONE SYMBOL CODE TO THE OTHER.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-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--2009.5
C     ORIGINAL VERSION--MAY       2009.
C
C-----NON-COMMON VARIABLES (GRAPHICS)-------------------------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGG3
C
      CHARACTER*4 ICTEXT(*)
      CHARACTER*4 ICTEX2(*)
C
      CHARACTER*1 IC1
      CHARACTER*1 IC2
      CHARACTER*1 IC3
      CHARACTER*1 IC4
      CHARACTER*1 IC5
      CHARACTER*1 IC6
      CHARACTER*1 IBASLC
C
C-----COMMON----------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STTR')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LIBPTR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,55)NCTEXT,MAXSYM
   55   FORMAT('NCTEXT,MAXSYM = ',2I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,56)(ICTEXT(I),I=1,MIN(NCTEXT,25))
   56   FORMAT('(ICTEXT(I),I=1,NCTEXT) = ',25A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,61)ICASE
   61   FORMAT('ICASE = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,79)IBUGG3,ISUBRO
   79   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      CALL DPCONA(92,IBASLC)
      NCTEX2=0
      NSKIP=0
C
      DO1000I=1,NCTEXT
C
        IF(NSKIP.GT.0)THEN
          NSKIP=NSKIP-1
          GOTO1000
        ENDIF
C
        IC5=' '
        IC6=' '
        IF(I.LE.NCTEXT)IC1=ICTEXT(I)(1:1)
        IF(I+1.LE.NCTEXT)IC2=ICTEXT(I+1)(1:1)
        IF(I+2.LE.NCTEXT)IC3=ICTEXT(I+2)(1:1)
        IF(I+3.LE.NCTEXT)IC4=ICTEXT(I+3)(1:1)
        IF(I+4.LE.NCTEXT)IC5=ICTEXT(I+4)(1:1)
        IF(I+5.LE.NCTEXT)IC6=ICTEXT(I+5)(1:1)
        CALL DPCOAN(IC1,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC1)
        CALL DPCOAN(IC2,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC2)
        CALL DPCOAN(IC3,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC3)
        CALL DPCOAN(IC4,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC4)
        CALL DPCOAN(IC5,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC5)
        CALL DPCOAN(IC6,IJUNK)
        IF(IJUNK.GE.97 .AND. IJUNK.LE.122)CALL DPCONA(IJUNK-32,IC6)
C
C       STEP 1: CHECK FOR SUBSCRIPT
C
        IF(IC1.EQ.'S' .AND. IC2.EQ.'U' .AND. IC3.EQ.'B' .AND.
     1     IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='s'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='b'
          ILASTT=I+4
          NSKIP=4
          IFONTT=1
          ASIZET=0.0
          OFFT=0.0
          GOTO1000
C
C
C       STEP 2: CHECK FOR SUPERSCRIPT
C
        ELSEIF(IC1.EQ.'S' .AND. IC2.EQ.'U' .AND. IC3.EQ.'P' .AND.
     1     IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='s'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='p'
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
C       STEP 3: CHECK FOR UNSUBSCRIPT
C
        ELSEIF(IC1.EQ.'U' .AND. IC2.EQ.'N' .AND. IC3.EQ.'S' .AND.
     1     IC4.EQ.'B' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='e'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='b'
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
C       STEP 4: CHECK FOR UNSUPERSCRIPT
C
        ELSEIF(IC1.EQ.'U' .AND. IC2.EQ.'N' .AND. IC3.EQ.'S' .AND.
     1     IC4.EQ.'P' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='e'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='p'
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
C       STEP 5: CHECK FOR GREEK CHARACTERS.  IN THIS CASE, WE NEED
C               TO CONVERT TO APPROPRIATE CHARACTER AND SET THE
C               FONT TO THE SYMBOL FONT.  ALSO, WE CREATE A NEW
C               SUBSTRING THAT CONTAINS JUST A SINGLE CHARACTER
C               (THE REMAINING CHARACTERS ARE SET TO BLANKS).
C
        ELSEIF(IC1.EQ.'A' .AND. IC2.EQ.'L' .AND. IC3.EQ.'P' .AND.
     1         IC4.EQ.'H' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='A'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='a'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'A')ICTEX2(NCTEX2)='A'
            IF(ICTEXT(I).EQ.'a')ICTEX2(NCTEX2)='a'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'B' .AND. IC2.EQ.'E' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='B'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='b'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'B')ICTEX2(NCTEX2)='B'
            IF(ICTEXT(I).EQ.'b')ICTEX2(NCTEX2)='b'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'C' .AND. IC2.EQ.'H' .AND. IC3.EQ.'I' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='C'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='c'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'C')ICTEX2(NCTEX2)='C'
            IF(ICTEXT(I).EQ.'c')ICTEX2(NCTEX2)='c'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'D' .AND. IC2.EQ.'E' .AND. IC3.EQ.'L' .AND.
     1         IC4.EQ.'T' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='D'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='d'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'D')ICTEX2(NCTEX2)='D'
            IF(ICTEXT(I).EQ.'d')ICTEX2(NCTEX2)='d'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'E' .AND. IC2.EQ.'P' .AND. IC3.EQ.'S' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='E'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='e'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'E')ICTEX2(NCTEX2)='E'
            IF(ICTEXT(I).EQ.'e')ICTEX2(NCTEX2)='e'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'P' .AND. IC2.EQ.'H' .AND. IC3.EQ.'I' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='F'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='f'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'F')ICTEX2(NCTEX2)='F'
            IF(ICTEXT(I).EQ.'f')ICTEX2(NCTEX2)='f'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'G' .AND. IC2.EQ.'A' .AND. IC3.EQ.'M' .AND.
     1         IC4.EQ.'M' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='G'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='g'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'G')ICTEX2(NCTEX2)='G'
            IF(ICTEXT(I).EQ.'g')ICTEX2(NCTEX2)='g'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'E' .AND. IC2.EQ.'T' .AND. IC3.EQ.'A' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='H'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='h'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'H')ICTEX2(NCTEX2)='H'
            IF(ICTEXT(I).EQ.'h')ICTEX2(NCTEX2)='h'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'I' .AND. IC2.EQ.'O' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='I'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='i'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'I')ICTEX2(NCTEX2)='I'
            IF(ICTEXT(I).EQ.'i')ICTEX2(NCTEX2)='i'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'K' .AND. IC2.EQ.'A' .AND. IC3.EQ.'P' .AND.
     1         IC4.EQ.'P' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='K'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='k'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'K')ICTEX2(NCTEX2)='K'
            IF(ICTEXT(I).EQ.'k')ICTEX2(NCTEX2)='k'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'L' .AND. IC2.EQ.'A' .AND. IC3.EQ.'M' .AND.
     1         IC4.EQ.'B' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='L'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='l'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'L')ICTEX2(NCTEX2)='L'
            IF(ICTEXT(I).EQ.'l')ICTEX2(NCTEX2)='l'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'M' .AND. IC2.EQ.'U' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='M'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='m'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'M')ICTEX2(NCTEX2)='M'
            IF(ICTEXT(I).EQ.'m')ICTEX2(NCTEX2)='m'
          ENDIF
C
          ILASTT=I+3
          NSKIP=3
          GOTO1000
C
        ELSEIF(IC1.EQ.'N' .AND. IC2.EQ.'U' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='N'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='n'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'N')ICTEX2(NCTEX2)='N'
            IF(ICTEXT(I).EQ.'n')ICTEX2(NCTEX2)='n'
          ENDIF
C
          ILASTT=I+3
          NSKIP=3
          GOTO1000
C
        ELSEIF(IC1.EQ.'O' .AND. IC2.EQ.'M' .AND. IC3.EQ.'I' .AND.
     1         IC4.EQ.'C' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='O'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='o'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'O')ICTEX2(NCTEX2)='O'
            IF(ICTEXT(I).EQ.'o')ICTEX2(NCTEX2)='o'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'P' .AND. IC2.EQ.'I' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='P'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='p'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'P')ICTEX2(NCTEX2)='P'
            IF(ICTEXT(I).EQ.'p')ICTEX2(NCTEX2)='p'
          ENDIF
C
          ILASTT=I+3
          NSKIP=3
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'H' .AND. IC3.EQ.'E' .AND.
     1         IC4.EQ.'T' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='Q'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='q'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'Q')ICTEX2(NCTEX2)='Q'
            IF(ICTEXT(I).EQ.'q')ICTEX2(NCTEX2)='q'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'R' .AND. IC2.EQ.'H' .AND. IC3.EQ.'O' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='R'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='r'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'R')ICTEX2(NCTEX2)='R'
            IF(ICTEXT(I).EQ.'r')ICTEX2(NCTEX2)='r'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'S' .AND. IC2.EQ.'I' .AND. IC3.EQ.'G' .AND.
     1         IC4.EQ.'M' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='S'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='s'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'S')ICTEX2(NCTEX2)='S'
            IF(ICTEXT(I).EQ.'s')ICTEX2(NCTEX2)='s'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'A' .AND. IC3.EQ.'U' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='T'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='t'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'T')ICTEX2(NCTEX2)='T'
            IF(ICTEXT(I).EQ.'t')ICTEX2(NCTEX2)='t'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'U' .AND. IC2.EQ.'P' .AND. IC3.EQ.'S' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='U'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='u'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'U')ICTEX2(NCTEX2)='U'
            IF(ICTEXT(I).EQ.'u')ICTEX2(NCTEX2)='u'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'O' .AND. IC2.EQ.'M' .AND. IC3.EQ.'E' .AND.
     1         IC4.EQ.'G' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='W'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='w'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'W')ICTEX2(NCTEX2)='W'
            IF(ICTEXT(I).EQ.'w')ICTEX2(NCTEX2)='w'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'X' .AND. IC2.EQ.'I' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='X'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='x'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'X')ICTEX2(NCTEX2)='X'
            IF(ICTEXT(I).EQ.'x')ICTEX2(NCTEX2)='x'
          ENDIF
C
          ILASTT=I+3
          NSKIP=3
          GOTO1000
C
        ELSEIF(IC1.EQ.'P' .AND. IC2.EQ.'S' .AND. IC3.EQ.'I' .AND.
     1         IC4.EQ.'(' .AND. IC5.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='Y'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='y'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'Y')ICTEX2(NCTEX2)='Y'
            IF(ICTEXT(I).EQ.'y')ICTEX2(NCTEX2)='y'
          ENDIF
C
          ILASTT=I+4
          NSKIP=4
          GOTO1000
C
        ELSEIF(IC1.EQ.'Z' .AND. IC2.EQ.'E' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          IF(ICASE.EQ.'UPPE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='Z'
          ELSEIF(ICASE.EQ.'LOWE')THEN
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='z'
          ELSE
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)=IBASLC
            NCTEX2=NCTEX2+1
            ICTEX2(NCTEX2)='*'
            NCTEX2=NCTEX2+1
            IF(ICTEXT(I).EQ.'Z')ICTEX2(NCTEX2)='Z'
            IF(ICTEXT(I).EQ.'z')ICTEX2(NCTEX2)='z'
          ENDIF
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
C       STEP 5: CHECK FOR CERTAIN SPECIAL CHARACTERS AND MATHEMATICAL
C               SYMBOLS.  BASICALLY SUPPORT THOSE THAT ARE SUPPORTED
C               IN THE POSTSCRIPT SYMBOL FONT.
C
        ELSEIF(IC1.EQ.'I' .AND. IC2.EQ.'N' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'E' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='i'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='s'
C
          ILASTT=I+5
          NSKIP=5
          IFONTT=1
          ASIZET=0.0
          OFFT=0.0
          GOTO1000
C
        ELSEIF(IC1.EQ.'S' .AND. IC2.EQ.'U' .AND. IC3.EQ.'M' .AND.
     1         IC4.EQ.'M' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='S'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='U'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'P' .AND. IC2.EQ.'R' .AND. IC3.EQ.'O' .AND.
     1         IC4.EQ.'D' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='P'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='R'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'I' .AND. IC2.EQ.'N' .AND. IC3.EQ.'F' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='i'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='f'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'D' .AND. IC2.EQ.'O' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'P' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='m'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='d'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'D' .AND. IC2.EQ.'I' .AND. IC3.EQ.'V' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='d'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='i'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'L' .AND. IC2.EQ.'T' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='<'
C
          ILASTT=I+3
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'G' .AND. IC2.EQ.'T' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='>'
C
          ILASTT=I+3
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'L' .AND. IC2.EQ.'T' .AND. IC3.EQ.'E' .AND.
     1         IC4.EQ.'Q' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='<'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='='
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'G' .AND. IC2.EQ.'T' .AND. IC3.EQ.'E' .AND.
     1         IC4.EQ.'Q' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='>'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='='
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'N' .AND. IC2.EQ.'O' .AND. IC3.EQ.'T' .AND.
     1         IC4.EQ.'=' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='!'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='='
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'+' .AND. IC2.EQ.'-' .AND.
     1         IC3.EQ.'(' .AND. IC4.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='+'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='-'
C
          ILASTT=I+3
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'I' .AND. IC3.EQ.'L' .AND.
     1         IC4.EQ.'D' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=CHAR(126)
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'E' .AND. IC2.EQ.'Q' .AND. IC3.EQ.'U' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='='
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='='
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'V' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='p'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='t'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'C' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='^'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'I' .AND. IC3.EQ.'M' .AND.
     1         IC4.EQ.'E' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='m'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='u'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'P' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'T' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='p'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='d'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'R' .AND. IC2.EQ.'A' .AND. IC3.EQ.'D' .AND.
     1         IC4.EQ.'I' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='s'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='r'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'S' .AND. IC2.EQ.'U' .AND. IC3.EQ.'B' .AND.
     1         IC4.EQ.'S' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='S'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='B'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'S' .AND. IC2.EQ.'U' .AND. IC3.EQ.'P' .AND.
     1         IC4.EQ.'E' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='S'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='S'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'H' .AND. IC3.EQ.'E' .AND.
     1         IC4.EQ.'X' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='t'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='e'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'T' .AND. IC2.EQ.'H' .AND. IC3.EQ.'F' .AND.
     1         IC4.EQ.'O' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='t'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='f'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'L' .AND. IC2.EQ.'B' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='l'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='c'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'R' .AND. IC2.EQ.'B' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'A' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='r'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='c'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'L' .AND. IC2.EQ.'C' .AND. IC3.EQ.'B' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='l'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='t'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'R' .AND. IC2.EQ.'C' .AND. IC3.EQ.'B' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='R'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='T'
          ICTEXT(I)=CHAR(125)
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'R' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='-'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='>'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'U' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='u'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='a'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'D' .AND. IC2.EQ.'A' .AND. IC3.EQ.'R' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='d'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='a'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'H' .AND. IC2.EQ.'B' .AND. IC3.EQ.'A' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='h'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='b'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ELSEIF(IC1.EQ.'D' .AND. IC2.EQ.'E' .AND. IC3.EQ.'G' .AND.
     1         IC4.EQ.'R' .AND. IC5.EQ.'(' .AND. IC6.EQ.')'
     1    )THEN
C
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)=IBASLC
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='d'
          NCTEX2=NCTEX2+1
          ICTEX2(NCTEX2)='e'
C
          ILASTT=I+5
          NSKIP=5
          GOTO1000
C
        ENDIF
        NCTEX2=NCTEX2+1
        ICTEX2(NCTEX2)=ICTEXT(I)
C
 1000 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STTR')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LIBPTR--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)NCTEX2
 9013   FORMAT('NCTEX2 = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)(ICTEX2(I)(1:1),I=1,MIN(80,NCTEX2))
 9015   FORMAT('ICTEX2 = ',80A1)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LIMITS( A, B, INFIN, LOWER, UPPER )
      DOUBLE PRECISION A, B, LOWER, UPPER, PHI
      INTEGER INFIN
      LOWER = 0.0D0
      UPPER = 1.0D0
      IF ( INFIN .GE. 0 ) THEN
         IF ( INFIN .NE. 0 ) LOWER = PHI(A)
         IF ( INFIN .NE. 1 ) UPPER = PHI(B)
      ENDIF
C
      RETURN
      END
      SUBROUTINE LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED,RES,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES WEIGHTED LINEAR FIT
C              OF THE DATA IN LOCATIONS I1 TO I2
C              OF THE HORIZONTALLY SORTED DATA
C              IN VARIABLES XS(.) AND YS(.).
C              AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES
C              AND RESIDUALS FOR ELEMENTS I3 TO I4 OF XS(.).
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/2
C     ORIGINAL VERSION--FEBRUARY   1988
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION XS(*)
      DIMENSION YS(*)
      DIMENSION WH(*)
      DIMENSION WV(*)
      DIMENSION PRED(*)
      DIMENSION RES(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINE'
      ISUBN2='AR  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NEAR')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)IT,I1,I2,N,I3,I4
   53 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,54)XMAXHF
   54 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO63
      DO61I=1,N
      WRITE(ICOUT,62)I,XS(I),YS(I),WH(I),WV(I)
   62 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
   61 CONTINUE
   63 CONTINUE
   90 CONTINUE
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.GE.1)GOTO119
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,111)
  111 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,112)
  112 FORMAT('      THE INPUT FULL SAMPLE SIZE,')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,113)
  113 FORMAT('      FOR WHICH LOWESS HORIZONTAL WEIGHTS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,114)
  114 FORMAT('      ARE TO BE COMPUTED, MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,115)
  115 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,116)N
  116 FORMAT('      THE FULL SAMPLE SIZE N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  119 CONTINUE
C
      IF(IT.GE.1)GOTO129
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
  121 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,122)
  122 FORMAT('      THE INPUT TARGET OBSERVATION INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,123)
  123 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,124)N
  124 FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVE).')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,125)
  125 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,126)IT
  126 FORMAT('      THE TARGET OBSERVATION INDEX IT = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  129 CONTINUE
C
      IF(I1.LE.I2)GOTO139
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,131)
  131 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,132)
  132 FORMAT('      THE  NEIGHBORHOOD LOWER INDEX')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,133)
  133 FORMAT('      FOR WHICH A LOWESS IS TO BE CARRIED OUT')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,134)
  134 FORMAT('      MUST NOT EXCEED THE NEIGHBORHOOD UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,135)
  135 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)IT
  136 FORMAT('      THE NEIGHBORHOOD INDICES I1 AND I2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  139 CONTINUE
C
      IF(I3.LE.I4)GOTO149
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,141)
  141 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,142)
  142 FORMAT('      THE  DESIRED LOWER INDEX FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,143)
  143 FORMAT('      LOWESS PREDICTED VALUES ARE TO BE COMPUTED')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,144)
  144 FORMAT('      MUST NOT EXCEED THE DESIRED UPPER INDEX.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,145)
  145 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,146)I3,I4
  146 FORMAT('      THE DESIRED INDICES I3 AND I4 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  149 CONTINUE
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES WEIGHTED       **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      IF(XMAXHF.LE.0.0)GOTO1200
      GOTO1300
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  TREAT THE CASE WHEN ALL HORIXONTAL AXIS  **
C               **  VALUES ARE IDENTICAL                     **
C               ***********************************************
C
 1200 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMY=0.0
      SUMW=0.0
      DO1210I=I1,I2
      W=WH(I)*WV(I)
      SUMY=SUMY+W*YS(I)
      SUMW=SUMW+W
 1210 CONTINUE
      YBAR=SUMY/SUMW
C
      ALPHA=YBAR
      BETA=0.0
C
      DO1220I=I3,I4
      PRED(I)=ALPHA
      RES(I)=YS(I)-PRED(I)
 1220 CONTINUE
C
      GOTO9000
C               *********************************************
C               **  STEP 13--                              **
C               **  TREAT THE CASE WHEN AT LEAST 1         **
C               **  HORIZONTAL AXIS VALUE IS DIFFERENT     **
C               *********************************************
C
 1300 CONTINUE
      NN=I2-I1+1
      ANN=NN
C
      SUMW=0.0
      DO1310I=I1,I2
      W=WH(I)*WV(I)
      SUMW=SUMW+W
 1310 CONTINUE
C
      IF(SUMW.GT.0.0)GOTO1319
      WRITE(ICOUT,1311)
 1311 FORMAT('***** ERROR IN LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1312)
 1312 FORMAT('      SUM OF WEIGHTS = 0')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1313)IT,I1,I2,N
 1313 FORMAT('IT,I1,I2,N = ',4I8)
      CALL DPWRST('XXX','BUG ')
      DO1314I=I1,I2
      WPROD=WH(I)*WV(I)
      WRITE(ICOUT,1315)I,WH(I),WV(I),WPROD
 1315 FORMAT('I,WH(I),WV(I),WPROD = ',I8,3E15.7)
      CALL DPWRST('XXX','BUG ')
 1314 CONTINUE
      IERROR='YES'
      GOTO9000
 1319 CONTINUE
C
      SUMX=0.0
      SUMY=0.0
      SUMW=0.0
      DO1320I=I1,I2
      W=WH(I)*WV(I)
      SUMX=SUMX+W*XS(I)
      SUMY=SUMY+W*YS(I)
      SUMW=SUMW+W
 1320 CONTINUE
      XBAR=SUMX/SUMW
      YBAR=SUMY/SUMW
C
      SUM1=0.0
      SUM2=0.0
      DO1330I=I1,I2
      W=WH(I)*WV(I)
      DELX=XS(I)-XBAR
      DELY=YS(I)-YBAR
      SUM1=SUM1+W*DELX*DELY
      SUM2=SUM2+W*DELX**2
 1330 CONTINUE
      BETA=0.0
      IF(SUM2.NE.0.0)BETA=SUM1/SUM2
      ALPHA=YBAR-BETA*XBAR
C
      DO1340I=I3,I4
      PRED(I)=ALPHA+BETA*XS(I)
      RES(I)=YS(I)-PRED(I)
 1340 CONTINUE
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NEAR')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LINEAR--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IT,I1,I2,N,I3,I4
 9013 FORMAT('IT,I1,I2,N,I3,I4 = ',6I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9014)XMAXHF
 9014 FORMAT('XMAXHF = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9033
      DO9031I=I1,I2
      WRITE(ICOUT,9032)I,XS(I),YS(I),WH(I),WV(I)
 9032 FORMAT('I,XS(I),YS(I),WH(I),WV(I) = ',I8,4E15.7)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9033 CONTINUE
      WRITE(ICOUT,9040)ALPHA,BETA
 9040 FORMAT('ALPHA,BETA = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9043
      DO9041I=I3,I4
      WRITE(ICOUT,9042)I,PRED(I),RES(I)
 9042 FORMAT('I,PRED(I),RES(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9041 CONTINUE
 9043 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LINFIT(Y,X,N,
     1                  ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,
     1                  CCALBE,
     1                  ISUBRO,IBUGA3,IERROR)
CCCCC THE ABOVE ARGUMENT LIST WAS AUGMENTED    DECEMBER 1993
C
C     PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT
C              OF THE DATA IN Y(.) AND X(.).
C              AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES,
C              RESIDUALS, RESIDUAL STANDARD DEVIATION,
C              RESIDUAL DEGREES OF FREEDOM.
C              ALSO COMPUTE THE CORRELATION COEFFICIENT.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--88/3
C     ORIGINAL VERSION--MARCH      1988
C     UPDATED         --DECEMBER   1993  SDA0, SDA1, CORR01
C     UPDATED         --DECEMBER   1993  PROTECT RESSD/DF
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
CCCCC DIMENSION PRED(*)  DUE TO COMPLEXITIES WITH DP'S PRED & RES
CCCCC                    AND TEMP STORAGE
CCCCC DIMENSION RES(*)   DUE TO COMPLEXITIES WITH DP'S PRED & RES
CCCCC                    AND TEMP STORAGE
CCCCC DIMENSION SDPRED(*)
CCCCC DIMENSION SDRESV(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINF'
      ISUBN2='IT  '
      IERROR='NO'
C
      AN=N
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LINFIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR,N
   52   FORMAT('ISUBRO,IBUGA3,IERROR,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GE.1)THEN
          DO61I=1,N
            WRITE(ICOUT,62)I,Y(I),X(I)
   62       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
   61     CONTINUE
        ENDIF
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LINFIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT SAMPLE SIZE MUST BE AT LEAST 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)N
  116   FORMAT('      THE SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES                **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      SUMX=0.0
      SUMY=0.0
      DO1120I=1,N
         SUMX=SUMX+X(I)
         SUMY=SUMY+Y(I)
 1120 CONTINUE
      XBAR=SUMX/AN
      YBAR=SUMY/AN
C
      SUMXX=0.0
      SUMYY=0.0
      SUMXY=0.0
      DO1130I=1,N
         DELX=X(I)-XBAR
         DELY=Y(I)-YBAR
         SUMXX=SUMXX+DELX**2
         SUMYY=SUMYY+DELY**2
         SUMXY=SUMXY+DELX*DELY
 1130 CONTINUE
      BETA=0.0
      IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX
      ALPHA=YBAR-BETA*XBAR
C
CCCCC DO1140I=1,N
CCCCC    PRED(I)=ALPHA+BETA*X(I)
CCCCC    RES(I)=Y(I)-PRED(I)
C1140 CONTINUE
C
      XRESDF=N-2
      SUM=0.0
      DO1150I=1,N
         SUM=SUM+(Y(I)-(ALPHA+BETA*X(I)))**2
 1150 CONTINUE
      RESVAR=0.0
      IF(XRESDF.GT.0.0)RESVAR=SUM/XRESDF
      XRESSD=0.0
      IF(RESVAR.GT.0.0)XRESSD=SQRT(RESVAR)
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE CORRELATION COEFFICIENT (X,Y)    **
C               ***********************************************
C
      ADENOM=0.0
      IF(SUMXX.GT.0.0.AND.SUMYY.GT.0.0)ADENOM=SQRT(SUMXX)*SQRT(SUMYY)
      CCXY=0.0
      IF(ADENOM.GT.0.0)CCXY=SUMXY/ADENOM
C
C               ************************************
C               **  STEP 13--                     **
C               **  COMPUTE SD OF ESTIMATES       **
C               **  AND CORR(ESTIMATES)           **
C               ************************************
C
      SDALPH=0.0
      SDBETA=0.0
      CCALBE=0.0
      SUM=0.0
      DO1200I=1,N
         SUM=SUM+X(I)*X(I)
 1200 CONTINUE
      IF(SUMXX.GT.0.0)THEN
         SDALPH=XRESSD*SQRT(SUM/(AN*SUMXX))
         SDBETA=XRESSD*SQRT(1.0/SUMXX)
      ENDIF
      IF(SUM.GT.0.0)THEN
         ANUM=(-XBAR)
         ADENOM=SQRT(SUM/AN)
         CCALBE=ANUM/ADENOM
      ENDIF
C
C               *******************************
C               **  STEP 14--                **
C               **  COMPUTE SD(PRED VALUES)  **
C               *******************************
C
CCCCC DO1300I=1,N
CCCCC    TERM1=1.0/AN
CCCCC    TERM2=0.0
CCCCC    IF(SUMXX.GT.0.0)TERM2=((X(I)-XBAR)**2)/SUMXX
CCCCC    SDPRED(I)=SDRES*SQRT(TERM1+TERM2)
CCCCC    SDRESV(I)=SDRES*SQRT(1.0-TERM1-TERM2)
C1300 CONTINUE
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LINFIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9031)IERROR,YBAR,XBAR
 9031   FORMAT('IERROR,YBAR,XBAR = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY
 9032   FORMAT('SUMXX,SUMYY,SUMXY = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9036)ALPHA,BETA,XRESSD,XRESDF
 9036   FORMAT('ALPHA,BETA,XRESSD,XRESDF = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9038)ADENOM,CCXY
 9038 FORMAT('ADENOM,CCXY = ',2E15.7)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9039)ADENOM,CCXY,SDALPH,SDBETA,CCALBE
 9039   FORMAT('ADENOM,CCXY,SDALPH,SDBETA,CCALBE = ',5G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LINFI2(Y,X,N,ALPHA,BETA,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT
C              OF THE DATA IN Y(.) AND X(.).
C              THIS IS A MODIFIED VERSION OF LINFIT.  THE
C              DISTINCTION IS THAT THIS VERSION HAS BEEN PRUNED
C              DOWN TO ONLY GENERATE THE PARAMETER ESTIMATES
C              (USED BY PPCC PLOT FOR ESTIMATES OF LOCATION AND
C              SCALE).
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004/5
C     ORIGINAL VERSION--MAY        2004
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINF'
      ISUBN2='I2  '
      IERROR='NO'
C
      AN=N
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFI2')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LINFI2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR,N
   52   FORMAT('ISUBRO,IBUGA3,IERROR,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GE.1)THEN
          DO61I=1,N
            WRITE(ICOUT,62)I,Y(I),X(I)
   62       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
   61     CONTINUE
        ENDIF
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        ALPHA=0.0
        BETA=1.0
        GOTO9000
      ENDIF
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES                **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      SUMX=0.0
      SUMY=0.0
      DO1120I=1,N
         SUMX=SUMX+X(I)
         SUMY=SUMY+Y(I)
 1120 CONTINUE
      XBAR=SUMX/AN
      YBAR=SUMY/AN
C
      SUMXX=0.0
      SUMYY=0.0
      SUMXY=0.0
      DO1130I=1,N
         DELX=X(I)-XBAR
         DELY=Y(I)-YBAR
         SUMXX=SUMXX+DELX**2
         SUMYY=SUMYY+DELY**2
         SUMXY=SUMXY+DELX*DELY
 1130 CONTINUE
      BETA=0.0
      IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX
      ALPHA=YBAR-BETA*XBAR
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFI2')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LINFI2--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9031)YBAR,XBAR,ALPHA,BETA
 9031   FORMAT('YBAR,XBAR,ALPHA,BETA = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY
 9032   FORMAT('SUMXX,SUMYY,SUMXY = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LINFI3(Y,X,N,
     1                  ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,
     1                  CCALBE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT OF THE DATA IN Y(.)
C              AND X(.).  AFTER THE FIT IS DONE, COMPUTE PREDICTED
C              VALUES, RESIDUALS, RESIDUAL STANDARD DEVIATION, RESIDUAL
C              DEGREES OF FREEDOM, AND THE CORRELATION COEFFICIENT.
C
C              THIS IS A COPY OF LINFIT THAT IMPLEMENTS THE FIT WITH
C              NO INTERCEPT TERM.
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2016/11
C     ORIGINAL VERSION--NOVEMBER   2016
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINF'
      ISUBN2='IT  '
      IERROR='NO'
C
      AN=N
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFI3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LINFI3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR,N
   52   FORMAT('ISUBRO,IBUGA3,IERROR,N = ',3(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        IF(N.GE.1)THEN
          DO61I=1,N
            WRITE(ICOUT,62)I,Y(I),X(I)
   62       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
            CALL DPWRST('XXX','BUG ')
   61     CONTINUE
        ENDIF
      ENDIF
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LINFI3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT SAMPLE SIZE MUST BE AT LEAST 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,116)N
  116   FORMAT('      THE SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ***********************************************
C               **  STEP 11--                                **
C               **  CARRY OUT A LEAST SQUARES                **
C               **  LINEAR FIT                               **
C               ***********************************************
C
      SUMX=0.0
      SUMY=0.0
      DO1120I=1,N
         SUMX=SUMX+X(I)
         SUMY=SUMY+Y(I)
 1120 CONTINUE
      XBAR=SUMX/AN
      YBAR=SUMY/AN
C
      SUMXX=0.0
      SUMYY=0.0
      SUMXY=0.0
      DO1130I=1,N
         DELX=X(I)-XBAR
         DELY=Y(I)-YBAR
         SUMXX=SUMXX+DELX**2
         SUMYY=SUMYY+DELY**2
         SUMXY=SUMXY+DELX*DELY
 1130 CONTINUE
      BETA=0.0
      IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX
      ALPHA=0.0
C
      XRESDF=N-1
      SUM=0.0
      DO1150I=1,N
         SUM=SUM+(Y(I)-(ALPHA+BETA*X(I)))**2
 1150 CONTINUE
      RESVAR=0.0
      IF(XRESDF.GT.0.0)RESVAR=SUM/XRESDF
      XRESSD=0.0
      IF(RESVAR.GT.0.0)XRESSD=SQRT(RESVAR)
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE CORRELATION COEFFICIENT (X,Y)    **
C               ***********************************************
C
      ADENOM=0.0
      IF(SUMXX.GT.0.0.AND.SUMYY.GT.0.0)ADENOM=SQRT(SUMXX)*SQRT(SUMYY)
      CCXY=0.0
      IF(ADENOM.GT.0.0)CCXY=SUMXY/ADENOM
C
C               ************************************
C               **  STEP 13--                     **
C               **  COMPUTE SD OF ESTIMATES       **
C               **  AND CORR(ESTIMATES)           **
C               ************************************
C
      SDALPH=0.0
      SDBETA=0.0
      CCALBE=0.0
      SUM=0.0
      DO1200I=1,N
         SUM=SUM+X(I)*X(I)
 1200 CONTINUE
      IF(SUMXX.GT.0.0)THEN
         SDBETA=XRESSD*SQRT(1.0/SUMXX)
      ENDIF
      IF(SUM.GT.0.0)THEN
         ANUM=(-XBAR)
         ADENOM=SQRT(SUM/AN)
         CCALBE=ANUM/ADENOM
      ENDIF
C
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFI3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LINFI3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9031)IERROR,YBAR,XBAR
 9031   FORMAT('IERROR,YBAR,XBAR = ',A4,2X,2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY
 9032   FORMAT('SUMXX,SUMYY,SUMXY = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9036)ALPHA,BETA,XRESSD,XRESDF
 9036   FORMAT('ALPHA,BETA,XRESSD,XRESDF = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9038)ADENOM,CCXY
 9038 FORMAT('ADENOM,CCXY = ',2G15.7)
      CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9039)ADENOM,CCXY,SDALPH,SDBETA,CCALBE
 9039   FORMAT('ADENOM,CCXY,SDALPH,SDBETA,CCALBE = ',5G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LININT(Y,X,N,X2,N2,IWRITE,Y2,
     1                  YTEMP,YDIST,XDIST,
     1                  IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--ALAN HECKERT
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--94/5
C     ORIGINAL VERSION--MAY       1994.
C     UPDATED         --JULY      2019. MOVE CREATION OF SCRATCH
C                                       STORAGE TO CALLING ROUTINE
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
      DIMENSION YTEMP(*)
      DIMENSION YDIST(*)
      DIMENSION XDIST(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINI'
      ISUBN2='NT  '
      IERROR='NO'
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NINT')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LININT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)N,N2
   52   FORMAT('N,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,Y(I),X(I)
   56     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
        DO65I=1,N2
          WRITE(ICOUT,66)I,X2(I)
   66     FORMAT('I,X2(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   65   CONTINUE
      ENDIF
C
C               ****************************************
C               **  STEP 11--                         **
C               **  SORT THE INPUT DATA ACCORDING     **
C               **  TO THE HORIZONTAL AXIS VARIABLE   **
C               ****************************************
C
      CALL SORTC(X,Y,N,X,Y)
C
C               *******************************************************
C               **  STEP 12--                                        **
C               **  DETERMINE THE NUMBER OF DISTINCT X VALUES        **
C               *******************************************************
C
      ISTEPN='12'
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NINT')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NDIST=0
      DO1210I=1,N
        IF(NDIST.EQ.0)GOTO1220
        DO1215I2=1,NDIST
          IF(X(I).EQ.XDIST(I2))GOTO1210
 1215   CONTINUE
 1220   CONTINUE
        NDIST=NDIST+1
        XDIST(NDIST)=X(I)
 1210 CONTINUE
C
      CALL SORT(XDIST,NDIST,XDIST)
C
C               *****************************************************
C               **  STEP 13--                                      **
C               **  IF ALL DISTINCT (THAT IS, NO REPLICATION),     **
C               **  (THAT IS, HAVE NO REPLICATION),                **
C               **  THEN COPY OVER Y VALUES.                       **
C               **  IF NOT ALL DISTINCT                            **
C               **  (THAT IS, HAVE SOME REPLICATION),              **
C               **  THEN COMPUTE A MEAN VALUE OVER THE REPLICATES  **
C               **  AND TREAT THAT AS THE COMMON VALUE.            **
C               **  THE CORE OF THE INTERPOLATION CODE             **
C               **  IS EXPECTING SORTED, DISTINCT X VALUES.        **
C               *****************************************************
C
      IF(NDIST.EQ.N)THEN
        DO1311K=1,NDIST
          YDIST(K)=Y(K)
 1311   CONTINUE
      ELSE
        DO1321K=1,NDIST
          TAG=XDIST(K)
          J=0
          DO1322I=1,N
            IF(X(I).EQ.TAG)THEN
              J=J+1
              YTEMP(J)=Y(I)
            ENDIF
 1322     CONTINUE
          NI=J
          CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR)
          YDIST(K)=YMEAN
 1321   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      CALL LININ2(YDIST,XDIST,NDIST,X2,N2,Y2,IBUGG3,ISUBRO,IERROR)
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NINT')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LININT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9051)NDIST
 9051   FORMAT('NDIST = ',I8)
        CALL DPWRST('XXX','BUG ')
        DO9052I=1,NDIST
          WRITE(ICOUT,9053)I,XDIST(I),YDIST(I)
 9053     FORMAT('I,XDIST(I),YDIST(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
 9052   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE LININ2(Y,X,N,X2,N2,Y2,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                VERTICAL AXIS DATA POINTS.
C                     --X      = SINGLE PRECISION VARIABLE
C                                CONTAINING THE ORIGINAL
C                                HORIZONTAL AXIS DATA POINTS.
C                     --X2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINTS.
C     OUTPUT ARGUMENTS--Y2     = SINGLE PRECISION VARIABLE
C                                CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.)
C           BEING IDENTICAL TO THE INPUT VECTOR Y(.)
C     NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT
C           DATA IS ALREADY SORTED ACCORDING TO THE
C           HORIZONTAL AXIS VARIABLE.
C           SUCH SORTING IS DOEN HEREIN.
C     CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN
C              AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE
C              THAN UPON ENTERING THIS SUBROUTINE.
C     WRITTEN BY--ALAN HECKERT
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--94/5
C     ORIGINAL VERSION--MAY L     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION X2(*)
      DIMENSION Y2(*)
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINI'
      ISUBN2='N2  '
      IERROR='NO'
C
      I2=0
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)N
   52 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N
      WRITE(ICOUT,56)I,Y(I),X(I)
   56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
      WRITE(ICOUT,62)N2
   62 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO65I=1,N2
      WRITE(ICOUT,66)I,X2(I)
   66 FORMAT('I,X2(I) = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
   65 CONTINUE
   90 CONTINUE
C
      NM1=N-1
      NM2=N-2
C
C               ****************************************
C               **  STEP 31--
C               **  COMPUTE INTERPOLATION VALUES
C               ****************************************
C
      DO3100J=1,N2
      XT=X2(J)
      IF(X(1).GT.XT.OR.XT.GT.X(N))GOTO3110
      GOTO3119
C
 3110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3111)
 3111 FORMAT('***** ERROR IN LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3112)
 3112 FORMAT('      AN ATTEMPT WAS MADE TO COMPUTE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3113)
 3113 FORMAT('      A SMOOTHED VALUE BEYOND THE RANGE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3114)
 3114 FORMAT('      OF THE DATA--SUCH EXTRAPOLATION')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3115)
 3115 FORMAT('      IS UNRELIABLE AND NOT PERMITTED.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3116)X(1)
 3116 FORMAT('         SMALLEST DATA POINT X(1)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3117)X(N)
 3117 FORMAT('         LARGEST DATA POINT  X(N)      = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,3118)XT
 3118 FORMAT('         ATTEMPTED EXTRAPOLATION POINT = ',E15.7)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
 3119 CONTINUE
C
      DO3200I=1,N
      I2=I
      IF(X(I).EQ.XT)GOTO3210
      IF(X(I).GT.XT)GOTO3220
 3200 CONTINUE
C
 3210 CONTINUE
      Y2(J)=Y(I2)
      GOTO3100
C
 3220 CONTINUE
      K1=I2-1
      DELX=X(I2)-X(K1)
      DELY=Y(I2)-Y(K1)
      SLOPE=DELY/DELX
      Y2(J)=SLOPE*(XT-X(K1))+Y(K1)
C
 3100 CONTINUE
C
C               ****************************************
C               **  STEP 41--
C               **  IF CALLED FOR,
C               **  WRITE OUT INTERPOLATION VALUES
C               ****************************************
C
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO4190
      DO4100J=1,N2
      WRITE(ICOUT,4110)X2(J),Y2(J)
      CALL DPWRST('XXX','BUG ')
 4110 FORMAT('X2(J),Y2(J) = ',2E15.7)
 4100 CONTINUE
 4190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LININ2--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)N,N2
 9012 FORMAT('N,N2 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9041)N2
 9041 FORMAT('N2 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO9042I=1,N2
      WRITE(ICOUT,9043)I,X2(I),Y2(I)
 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
 9042 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      REAL FUNCTION LININ3(X1,Y1,X2,Y2,X3,IBUGG3,ISUBRO,IERROR)
C
C     PURPOSE--COMPUTE LINEAR INTERPOLATION FOR PARAMETERS
C              (GENERATE INTERPOLATED POINTS).
C     INPUT  ARGUMENTS--Y1     = SINGLE PRECISION PARAMETER
C                                CONTAINING THE FIRST ORIGINAL
C                                VERTICAL AXIS DATA POINT.
C                     --X1     = SINGLE PRECISION PARAMETER
C                                CONTAINING THE FIRST ORIGINAL
C                                HORIZONTAL AXIS DATA POINT.
C                     --Y2     = SINGLE PRECISION PARAMETER
C                                CONTAINING THE SECOND ORIGINAL
C                                VERTICAL AXIS DATA POINT.
C                     --X2     = SINGLE PRECISION PARAMETER
C                                CONTAINING THE SECOND ORIGINAL
C                                HORIZONTAL AXIS DATA POINT.
C                     --X3     = SINGLE PRECISION PARAMETER
C                                CONTAINING THE DESIRED
C                                HORIZONTAL AXIS INTERPOLATION
C                                POINT.
C     OUTPUT ARGUMENTS--LININ3   CONTAINING THE COMPUTED
C                                VERTICAL AXIS INTERPOLATION
C                                POINTS.
C     WRITTEN BY--ALAN HECKERT
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--2013/8
C     ORIGINAL VERSION--AUGUST    2013.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IBUGG3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
C-----COMMON VARIABLES (GENERAL)--------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LINI'
      ISUBN2='N3  '
      IERROR='NO'
      LININ3=0.0
C
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NIN3')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LININ3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,56)Y1,X1,X2
   56   FORMAT('Y1,X1,X2 = ',3G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               ********************************************
C               **  STEP 14--                             **
C               **  COMPUTE INTERPOLATED VALUES           **
C               ********************************************
C
      IF(X2.LT.X1)THEN
        ATEMP=X2
        X2=X1
        X1=ATEMP
        ATEMP=Y2
        Y2=Y1
        Y1=ATEMP
      ENDIF
C
      IF(X3.LT.X1 .OR. X3.GT.X2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,101)
  101   FORMAT('***** ERROR IN LINEAR INTERPOLATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,103)
  103   FORMAT('      THE POINT TO BE INTERPOLATED IS OUT OF RANGE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,105)X1
  105   FORMAT('      MINIMUM POINT:       ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,107)X2
  107   FORMAT('      MAXIMUM POINT:       ',G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,109)X3
  109   FORMAT('      INTERPOLATION POINT: ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      Y3=Y1 + (Y2-Y1)*(X3-X1)/(X2-X1)
      LININ3=Y3
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NIN3')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LININ3--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,Y3
 9012   FORMAT('IERROR,Y3 = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LKCDF(X,A,B,BETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LAGRANGE KATZ
C              DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE
C              INTEGERS  X >= 0.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;A,B,BETA)=
C                  (A/BETA)/((A/BETA) + (X*B/BETA) + X)*
C                  ((A/BETA)+X*b/BETA+X  X)*
C                  BETA**X*(1-BETA)**((A/BETA)+X*B/BETA)
C                  X = 0, 1, 2, 3, ,...
C                  A > 0, B > -BETA, BETA < 1
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              P(X+1) = {(A+B*(X+1)+BETA*X)/(X+1)}*(1-BETA)**(b/BETA)*
C                       PROD[i=1 to X-1][(1 + b/(a+B*X+BETA*i)]*P(X)
C              WHERE P(0) = (1-BETA)**(A/BETA) AND
C                    P(1) = A*(1-BETA)**(b/BETA)*P(0)
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --A      = THE FIRST SHAPE PARAMETER
C                     --B      = THE SECOND SHAPE PARAMETER
C                     --BETA   = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE DOUBLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION
C             VALUE CDF FOR THE LAGRANGE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS A, B, AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --A > 0, B > -BETA, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--ALAN HECKERT
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/2
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5D0)
      CDF=0.0D0
C
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKCDF IS LESS ',
     1         'THAN 0.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7'.')
        GOTO9000
      ELSEIF(A.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKCDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.GE.1.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKCDF IS GREATER ',
     1         'THAN OR EQUAL TO 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(B.LE.-BETA)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKCDF IS LESS ',
     1         'THAN OR EQUAL TO -(FOURTH ARGUMENT).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
C
C
C     USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE):
C
      CDF=(1.0D0 - BETA)**(A/BETA)
      IF(IX.EQ.0)GOTO9000
C
      DPDF=A*(1.0D0 - BETA)**(B/BETA)*CDF
      CDF=CDF + DPDF
      IF(IX.EQ.1)GOTO9000
C
C     FOR X = 2, USE RELATION:
C
C         p(x+1;a,b,beta)=p(x;a+b,b,beta)*(a+c*x)/(1+x)
C
C     NOTE THAT WE NEED TO REPLACE A WITH A + B IN COMPUTATION
C     OF p(1).
C
      DP0=(1.0D0 - BETA)**((A+B)/BETA)
      DP1=(A+B)*(1.0D0 - BETA)**(B/BETA)*DP0
      DX=1.0D0
      C=A*(B+BETA)/(A+B)
      DPDF=DP1*(A + C*DX)/(1.0 + DX)
      CDF=CDF + DPDF
      IF(IX.EQ.2)GOTO9000
      DPDFSV=DPDF
C
      DTERM1=(B/BETA)*DLOG(1.0D0 - BETA)
      DO100I=3,IX
        DX=DBLE(I)
        DTERM2=DLOG(A + B*DX + BETA*(DX-1.0D0))
        DTERM3=DLOG(DX)
        IF(DPDFSV.LE.0.0D0)THEN
          GOTO9000
        ELSE
          DTERM4=DLOG(DPDFSV)
        ENDIF
C
        DSUM=0.0D0
        DO200J=1,I-2
          DSUM=DSUM + DLOG(1.0D0 + B/
     1         (A + B*(DX-1.0D0) + BETA*DBLE(J)))
  200   CONTINUE
C
        DPDF=DEXP(DTERM1 + DTERM2 - DTERM3 + DTERM4 + DSUM)
        CDF=CDF + DPDF
        DPDFSV=DPDF
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LKPDF(X,A,B,BETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LAGRANGE KATZ
C              DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE
C              INTEGERS  X >= 0.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;A,B,BETA)=
C                  (A/BETA)/((A/BETA) + (X*B/BETA) + X)*
C                  ((A/BETA)+X*b/BETA+X  X)*
C                  BETA**X*(1-BETA)**((A/BETA)+X*B/BETA)
C                  X = 0, 1, 2, 3, ,...
C                  A > 0, B > -BETA, BETA < 1
C
C              THE PROBABILITIES ARE COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              P(X+1) = {(A+B*(X+1)+BETA*X)/(X+1)}*(1-BETA)**(b/BETA)*
C                       PROD[i=1 to X-1][(1 + b/(a+B*X+BETA*i)]*P(X)
C              WHERE P(0) = (1-BETA)**(A/BETA) AND
C                    P(1) = A*(1-BETA)**(b/BETA)*P(0)
C
C     INPUT  ARGUMENTS--X      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGER.
C                     --A      = THE FIRST SHAPE PARAMETER
C                     --B      = THE SECOND SHAPE PARAMETER
C                     --BETA   = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE DOUBLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY FUNCTION
C             VALUE PDF FOR THE LAGRANGE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS A, B, AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER
C                 --A > 0, B > -BETA, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--ALAN HECKERT
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/2
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IX=INT(X+0.5D0)
      PDF=0.0D0
C
      IF(IX.LT.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKPDF IS LESS ',
     1         'THAN 0')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(A.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKPDF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.GE.1.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKPDF IS GREATER ',
     1         'THAN OR EQUAL TO 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(B.LE.-BETA)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKPDF IS LESS ',
     1         'THAN OR EQUAL TO -(FOURTH ARGUMENT).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     ALTHOUGH THE DIRECT COMPUTATION OF THE PDF MIGHT BE
C     MORE EFFICIENT IN SOME CASES, IT IS NOT CLEAR HOW TO
C     HANDLE NEGATIVE VALUES OF BETA (THE DLNGAM FUNCTION IS
C     ONLY IMPLEMENTED FOR POSITIVE ARGUMENTS).  SO IN THE
C     MEANTIME, USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL
C     AND FAMOYE).
C
CCCCC  DX=DBLE(IX)
CCCCC  DTERM1=A/BETA
CCCCC  DTERM2=DX*B/BETA
C
CCCCC  DTERM3=DLOG(DTERM1) - DLOG(DTERM1 + DTERM2 + DX)
CCCCC  DTERM4=DX*DLOG(BETA)
CCCCC  DTERM5=(DTERM1+DTERM2)*DLOG(1.0D0 - BETA)
CCCCC  DTERM6=DLNGAM(DTERM1 + DTERM2 + DX + 1.0D0)
CCCCC  DTERM7=DLNGAM(DTERM1 + DTERM2 + 1.0D0)
CCCCC  DTERM8=DLNGAM(DX + 1.0D0)
CCCCC  DPDF=DTERM3 + DTERM4 + DTERM5 + DTERM6 - DTERM7 - DTERM8
CCCCC  PDF=DEXP(DPDF)
C
      CDF=(1.0D0 - BETA)**(A/BETA)
      IF(IX.EQ.0)THEN
        PDF=CDF
        GOTO9000
      ENDIF
C
      DPDF=A*(1.0D0 - BETA)**(B/BETA)*CDF
      IF(IX.EQ.1)THEN
        PDF=DPDF
        GOTO9000
      ENDIF
      CDF=CDF + DPDF
C
      DPDFSV=DPDF
      DTERM1=(B/BETA)*DLOG(1.0D0 - BETA)
C
      DO100I=2,IX
        DX=DBLE(I)
        DTERM2=DLOG(A + B*DX + BETA*(DX-1.0D0))
        DTERM3=DLOG(DX)
        IF(DPDFSV.LE.0.0D0)THEN
          GOTO9000
        ELSE
          DTERM4=DLOG(DPDFSV)
        ENDIF
C
        IF(I-2.GE.1)THEN
          DSUM=0.0D0
          DO200J=1,I-2
            DSUM=DSUM + DLOG(1.0D0 + B/
     1           (A + B*(DX-1.0D0) + BETA*DBLE(J)))
  200     CONTINUE
        ELSE
CCCCC     DSUM=DLOG(1.0D0 + B/(A + B))
          DSUM=DLOG(1.0D0)
        ENDIF
C
        DPDF=DEXP(DTERM1 + DTERM2 - DTERM3 + DTERM4 + DSUM)
        CDF=CDF + DPDF
        DPDFSV=DPDF
  100 CONTINUE
C
      PDF=DPDF
C
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LKPPF(P,A,B,BETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LAGRANGE KATZ
C              DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE
C              INTEGERS  X >= 0.
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;A,B,BETA)=
C                  (A/BETA)/((A/BETA) + (X*B/BETA) + X)*
C                  ((A/BETA)+X*b/BETA+X  X)*
C                  BETA**X*(1-BETA)**((A/BETA)+X*B/BETA)
C                  X = 0, 1, 2, 3, ,...
C                  A > 0, B > -BETA, BETA < 1
C
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED
C              FROM THE FOLLOWING RECURRENCE RELATION:
C
C              P(X+1) = {(A+B*(X+1)+BETA*X)/(X+1)}*(1-BETA)**(b/BETA)*
C                       PROD[i=1 to X-1][(1 + b/(a+B*X+BETA*i)]*P(X)
C              WHERE P(0) = (1-BETA)**(A/BETA) AND
C                    P(1) = A*(1-BETA)**(b/BETA)*P(0)
C
C              THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING
C              THE CUMULATIVE DISTRIBUTION FUNCTION UNTIL THE
C              APPROPRIATE PROBABILITY IS REACHED.
C
C     INPUT  ARGUMENTS--P      = THE DOUBLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --A      = THE FIRST SHAPE PARAMETER
C                     --B      = THE SECOND SHAPE PARAMETER
C                     --BETA   = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE DOUBLE PRECISION PERCENT POINT
C                                FUNCTION VALUE.
C     OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION
C             VALUE PPF FOR THE LAGRANGE KATZ DISTRIBUTION WITH
C             SHAPE PARAMETERS A, B, AND BETA
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P < 1
C                 --A > 0, B > -BETA, BETA < 1
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
C     WRITTEN BY--ALAN HECKERT
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 BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/2
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C-----COMMON----------------------------------------------------------
C
      REAL R1MACH
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0D0
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,4)
    4   FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKPPF IS OUTSIDE ',
     1         'THE (0,1] INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(A.LE.0.0D0)THEN
        WRITE(ICOUT,15)
   15   FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKPPF IS ',
     1         'NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(BETA.GE.1.0D0)THEN
        WRITE(ICOUT,25)
   25   FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKPPF IS GREATER ',
     1         'THAN OR EQUAL TO 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(B.LE.-BETA)THEN
        WRITE(ICOUT,35)
   35   FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKPPF IS LESS ',
     1         'THAN OR EQUAL TO -(FOURTH ARGUMENT).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)B
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
C     USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE):
C
      DEPS=1.0D-7
      DCDF=(1.0D0 - BETA)**(A/BETA)
      IF(DCDF.GE.P-DEPS)THEN
        PPF=0.0D0
        GOTO9000
      ENDIF
C
      DPDF=A*(1.0D0 - BETA)**(B/BETA)*DCDF
      DCDF=DCDF + DPDF
      IF(DCDF.GE.P-DEPS)THEN
        PPF=1.0D0
        GOTO9000
      ENDIF
C
      DPDFSV=DPDF
      DTERM1=(B/BETA)*DLOG(1.0D0 - BETA)
C
      I=1
C
  100 CONTINUE
        I=I+1
        IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN
          WRITE(ICOUT,55)
   55     FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ',
     1           'EXCEEDS THE LARGEST MACHINE INTEGER.')
          CALL DPWRST('XXX','BUG ')
          PPF=0.0D0
          GOTO9000
        ENDIF
        DX=DBLE(I)
C
        DTERM2=DLOG(A + B*DX + BETA*(DX-1.0D0))
        DTERM3=DLOG(DX)
        IF(DPDFSV.LE.0.0D0)THEN
          PPF=DBLE(I)
          GOTO9000
        ELSE
          DTERM4=DLOG(DPDFSV)
        ENDIF
C
        IF(I-2.GE.1)THEN
          DSUM=0.0D0
          DO200J=1,I-2
            DSUM=DSUM + DLOG(1.0D0 + B/
     1           (A + B*(DX-1.0D0) + BETA*DBLE(J)))
  200     CONTINUE
        ELSE
CCCCC     DSUM=DLOG(1.0D0 + B/(A + B))
          DSUM=DLOG(1.0D0)
        ENDIF
C
        DPDF=DEXP(DTERM1 + DTERM2 - DTERM3 + DTERM4 + DSUM)
        DCDF=DCDF + DPDF
        DPDFSV=DPDF
C
        IF(DCDF.GE.P-DEPS)THEN
          PPF=DBLE(I)
          GOTO9000
        ENDIF
      GOTO100
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LKRAN(N,A,B,BETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LAGRANGE KATZ DISTRIBUTION
C              WITH SHAPE PARAMETERS A, B, AND BETA.
C              THE PROBABILITY MASS FUNCTION IS:
C
C              THE PROBABILITY MASS FUNCTION IS:
C              p(X;A,B,BETA)=
C                  (A/BETA)/((A/BETA) + (X*B/BETA) + X)*
C                  ((A/BETA)+X*b/BETA+X  X)*
C                  BETA**X*(1-BETA)**((A/BETA)+X*B/BETA)
C                  X = 0, 1, 2, 3, ,...
C                  A > 0, B > -BETA, BETA < 1
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --A      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --B      = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C                     --BETA   = THE SINGLE PRECISION VALUE
C                                OF THE THIRD SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LAGRANGE KATZ DISTRIBUTION
C             WITH SHAPE PARAMETERS A, B, AND BETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --A > 0, BETA < 1, B > -BETA
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LKPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12.
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--2007/2
C     ORIGINAL VERSION--FEBRUARY  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL A
      REAL B
      REAL BETA
C
      DIMENSION X(*)
C
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF LAGRANGE KATZ ',
     1         'RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(A.LE.0.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE A PARAMETER FOR THE LAGRANGE KATZ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
   12   FORMAT('      RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)A
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(BETA.GE.1.0)THEN
        WRITE(ICOUT,21)
   21   FORMAT('***** ERROR--THE BETA PARAMETER FOR THE LAGRANGE KATZ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,22)
   22   FORMAT('      RANDOM NUMBERS IS GREATER THAN OR EQUAL TO 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)BETA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(B.LE.-BETA)THEN
        WRITE(ICOUT,31)
   31   FORMAT('***** ERROR--THE B PARAMETER FOR THE LAGRANGE KATZ')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,32)
   32   FORMAT('      RANDOM NUMBERS IS LESS THAN OR EQUAL TO -BETA.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)B
   48   FORMAT('***** THE VALUE OF THE B ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,49)BETA
   49   FORMAT('***** THE VALUE OF THE BETA ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N LAGRANGE KATZ DISTRIBUTION RANDOM NUMBERS USING
C     THE INVERSION METHOD.
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        ZTEMP=X(I)
        CALL LKPPF(DBLE(ZTEMP),DBLE(A),DBLE(B),DBLE(BETA),DPPF)
        X(I)=REAL(DPPF)
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE LLGCDF(X,DELTA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C                 F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2]
C              THE CUMULATIVE DISTRIBUTION FUNCTION IS
C                 F(X,DELTA) = 1/(1+X**(-DELTA))
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --DELTA  = THE POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --DELTA SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DDELTA
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGCDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
      IF(X.EQ.0.0)GOTO9999
      DX=DBLE(X)
      DDELTA=DBLE(DELTA)
C
      DTERM1=DLOG(1.0D0)
      DTERM2=DLOG(1.0D0 + DX**(-DDELTA))
      DTERM3=DTERM1-DTERM2
      DCDF=DEXP(DTERM3)
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LLGPDF(X,DELTA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION.
C              THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X
C              AND HAS THE PROBABILITY DENSITY FUNCTION
C              F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2]
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE POSITIVE.
C                     --DELTA  = THE POSITIVE SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-LOGISTIC DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE POSITIVE.
C                 --DELTA SHOULD BE POSITIVE.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX, DDELTA
      DOUBLE PRECISION DUL, DZ, DPDF
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LT.0.0)THEN
        WRITE(ICOUT,4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT')
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGPDF SUBROUTINE IS NEGATIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
      IF(X.EQ.0.0)GOTO9999
      DX=DBLE(X)
      DDELTA=DBLE(DELTA)
C
C CHECK FOR VALUE OF X**DELTA THAT IS TO LARGE (SET PDF TO 0)
C
      DUL=DLOG(DSQRT(D1MACH(2)))
      DZ=DDELTA*DLOG(DX)
      IF(DZ.GE.DUL)GOTO9999
C
      DTERM1=DLOG(DDELTA)
      DTERM2=(DDELTA-1.0D0)*DLOG(DX)
      DTERM3=2.0D0*DLOG(1.0D0+DX**DDELTA)
      DTERM4=DTERM1+DTERM2-DTERM3
      IF(DTERM4.GE.-80.0D0)THEN
        DPDF=DEXP(DTERM4)
      ELSE
        DPDF=0.0D0
      ENDIF
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LLGPPF(P,DELTA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-LOGISTIC
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 (EXCLUSIVELY)
C                                AND 1.0 (EXCLUSIVELY))
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION .
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY)
C                   AND 1.0 (EXCLUSIVELY).
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE",
C                 ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN,
C                 FEBRUARY, 1995.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DTERM1, DTERM2, DTERM3
      DOUBLE PRECISION DPPF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,14)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT')
    5 FORMAT('      TO THE LLGPDF SUBROUTINE IS NEGATIVE *****')
      IF(P.LT.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      PPF=0.0
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LLGPPF')
    2 FORMAT(
     1'      SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
      IF(P.EQ.0.0)GOTO9999
C
      DTERM1=(-1.0D0/DBLE(DELTA))
      DTERM2=DLOG((1.0D0-DBLE(P))/DBLE(P))
      DTERM3=DTERM1*DTERM2
      DPPF=DEXP(DTERM3)
      PPF=DPPF
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LLGRAN(N,DELTA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-LOGISTIC DISTRIBUTION
C              WITH SHAPE PARAMETER VALUE = DELTA.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --DELTA  = THE SINGLE PRECISION VALUE OF THE
C                                SHAPE PARAMETER.
C                                DELTA SHOULD BE POSITIVE.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-LOGISTIC DISTRIBUTION
C             WITH SHAPE PARAMETER VALUE = DELTA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --DELTA SHOULD BE POSITIVE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--XX
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2001.10
C     ORIGINAL VERSION--OCTOBER   2001.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(DELTA.LE.0.0)THEN
        WRITE(ICOUT,15)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)DELTA
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LLGRAN SUBROUTINE IS NON-POSITIVE *****')
   15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ',
     1'LLGRAN SUBROUTINE IS NON-POSITIVE *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOG-LOGISTIC DISTRIBUTION RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
        CALL LLGPPF(X(I),DELTA,XTEMP)
        X(I)=XTEMP
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LLTSLV(NR,N,A,X,B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C PURPOSE
C -------
C SOLVE AX=B WHERE A HAS THE FORM L(L-TRANSPOSE)
C BUT ONLY THE LOWER TRIANGULAR PART, L, IS STORED.
C
C PARAMETERS
C ----------
C NR           --> ROW DIMENSION OF MATRIX
C N            --> DIMENSION OF PROBLEM
C A(N,N)       --> MATRIX OF FORM L(L-TRANSPOSE).
C                  ON RETURN A IS UNCHANGED.
C X(N)        <--  SOLUTION VECTOR
C B(N)         --> RIGHT-HAND SIDE VECTOR
C
C NOTE
C ----
C IF B IS NOT REQUIRED BY CALLING PROGRAM, THEN
C B AND X MAY SHARE THE SAME STORAGE.
C
      DIMENSION A(NR,1),X(N),B(N)
C
C FORWARD SOLVE, RESULT IN X
C
      CALL FORSLV(NR,N,A,X,B)
C
C BACK SOLVE, RESULT IN X
C
      CALL BAKSLV(NR,N,A,X,X)
      RETURN
      END
      SUBROUTINE LMRGLO(PARA,XMOM,NMOM)
C===================================================== LMRGLO.FOR
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE GENERALIZED LOGISTIC DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION,
C                  SCALE, SHAPE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3),XMOM(NMOM),Z(10,20)
C
      INCLUDE 'DPCOP2.INC'
C
      DATA ZERO/0D0/,ONE/1D0/
      DATA PI/3.141592653589793238D0/
C
C         SMALL IS USED TO DECIDE WHETHER TO APPROXIMATE THE FIRST 2
C         L-MOMENTS BY A POWER-SERIES EXPANSION WHEN G IS NEAR ZERO.
C         C1,C2 ARE COEFFICIENTS OF THIS POWER-SERIES EXPANSION.
C         C1 IS PI**2/6, C2 IS 7*PI**4/360.
C
      DATA SMALL/1D-4/
      DATA C1,C2/
     *  0.16449 34066 84822 644D 1,  0.18940 65658 99449 184D 1/
C
C         Z-ARRAY CONTAINS COEFFICIENTS OF THE REPRESENTATIONS OF
C         L-MOMENT RATIOS AS POLYNOMIALS IN THE SHAPE PARAMETER K
C
      DATA Z(1,3)/1D0/
      DATA (Z(I, 4),I=1, 2)/
     *  0.16666 66666 66666 667D 0,  0.83333 33333 33333 333D 0/
      DATA (Z(I, 5),I=1, 2)/
     *  0.41666 66666 66666 667D 0,  0.58333 33333 33333 333D 0/
      DATA (Z(I, 6),I=1, 3)/
     *  0.66666 66666 66666 667D-1,  0.58333 33333 33333 333D 0,
     *  0.35000 00000 00000 000D 0/
      DATA (Z(I, 7),I=1, 3)/
     *  0.23333 33333 33333 333D 0,  0.58333 33333 33333 333D 0,
     *  0.18333 33333 33333 333D 0/
      DATA (Z(I, 8),I=1, 4)/
     *  0.35714 28571 42857 143D-1,  0.42083 33333 33333 333D 0,
     *  0.45833 33333 33333 333D 0,  0.85119 04761 90476 190D-1/
      DATA (Z(I, 9),I=1, 4)/
     *  0.15099 20634 92063 492D 0,  0.51562 50000 00000 000D 0,
     *  0.29791 66666 66666 667D 0,  0.35466 26984 12698 413D-1/
      DATA (Z(I,10),I=1, 5)/
     *  0.22222 22222 22222 222D-1,  0.31889 32980 59964 727D 0,
     *  0.47997 68518 51851 852D 0,  0.16550 92592 59259 259D 0,
     *  0.13398 36860 67019 400D-1/
      DATA (Z(I,11),I=1, 5)/
     *  0.10650 79365 07936 508D 0,  0.44766 31393 29805 996D 0,
     *  0.36081 01851 85185 185D 0,  0.80390 21164 02116 402D-1,
     *  0.46285 27336 86067 019D-2/
      DATA (Z(I,12),I=1, 6)/
     *  0.15151 51515 15151 515D-1,  0.25131 61375 66137 566D 0,
     *  0.46969 52160 49382 716D 0,  0.22765 04629 62962 963D 0,
     *  0.34713 95502 64550 265D-1,  0.14727 13243 54657 688D-2/
      DATA (Z(I,13),I=1, 6)/
     *  0.79569 50456 95045 695D-1,  0.38976 59465 02057 613D 0,
     *  0.39291 73096 70781 893D 0,  0.12381 31062 61022 928D 0,
     *  0.13499 87139 91769 547D-1,  0.43426 15974 56041 900D-3/
      DATA (Z(I,14),I=1, 7)/
     *  0.10989 01098 90109 890D-1,  0.20413 29966 32996 633D 0,
     *  0.44773 66255 14403 292D 0,  0.27305 34428 27748 383D 0,
     *  0.59191 74382 71604 938D-1,  0.47768 77572 01646 091D-2,
     *  0.11930 26366 63747 775D-3/
      DATA (Z(I,15),I=1, 7)/
     *  0.61934 52050 59490 774D-1,  0.34203 17593 92870 504D 0,
     *  0.40701 37051 73427 396D 0,  0.16218 91928 06752 331D 0,
     *  0.25249 21002 35155 791D-1,  0.15509 34276 62872 107D-2,
     *  0.30677 82085 63922 850D-4/
      DATA (Z(I,16),I=1, 8)/
     *  0.83333 33333 33333 333D-2,  0.16976 83649 02293 474D 0,
     *  0.42219 12828 68366 202D 0,  0.30542 71728 94620 811D 0,
     *  0.84082 79399 72285 210D-1,  0.97243 57914 46208 113D-2,
     *  0.46528 02829 88616 322D-3,  0.74138 06706 96146 887D-5/
      DATA (Z(I,17),I=1, 8)/
     *  0.49716 60284 16028 416D-1,  0.30276 58385 89871 328D 0,
     *  0.41047 33000 89185 506D 0,  0.19483 90265 03251 764D 0,
     *  0.38659 80637 04648 526D-1,  0.34139 94076 42897 226D-2,
     *  0.12974 16173 71825 705D-3,  0.16899 11822 91033 482D-5/
      DATA (Z(I,18),I=1, 9)/
     *  0.65359 47712 41830 065D-2,  0.14387 48475 95085 690D 0,
     *  0.39643 28537 10259 464D 0,  0.32808 41807 20899 471D 0,
     *  0.10797 13931 65194 318D 0,  0.15965 33699 32077 769D-1,
     *  0.11012 77375 69143 819D-2,  0.33798 23645 82066 963D-4,
     *  0.36449 07853 33601 627D-6/
      DATA (Z(I,19),I=1, 9)/
     *  0.40878 45705 49276 431D-1,  0.27024 42907 25441 519D 0,
     *  0.40759 95245 14551 521D 0,  0.22211 14264 89320 008D 0,
     *  0.52846 38846 29533 398D-1,  0.59829 82392 72872 761D-2,
     *  0.32859 39655 65898 436D-3,  0.82617 91134 22830 354D-5,
     *  0.74603 37711 50646 605D-7/
      DATA (Z(I,20),I=1,10)/
     *  0.52631 57894 73684 211D-2,  0.12381 76557 53054 913D 0,
     *  0.37185 92914 44794 917D 0,  0.34356 87476 70189 607D 0,
     *  0.13019 86628 12524 058D 0,  0.23147 43648 99477 023D-1,
     *  0.20519 25194 79869 981D-2,  0.91205 82581 07571 930D-4,
     *  0.19023 86116 43414 884D-5,  0.14528 02606 97757 497D-7/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO.OR.DABS(G).GE.ONE)THEN
        WRITE(ICOUT,7000)
 7000   FORMAT('***** ERROR IN GENERALIZED LOGISTIC L-MOMENTS--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7005)
 7005   FORMAT('      PARAMETERS INVALID')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ELSEIF(NMOM.GT.20)THEN
        WRITE(ICOUT,7000)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,7010)
 7010   FORMAT('      PARAMETER NMOM TOO LARGE')
        CALL DPWRST('XXX','WRIT')
        GOTO9000
      ENDIF
C
C         FIRST 2 MOMENTS
C
      GG=G*G
      ALAM1=-G*(C1+GG*C2)
      ALAM2=ONE+GG*(C1+GG*C2)
      IF(DABS(G).GT.SMALL)ALAM2=G*PI/DSIN(G*PI)
      IF(DABS(G).GT.SMALL)ALAM1=(ONE-ALAM2)/G
      XMOM(1)=U+A*ALAM1
      IF(NMOM.EQ.1)GOTO9000
      XMOM(2)=A*ALAM2
      IF(NMOM.EQ.2)GOTO9000
C
C         HIGHER MOMENTS
C
      DO 20 M=3,NMOM
         KMAX=M/2
         SUM=Z(KMAX,M)
         DO 10 K=KMAX-1,1,-1
            SUM=SUM*GG+Z(K,M)
   10    CONTINUE
         IF(M.NE.M/2*2)SUM=-G*SUM
         XMOM(M)=SUM
   20 CONTINUE
C
 9000 CONTINUE
      RETURN
C
      END
      SUBROUTINE LNHERM(X,AN,HN,ISIGN)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE LOGARITHM OF THE HERMITE
C              POLYNOMIAL OF ORDER N.  THIS IS USEFUL FOR LARGER
C              ORDERS WHERE OVERFLOW MAY OCCUR WITH THE STANDARD
C              HERMITE POLYNOMIAL.
C
C              THE HERMITE POLYNOMIAL CAN BE NEGATIVE OR POSITIVE,
C              SO TAKE LOG OF ABSOLUTE VALUE, SAVE SIGN IN ISIGN.
C              IF HERMITE POLYNOMIAL IS ZERO, THEN SET THIS FUNCTION
C              TO ZERO.
C
C              THIS FUNCTION IS INTENDED FOR INTERMEDIATE PRIMARILY
C              FOR WHEN HIGH ORDER HERMITE POLYNOMIALS ARE USED IN
C              INTERMEDIATE CALCULATIONS AND LOGS CAN BE USED TO
C              HANDLE LARGE VALUES.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION INPUT ARGUMENT
C                       AN     = THE SINGLE PRECISION VALUE FOR THE
C                                ORDER OF THE FUNCTION (SHOULD BE
C                                NON-NEGATIVE ORDER)
C     OUTPUT ARGUMENTS--HN     = THE SINGLE PRECISION VALUE OF THE
C                                LOG HERMITE POLYNOMIAL.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE
C     MODE OF INTERNAL OPERATIONS--SOME DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--"HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55",
C                 ABRAMOWITZ AND STEGUM.
C                 USE FOLLOWING RECURRENCE FORMULA:
C                    H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1)
C                 FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ
C                 AND STEGUM.
C                 COMPUTE THE HERMITE POLYNOMIAL IN THE STANDARD WAY
C                 (IN DOUBLE PRECISION), BUT TAKE LOG BEFORE CONVERTING
C                 TO SINGLE PRECISION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2855
C     ORIGINAL VERSION--JULY       1995.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DN, DN2
      DOUBLE PRECISION DHN, DHN1, DHN2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      N=INT(AN+0.5)
      IF(N.LT.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    6 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ',
     1'TO THE LNHERM SUBROUTINE IS NEGATIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
      DX=DBLE(X)
      DN=DBLE(N)
C
      IF(N.LE.0)THEN
        DHN=1.0D0
      ELSEIF(N.EQ.1)THEN
        DHN=2.0D0*DX
      ELSEIF(N.EQ.2)THEN
        DHN=4.0D0*DX**2 - 2.0D0
      ELSEIF(N.EQ.3)THEN
        DHN=8.0D0*DX**3 - 12.0D0*DX
      ELSEIF(N.EQ.4)THEN
        DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
      ELSEIF(N.EQ.5)THEN
        DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
      ELSE
        DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX
        DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0
        DO1000I=6,N
          DN2=DBLE(I)-1.0D0
          DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2
          DHN2=DHN1
          DHN1=DHN
 1000   CONTINUE
      ENDIF
C
      IF(DHN.GT.0.0)THEN
        DHN=DLOG(DHN)
        ISIGN=1
      ELSEIF(DHN.LT.0.D0)THEN
        DHN=DLOG(DABS(DHN))
        ISIGN=-1
      ELSE
        DHN=0.0D0
        ISIGN=0
      ENDIF
C
      HN=REAL(DHN)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,MXTAKE,
CDPLT SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,OPTFCN,MXTAKE,
     +                  IRETCD,STEPMX,STEPTL,SX,IPR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C PURPOSE
C -------
C FIND A NEXT NEWTON ITERATE BY LINE SEARCH.
C
C PARAMETERS
C ----------
C N            --> DIMENSION OF PROBLEM
C X(N)         --> OLD ITERATE:   X[K-1]
C F            --> FUNCTION VALUE AT OLD ITERATE, F(X)
C G(N)         --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE
C P(N)         --> NON-ZERO NEWTON STEP
C XPLS(N)     <--  NEW ITERATE X[K]
C FPLS        <--  FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C OPTFCN       --> NAME OF SUBROUTINE TO EVALUATE FUNCTION
C IRETCD      <--  RETURN CODE
C MXTAKE      <--  BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C STEPMX       --> MAXIMUM ALLOWABLE STEP SIZE
C STEPTL       --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C SX(N)        --> DIAGONAL SCALING MATRIX FOR X
C IPR          --> DEVICE TO WHICH TO SEND OUTPUT
C
C INTERNAL VARIABLES
C ------------------
C SLN              NEWTON LENGTH
C RLN              RELATIVE LENGTH OF NEWTON STEP
C
      INTEGER N,IRETCD
      DIMENSION SX(N)
      DIMENSION X(N),G(N),P(N)
      DIMENSION XPLS(N)
      DIMENSION FHAT(1)
      LOGICAL MXTAKE
C
      PLMBDA=0.0
      PFPLS=0.0
C
      IPR=IPR
      MXTAKE=.FALSE.
      IRETCD=2
C$    WRITE(IPR,954)
C$    WRITE(IPR,955) (P(I),I=1,N)
      TMP=0.0D0
      DO 5 I=1,N
        TMP=TMP+SX(I)*SX(I)*P(I)*P(I)
    5 CONTINUE
      SLN=SQRT(TMP)
      IF(SLN.LE.STEPMX) GO TO 10
C
C NEWTON STEP LONGER THAN MAXIMUM ALLOWED
        SCL=STEPMX/SLN
        CALL SCLMUL(N,SCL,P,P)
        SLN=STEPMX
C$      WRITE(IPR,954)
C$      WRITE(IPR,955) (P(I),I=1,N)
   10 CONTINUE
      SLP=DDOT(N,G,1,P,1)
      RLN=0.D0
      DO 15 I=1,N
        RLN=MAX(RLN,ABS(P(I))/MAX(ABS(X(I)),1.D0/SX(I)))
   15 CONTINUE
      RMNLMB=STEPTL/RLN
      ALMBDA=1.0D0
C$    WRITE(IPR,952) SLN,SLP,RMNLMB,STEPMX,STEPTL
C
C LOOP
C CHECK IF NEW ITERATE SATISFACTORY.  GENERATE NEW LAMBDA IF NECESSARY.
C
  100 CONTINUE
      IF(IRETCD.LT.2) RETURN
      DO 105 I=1,N
        XPLS(I)=X(I) + ALMBDA*P(I)
  105 CONTINUE
      CALL OPTFCN(N,XPLS,FHAT)
      FPLS=FHAT(1)
C$    WRITE(IPR,950) ALMBDA
C$    WRITE(IPR,951)
C$    WRITE(IPR,955) (XPLS(I),I=1,N)
C$    WRITE(IPR,953) FPLS
      IF(FPLS.GT. F+SLP*1.D-4*ALMBDA) GO TO 130
C     IF(FPLS.LE. F+SLP*1.D-4*ALMBDA)
C     THEN
C
C SOLUTION FOUND
C
        IRETCD=0
        IF(ALMBDA.EQ.1.0 .AND. SLN.GT. .99D0*STEPMX) MXTAKE=.TRUE.
        GO TO 100
C
C SOLUTION NOT (YET) FOUND
C
C     ELSE
  130   CONTINUE
        IF(ALMBDA .GE. RMNLMB) GO TO 140
C       IF(ALMBDA .LT. RMNLMB)
C       THEN
C
C NO SATISFACTORY XPLS FOUND SUFFICIENTLY DISTINCT FROM X
C
          IRETCD=1
          GO TO 100
C       ELSE
C
C CALCULATE NEW LAMBDA
C
  140     IF(ALMBDA.NE.1.0D0) GO TO 150
C         IF(ALMBDA.EQ.1.0D0)
C         THEN
C
C FIRST BACKTRACK: QUADRATIC FIT
C
            TLMBDA=-SLP/(2.D0*(FPLS-F-SLP))
            GO TO 170
C         ELSE
C
C ALL SUBSEQUENT BACKTRACKS: CUBIC FIT
C
  150       CONTINUE
            T1=FPLS-F-ALMBDA*SLP
            T2=PFPLS-F-PLMBDA*SLP
            T3=1.0D0/(ALMBDA-PLMBDA)
            A=T3*(T1/(ALMBDA*ALMBDA) - T2/(PLMBDA*PLMBDA))
            B=T3*(T2*ALMBDA/(PLMBDA*PLMBDA)
     +           - T1*PLMBDA/(ALMBDA*ALMBDA) )
            DISC=B*B-3.0D0*A*SLP
            IF(DISC.LE. B*B) GO TO 160
C           IF(DISC.GT. B*B)
C           THEN
C
C ONLY ONE POSITIVE CRITICAL POINT, MUST BE MINIMUM
C
              TLMBDA=(-B+SIGN(1.0D0,A)*SQRT(DISC))/(3.0D0*A)
              GO TO 165
C           ELSE
C
C BOTH CRITICAL POINTS POSITIVE, FIRST IS MINIMUM
C
  160         TLMBDA=(-B-SIGN(1.0D0,A)*SQRT(DISC))/(3.0D0*A)
C           ENDIF
  165       IF(TLMBDA.GT. .5D0*ALMBDA) TLMBDA=.5D0*ALMBDA
C         ENDIF
  170     CONTINUE
          PLMBDA=ALMBDA
          PFPLS=FPLS
          IF(TLMBDA.GE. ALMBDA*.1D0) GO TO 180
C         IF(TLMBDA.LT.ALMBDA/10.D0)
C         THEN
            ALMBDA=ALMBDA*.1D0
            GO TO 190
C         ELSE
  180       ALMBDA=TLMBDA
C         ENDIF
C       ENDIF
C     ENDIF
  190 GO TO 100
CC950 FORMAT(18H LNSRCH    ALMBDA=,E20.13)
CC951 FORMAT(29H LNSRCH    NEW ITERATE (XPLS))
CC952 FORMAT(18H LNSRCH    SLN   =,E20.13/
CC   +       18H LNSRCH    SLP   =,E20.13/
CC   +       18H LNSRCH    RMNLMB=,E20.13/
CC   +       18H LNSRCH    STEPMX=,E20.13/
CC   +       18H LNSRCH    STEPTL=,E20.13)
CC953 FORMAT(19H LNSRCH    F(XPLS)=,E20.13)
CC954 FORMAT(26H0LNSRCH    NEWTON STEP (P))
CC955 FORMAT(14H LNSRCH       ,5(E20.13,3X))
      END
      DOUBLE PRECISION FUNCTION LOBACH(XVALUE)
C
C   DESCRIPTION:
C
C      This function calculates the Lobachewsky function L(x), defined as
C
C         LOBACH(x) = {integral 0 to x} ( -ln ( | cos t | ) dt
C
C      The code uses Chebyshev expansions whose coefficients are given
C      to 20 decimal places.
C
C
C   ERROR RETURNS:
C
C      If |x| too large, it is impossible to accurately reduce the
C      argument to the range [0,pi]. An error message is printed
C      and the program returns the value 0.0
C
C
C   MACHINE-DEPENDENT CONSTANTS:
C
C      NTERM1 - INTEGER - The no. of terms to be used of the array ARLOB1.
C                          The recommended value is such that
C                          ABS(ARLOB1(NTERM1)) < EPS/100
C
C      NTERM2 - INTEGER - The no. of terms to be used of the array ARLOB2.
C                          The recommended value is such that
C                          ABS(ARLOB2(NTERM2)) < EPS/100
C
C      XLOW1 - DOUBLE PRECISION - The value below which L(x) = 0.0 to machine-precision.
C                     The recommended value is
C                              cube-root ( 6*XMIN )
C
C      XLOW2 - DOUBLE PRECISION - The value below which L(x) = x**3/6 to
C                     machine-precision. The recommended value is
C                              sqrt ( 10*EPS )
C
C      XLOW3 - DOUBLE PRECISION - The value below which
C                         L(pi/2) - L(pi/2-x) = x ( 1 - log(x) )
C                     to machine-precision. The recommended value is
C                               sqrt ( 18*EPS )
C
C      XHIGH - DOUBLE PRECISION - The value of |x| above which it is impossible
C                     to accurately reduce the argument. The
C                     recommended value is   1 / EPS.
C
C      For values of EPS, and XMIN, refer to the file MACHCON.TXT
C
C      The machine-dependent constants are computed internally by
C      using the D1MACH subroutine.
C
C
C   INTRINSIC FUNCTIONS USED:
C
C      INT , LOG , SQRT
C
C
C   OTHER MISCFUN SUBROUTINES USED:
C
C          CHEVAL , ERRPRN, D1MACH
C
C
C   AUTHOR:
C
C      Dr. Allan J. MacLeod,
C      Dept. of Mathematics and Statistics,
C      University of Paisley,
C      High St.,
C      Paisley,
C      SCOTLAND
C
C      ( e-mail: macl_ms0@paisley.ac.uk )
C
C
C   LATEST UPDATE:
C                  23 January, 1996
C
      INTEGER INDPI2,INDSGN,NPI,NTERM1,NTERM2
      DOUBLE PRECISION ARLOB1(0:15),ARLOB2(0:10),
     1     CHEVAL,FVAL,FVAL1,HALF,LBPB21,LBPB22,LOBPIA,LOBPIB,
     2     LOBPI1,LOBPI2,ONE,ONEHUN,PI,PIBY2,PIBY21,PIBY22,PIBY4,PI1,
     3     PI11,PI12,PI2,SIX,T,TCON,TEN,TWO,X,XCUB,XHIGH,XLOW1,
     4     XLOW2,XLOW3,XR,XVALUE,ZERO
CCCCC CHARACTER FNNAME*6,ERRMSG*26
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
CCCCC DATA FNNAME/'LOBACH'/
CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/
      DATA ZERO,HALF/ 0.0 D 0 , 0.5 D 0 /
      DATA ONE,TWO,SIX/ 1.0 D 0 , 2.0 D 0 , 6.0 D 0 /
      DATA TEN,ONEHUN/ 10.0 D 0 , 100.0 D 0 /
      DATA LOBPIA,LOBPIB/ 1115.0 D 0 , 512.0 D 0 /
      DATA LOBPI2/-1.48284 69639 78694 99311 D -4/
      DATA LBPB22/-7.41423 48198 93474 96556 D -5/
      DATA PI11,PI12/ 201.0 D 0 , 64.0 D 0 /
      DATA PI2/9.67653 58979 32384 62643 D -4/
      DATA PIBY22/4.83826 79489 66192 31322 D -4/
      DATA TCON/3.24227 78765 54808 68620 D 0/
      DATA ARLOB1/0.34464 88495 34813 00507  D    0,
     1            0.58419 83571 90277 669    D   -2,
     2            0.19175 02969 46003 30     D   -3,
     3            0.78725 16064 56769        D   -5,
     4            0.36507 47741 5804         D   -6,
     5            0.18302 87272 680          D   -7,
     6            0.96890 33300 5            D   -9,
     7            0.53390 55444              D  -10,
     8            0.30340 8025               D  -11,
     9            0.17667 875                D  -12,
     X            0.10493 93                 D  -13,
     1            0.63359                    D  -15,
     2            0.3878                     D  -16,
     3            0.240                      D  -17,
     4            0.15                       D  -18,
     5            0.1                        D  -19/
      DATA ARLOB2/2.03459 41803 61328 51087  D    0,
     1            0.17351 85882 02740 7681   D   -1,
     2            0.55162 80426 09052 1      D   -4,
     3            0.39781 64627 6598         D   -6,
     4            0.36901 80289 18           D   -8,
     5            0.38804 09214              D  -10,
     6            0.44069 698                D  -12,
     7            0.52767 4                  D  -14,
     8            0.6568                     D  -16,
     9            0.84                       D  -18,
     X            0.1                        D  -19/
C
C   Start computation
C
      X = ABS ( XVALUE )
      INDSGN = 1
      IF ( XVALUE .LT. ZERO ) THEN
         INDSGN = -1
      ENDIF
C
C   Compute the machine-dependent constants.
C
      XR = D1MACH(3)
      XHIGH = ONE / XR
C
C   Error test
C
      IF ( X .GT. XHIGH ) THEN
CCCCC    CALL ERRPRN(FNNAME,ERRMSG)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,101)X
         CALL DPWRST('XXX','BUG ')
         LOBACH = ZERO
         RETURN
      ENDIF
  999 FORMAT(1X)
  101 FORMAT('***** ERROR FROM LOBACH--ARGUMENT TOO LARGE.   ',
     1       'ARGUMENT = ',G15.7)
C
C   continue with constants
C
      T = XR / ONEHUN
      DO 10 NTERM1 = 15 , 0 , -1
         IF ( ABS(ARLOB1(NTERM1)) .GT. T ) GOTO 19
 10   CONTINUE
 19   DO 20 NTERM2 = 10 , 0 , -1
         IF ( ABS(ARLOB2(NTERM2)) .GT. T ) GOTO 29
 20   CONTINUE
 29   XLOW1 = ( SIX * D1MACH(1) ) ** (TWO/SIX)
      XLOW2 = SQRT ( TEN * XR )
      T = TWO * TEN - TWO
      XLOW3 = SQRT ( T * XR )
C
C   Reduce argument to [0,pi]
C
      PI1 = PI11/PI12
      PI = PI1 + PI2
      PIBY2 = PI/TWO
      PIBY21 = PI1/TWO
      PIBY4 = PIBY2/TWO
      NPI = INT ( X / PI )
      XR = ( X - NPI * PI1 ) - NPI * PI2
C
C   Reduce argument to [0,pi/2]
C
      INDPI2 = 0
      IF ( XR .GT. PIBY2 ) THEN
         INDPI2 = 1
         XR = ( PI1 - XR ) + PI2
      ENDIF
C
C   Code for argument in [0,pi/4]
C
      IF ( XR .LE. PIBY4 ) THEN
         IF ( XR .LT. XLOW1 ) THEN
            FVAL = ZERO
         ELSE
            XCUB = XR * XR * XR
            IF ( XR .LT. XLOW2 ) THEN
               FVAL = XCUB / SIX
            ELSE
               T = ( TCON * XR * XR - HALF ) - HALF
               FVAL = XCUB * CHEVAL(NTERM1,ARLOB1,T)
            ENDIF
         ENDIF
      ELSE
C
C   Code for argument in [pi/4,pi/2]
C
         XR = ( PIBY21 - XR ) + PIBY22
         IF ( XR .EQ. ZERO ) THEN
            FVAL1 = ZERO
         ELSE
            IF ( XR .LT. XLOW3 ) THEN
               FVAL1 = XR * ( ONE - LOG( XR ) )
            ELSE
               T = ( TCON * XR * XR - HALF ) - HALF
               FVAL1 = XR * ( CHEVAL(NTERM2,ARLOB2,T) - LOG( XR ) )
            ENDIF
         ENDIF
         LBPB21 = LOBPIA / ( LOBPIB + LOBPIB )
         FVAL = ( LBPB21 - FVAL1 ) + LBPB22
      ENDIF
      LOBPI1 = LOBPIA / LOBPIB
C
C   Compute value for argument in [pi/2,pi]
C
      IF ( INDPI2 .EQ. 1 ) THEN
         FVAL = ( LOBPI1 - FVAL ) + LOBPI2
      ENDIF
      LOBACH = FVAL
C
C   Scale up for arguments > pi
C
      IF ( NPI .GT. 0 ) THEN
         LOBACH = ( FVAL + NPI * LOBPI2 ) + NPI * LOBPI1
      ENDIF
      IF ( INDSGN .EQ. -1 ) THEN
         LOBACH = - LOBACH
      ENDIF
      RETURN
      END
      SUBROUTINE LOCAL (XI,YI,FI,NXG,XG,NYG,YG,NP,MP,AL,AB,C,IP,IER)
C
C     THIS SUBROUTINE CONSTRUCTS THE LOCAL APPROXIMANTS FOR THE GRID
C     VERSION OF FRANKE'S METHOD.  THE LOCAL APPROXIMATIONS ARE TAKEN
C     TO BE THE THIN PLATE SPLINES DESCRIBED BY DUCHON AND OTHERS.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI,FI),I=1,NPI.
C        FI   - /
C        NXG  - INPUT.  THE NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER.
C        NYG  - INPUT.  THE NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES, IN
C                       INCREASING ORDER.
C        NP   - INPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - INPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        AL   - OUTPUT.  THE COEFFICIENTS FOR THE LINEAR PART OF THE
C                       LOCAL THIN PLATE SPLINE FIT.
C        AB   - OUTPUT.  THE COEFFICIENTS FOR THE THIN PLATE SPLINES
C        C    - OUTPUT.  NOT MEANINGFUL.  THIS IS A SCRATCH ARRAY USED
C                       DURING CALCULATION OF THE LOCAL APPROXIMATIONS.
C        IP   - OUTPUT.  NOT MEANINGFUL.  THIS IS A SCRATCH ARRAY USED
C                       TO STORE PIVOT ORDER IN EQUATION SOLUTION.
C        IER  - OUTPUT.  RETURN INDICATOR.
C                 = 0,  NORMAL RETURN.
C                 = 1,  SINGULAR MATRIX HAS BEEN DETECTED IN THE
C                       THIN PLATE SPLINE FIT.
C
C     SUBROUTINES USED
C        LINPACK:  SGECO,SGESL
C        SLATEC:  XERROR
C
      DIMENSION XI(*), YI(*), FI(*), NP(*), MP(*), AL(*), AB(*), XG(*),
     1 YG(*),C(*),IP(*)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS
C     FUNCTIONS.
C
      PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*LOG(((X-XP)**2+(Y-YP)**2)
     1 + 1.E-20)
      IER = 0
      IJ = 0
      DO 160 J=1,NYG
      DO 140 I=1,NXG
      IJ = IJ + 1
  140 CONTINUE
  160 CONTINUE
      IJ = 0
C
      DO 260 J=1,NYG
      DY = YG(J+2)-YG(J)
C
      DO 240 I=1,NXG
      DX = XG(I+2)-XG(I)
      IJ = IJ+1
      LEND = NP(IJ+1)-NP(IJ)
      LEND3 = LEND + 3
      IALS = (IJ-1)*3
C
      DO 200 LI=1,LEND
      MPI = NP(IJ)+LI-1
      KI = MP(MPI)
      XKI = (XI(KI)-XG(I))/DX
      YKI = (YI(KI)-YG(J))/DY
      LIJ = LEND*LEND3 + LI
      C(LIJ) = 1.
      C(LIJ+LEND3) = XKI
      C(LIJ+2*LEND3) = YKI
      LIJ = LEND3*(LI - 1) + LEND + 1
      C(LIJ) = 1.
      C(LIJ+1) = XKI
      C(LIJ+2) = YKI
      LIJL = LI
      LIJU = LEND3*(LI-1)+1
C
      DO 180 LJ=1,LI
      MPJ = NP(IJ)+LJ-1
      KJ = MP(MPJ)
      XKJ = (XI(KJ)-XG(I))/DX
      YKJ = (YI(KJ)-YG(J))/DY
      C(LIJL) = PHI(XKI,YKI,XKJ,YKJ)
      C(LIJU) = C(LIJL)
      LIJL = LIJL + LEND3
      LIJU = LIJU + 1
  180 CONTINUE
C
      LIJ = LEND3*LEND3 + LI
      C(LIJ) = FI(KI)
  200 CONTINUE
      DO 215 LLI=1,3
      LIJU = (LEND + LLI - 1)*LEND3 + LEND + 1
      LIJL = LEND*LEND3 + LEND + LLI
      DO 210 LLJ = 1,LLI
      C(LIJL) = 0.
      C(LIJU) = 0.
      LIJL = LIJL + LEND3
      LIJU = LIJU + 1
  210 CONTINUE
      LIJ = LEND3*LEND3 + LEND + LLI
      C(LIJ) = 0.
  215 CONTINUE
C
      LR = LEND3*LEND3 + 1
      LRR = LR + LEND3
C
      CALL SGECO(C,LEND3,LEND3,IP,RCOND,C(LRR))
      IF((.1*RCOND+1.).EQ.1.)GO TO 300
      CALL SGESL(C,LEND3,LEND3,IP,C(LR),0)
C
      DO 220 LI=1,LEND
      IAB = NP(IJ)+LI-1
      AB(IAB) = C(LR)
      LR = LR + 1
  220 CONTINUE
C
      AL(IALS+1) = C(LR)
      AL(IALS+2) = C(LR+1)
      AL(IALS+3) = C(LR+2)
  240 CONTINUE
C
  260 CONTINUE
C
      RETURN
C
C     ERROR RETURN
C
  300 IER = 1
      RETURN
      END
      SUBROUTINE LOEVL (XI,YI,NXG,XG,NYG,YG,NP,MP,AL,AB,NXO,XO,NYO
     1,YO,FO)
C
C     THIS SUBROUTINE EVALUATES THE INTERPOLANT FOR THE GRID VERSION OF
C     FRANKE'S METHOD.  THE FUNCTION IS EVALUATED AT THE GRID OF POINTS
C     INDICATED BY NXO, XO, NYO, YO, AND THESE VALUES ARE RETURNED
C     IN THE ARRAY FO, WHICH IS ASSUMED TO BE DIMENSIONED (NXO,NYO).
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI,FI),I=1,...,NPI.
C        FI   - /
C        NXG  - INPUT.  THE NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER.
C        NYG  - INPUT.  THE NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES,
C                       IN INCREASING ORDER.
C        NP   - INPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - INPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        AL   - INPUT.  THE COEFFICIENTS FOR THE LINEAR PART OF THE
C                       THIN PLATE SPLINE APPROXIMATIONS.
C        AB   - INPUT.  THE COEFFICIENTS FOR THE LOCAL THIN PLATE
C                       SPLINE APPROXIMATIONS.
C        NXO  - INPUT.  THE NUMBER OF XO VALUES AT WHICH THE INTERPO-
C                       LATION FUNCTION IS TO BE CALCULATED.
C        XO   - INPUT.  THE VALUES OF X AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.
C        NYO  - INPUT.  THE NUMBER OF YO VALUES AT WHICH THE INTERPO-
C                       LATION FUNCTION IS TO BE CALCULATED.
C        YO   - INPUT.  THE VALUES OF Y AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.
C        FO   - OUTPUT.  VALUES OF THE INTERPOLATION FUNCTION AT THE
C                       GRID POINTS INDICATED BY NXO, XO, NYO, YO.
C                       FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE
C                       CALLING PROGRAM.
C
      DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), FC(4), AL(*),
     1AB(*), XO(*), YO(*), FO(NXO,1)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE HERMITE CUBIC.
C
      H3(S) = 1. - S**2*(3. - 2.*S)
C
C     ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS
C     FUNCTIONS.
C
      PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*LOG(((X-XP)**2+(Y-YP)**2)
     1 + 1.E-20)
C
      J = 1
C
      DO 640 JO=1,NYO
C
C       DETERMINE THE LOCATION OF THE POINT YO IN TERMS OF THE SMALLEST
C       VALUE OF J SUCH THAT YO(JO) IS IN SOME RECTANGLE (I,J).
C
        YV = YO(JO)
        JJS = J+1
        IF (YV.LT.YG(JJS)) JJS=1
C
        DO 100 JJ=JJS,NYG
          IF (YV.LT.YG(JJ+1)) GO TO 120
  100   CONTINUE
C
        J = NYG
        GO TO 140
  120   CONTINUE
        J = JJ-1
  140   CONTINUE
        JD = 3
        IF (J.GE.1) GO TO 160
        JD = 0
        J = 1
        GO TO 180
  160   CONTINUE
        IF (J.LT.NYG) GO TO 180
        JD = 6
  180   CONTINUE
        DY = YG(J+2)-YG(J+1)
        I = 1
C
        DO 620 IO=1,NXO
C
C         DETERMINE THE LOCATION OF THE POINT XO IN TERMS OF THE
C         SMALLEST VALUE OF I SUCH THAT XO(IO) IS IN THE
C         RECTANGLE (I,J).
C
          IIS = I+1
          XV = XO(IO)
          IF (XV.LT.XG(IIS)) IIS=1
C
          DO 200 II=IIS,NXG
            IF (XV.LT.XG(II+1)) GO TO 220
  200     CONTINUE
C
          I = NXG
          GO TO 240
  220     CONTINUE
          I = II-1
  240     CONTINUE
          ID = 2
          IF (I.GE.1) GO TO 260
          ID = 1
          I = 1
          GO TO 280
  260     CONTINUE
          IF (I.LT.NXG) GO TO 280
          ID = 3
  280     CONTINUE
          DX = XG(I+2)-XG(I+1)
          KD = ID+JD
          GO TO (300,360,300,440,520,440,300,360,300), KD
C
C         THIS IS FOR (XO(IO),YO(JO)) POINTS IN A SINGLE
C         RECTANGLE (I,J)
C
  300     CONTINUE
          FV = 0.
          IJ = (J-1)*NXG+I
          IAL = 3*IJ-2
          LMAX = NP(IJ+1)-NP(IJ)
          DXA = XG(I+2)-XG(I)
          DYA = YG(J+2)-YG(J)
          XVD = (XV-XG(I))/DXA
          YVD = (YV-YG(J))/DYA
C
          DO 320 L=1,LMAX
            MPS = NP(IJ)+L-1
            KI = MP(MPS)
            XKI = (XI(KI)-XG(I))/DXA
            YKI = (YI(KI)-YG(J))/DYA
            FV = FV+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
  320     CONTINUE
C
          FV = FV + AL(IAL) + AL(IAL+1)*XVD + AL(IAL+2)*YVD
          GO TO 620
C
C         THIS IS FOR XO(IO),YO(JO)) POINTS WHICH ARE IN TWO
C         RECTANGLES, (I,J) AND (I+1,J).
C
  360     CONTINUE
          DYA = YG(J+2)-YG(J)
          YVD = (YV-YG(J))/DYA
C
          DO 420 IP=1,2
            FC(IP) = 0.
            IS = I+IP-1
            IJ = (J-1)*NXG+IS
            IAL = 3*IJ-2
            DXA = XG(IS+2)-XG(IS)
            XVD = (XV-XG(IS))/DXA
            LMAX = NP(IJ+1)-NP(IJ)
C
            DO 380 L=1,LMAX
              MPS = NP(IJ)+L-1
              KI = MP(MPS)
              XKI = (XI(KI)-XG(IS))/DXA
              YKI = (YI(KI)-YG(J))/DYA
              FC(IP) = FC(IP)+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
  380       CONTINUE
C
            FC(IP)=FC(IP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  420     CONTINUE
C
          WI = H3((XV-XG(I+1))/DX)
          FV = FC(1)*WI+(1.-WI)*FC(2)
          GO TO 620
C
C         THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN TWO
C         RECTANGLES, (I,J) AND (I,J+1).
C
  440     CONTINUE
          DXA = XG(I+2)-XG(I)
          XVD = (XV-XG(I))/DXA
C
          DO 500 JP=1,2
            FC(JP) = 0.
            JS = J+JP-1
            IJ = (JS-1)*NXG+I
            IAL = 3*IJ-2
            DYA = YG(JS+2)-YG(JS)
            YVD = (YV-YG(JS))/DYA
            LMAX = NP(IJ+1)-NP(IJ)
C
            DO 460 L=1,LMAX
              MPS = NP(IJ)+L-1
              KJ = MP(MPS)
              XKJ = (XI(KJ)-XG(I))/DXA
              YKJ = (YI(KJ)-YG(JS))/DYA
              FC(JP) = FC(JP)+AB(MPS)*PHI(XKJ,YKJ,XVD,YVD)
  460       CONTINUE
C
            FC(JP)=FC(JP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  500     CONTINUE
C
          UJ = H3((YV-YG(J+1))/DY)
          FV = FC(1)*UJ+(1.-UJ)*FC(2)
          GO TO 620
C
C         THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN FOUR
C         RECTANGLES, (I,J), (I+1,J), (I,J+1), AND (I+1,J+1).
C
  520     CONTINUE
          KFC = 0
C
          DO 600 JP=1,2
            JS = J+JP-1
            DYA = YG(JS+2)-YG(JS)
            YVD = (YV-YG(JS))/DYA
C
            DO 580 IP=1,2
              IS = I+IP-1
              IJ = (JS-1)*NXG+IS
              IAL = 3*IJ-2
              KFC = KFC+1
              FC(KFC) = 0.
              DXA = XG(IS+2)-XG(IS)
              XVD = (XV-XG(IS))/DXA
              LMAX = NP(IJ+1)-NP(IJ)
C
              DO 540 L=1,LMAX
                MPS = NP(IJ)+L-1
                KI = MP(MPS)
                XKI = (XI(KI)-XG(IS))/DXA
                YKI = (YI(KI)-YG(JS))/DYA
                FC(KFC) = FC(KFC)+AB(MPS)*PHI(XKI,YKI,XVD,YVD)
  540         CONTINUE
C
              FC(KFC)=FC(KFC)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD
  580       CONTINUE
C
  600     CONTINUE
C
          WI = H3((XV-XG(I+1))/DX)
          UJ = H3((YV-YG(J+1))/DY)
          FV = WI*(UJ*FC(1)+(1.-UJ)*FC(3))+
     1         (1.-WI)*(UJ*FC(2)+(1.-UJ)*FC(4))
          FO(IO,JO) = FV
  620   CONTINUE
  640 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGARI(Y1,Y2,N1,IACASE,IWRITE,
     1Y3,N3,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR)
C
C     PURPOSE--CARRY OUT LOGICAL    ARITHMETIC OPERATIONS
C              OF THE REAL DATA IN Y1 AND Y2.
C
C     OPERATIONS--AND (OR CONJUNCTION OR MULTIPLICATION)
C                 OR (OR DISJUNCTION OR ADDITION)
C                 NAND
C                 NOR (OR EXCLUSIVE DISJUNCTION)
C                 IFTHEN (OR IMPLICATION)
C                 IFF (OR EQUIVALENCE)
C                 NOT (OR NEGATION OR NOT OR COMPLEMENT)
C                 XOR (OR EXCLUSIVE OR   OR EXCL. DISJUNCTION)
C
C     INPUT  ARGUMENTS--Y1 (REAL)
C                     --Y2 (REAL)
C     OUTPUT ARGUMENTS--Y3 (REAL)
C                       SCAL3
C                       ITYP3
C
C     NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT LOGICALY3(.)
C           BEING IDENTICAL TO THE INPUT LOGICALY1(.) OR Y2(.).
C     REFERENCE--HANDBOOK OF MATHEMATICAL TABLES AND FORMULAS,
C                BURINGTON, EDITION 5, PAGES 130-135.
C              --INTRODUCTION TO COMPUTER SCIENCE,
C                SCHEID, SCHAUM OUTLINE SERIES, PP. 3, 4, 6, 7, 43, 224.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--87/9
C     ORIGINAL VERSION--AUGUST   1987.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IACASE
      CHARACTER*4 IWRITE
      CHARACTER*4 ITYP3
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
C
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION Y3(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOGA'
      ISUBN2='RI  '
      IERROR='NO'
C
      SCAL3=(-999.0)
      ITYP3='VECT'
C
      TOL=0.00001
      ONE=1.0
      ONEMIN=ONE-TOL
      ONEMAX=ONE+TOL
      ZERO=0.0
      ZERMIN=ZERO-TOL
      ZERMAX=ZERO+TOL
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ISUBRO,IACASE,IWRITE
   52 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)N1
   53 FORMAT('N1 = ',I8)
      CALL DPWRST('XXX','BUG ')
      DO55I=1,N1
      WRITE(ICOUT,56)I,Y1(I),Y2(I)
   56 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
   55 CONTINUE
   90 CONTINUE
C
C               **************************************************
C               **  CARRY OUT LOGICAL    ARITHMETIC OPERATIONS  **
C               **************************************************
C
C               ********************************************
C               **  STEP 11--                             **
C               **  CHECK NUMBER OF INPUT OBSERVATIONS.   **
C               ********************************************
C
      IF(N1.LT.1)GOTO1100
      GOTO1190
C
 1100 CONTINUE
      IERROR='YES'
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      IN THE VARIABLE FOR WHICH')
      CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOAN')WRITE(ICOUT,1161)
 1161 FORMAT('      THE LOGICAL    AND    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOAN')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOOR')WRITE(ICOUT,1162)
 1162 FORMAT('      THE LOGICAL    OR     IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOOR')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONA')WRITE(ICOUT,1163)
 1163 FORMAT('      THE LOGICAL    NAND   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONA')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONO')WRITE(ICOUT,1164)
 1164 FORMAT('      THE LOGICAL    NOR    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONO')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOIM')WRITE(ICOUT,1165)
 1165 FORMAT('      THE LOGICAL    IMPLICATION   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOIM')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOEQ')WRITE(ICOUT,1166)
 1166 FORMAT('      THE LOGICAL    EQUIVALENCE   IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOEQ')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LONT')WRITE(ICOUT,1167)
 1167 FORMAT('      THE LOGICAL    NOT    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LONT')CALL DPWRST('XXX','BUG ')
      IF(IACASE.EQ.'LOXO')WRITE(ICOUT,1168)
 1168 FORMAT('      THE LOGICAL    XOR    IS TO BE ',
     1'COMPUTED')
      IF(IACASE.EQ.'LOXO')CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1181)
 1181 FORMAT('      MUST BE 1 OR LARGER.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1182)
 1182 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1183)N1
 1183 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8,
     1'.')
      CALL DPWRST('XXX','BUG ')
      GOTO9000
C
 1190 CONTINUE
C
C               *********************************
C               **  STEP 12--                  **
C               **  BRANCH TO THE PROPER CASE  **
C               *********************************
C
      IF(IACASE.EQ.'LOAN')GOTO2100
      IF(IACASE.EQ.'LOOR')GOTO2200
      IF(IACASE.EQ.'LONA')GOTO2300
      IF(IACASE.EQ.'LONO')GOTO2400
      IF(IACASE.EQ.'LOIM')GOTO2500
      IF(IACASE.EQ.'LOEQ')GOTO2600
      IF(IACASE.EQ.'LONT')GOTO2700
      IF(IACASE.EQ.'LOXO')GOTO2800
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1211)
 1211 FORMAT('***** INTERNAL ERROR IN LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1212)
 1212 FORMAT('      IACASE NOT EQUAL TO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1213)
 1213 FORMAT('      LOAN, LOOR, LONA, LONO, ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1214)
 1214 FORMAT('      LOIM, LOEQ, LONT, OR LOXO')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1215)
 1215 FORMAT('      IACASE = ',A4)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
C               *********************************************
C               **  STEP 21--                              **
C               **  TREAT THE LOGICAL    AND         CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 0 0 1 **
C               *********************************************
C
 2100 CONTINUE
      DO2110I=1,N1
      Y3(I)=ZERO
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE
 2110 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *********************************************
C               **  STEP 22--                              **
C               **  TREAT THE LOGICAL    OR          CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 1 1 1 **
C               *********************************************
C
 2200 CONTINUE
      DO2210I=1,N1
      Y3(I)=ONE
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2210 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 23--                                 **
C               **  TREAT THE LOGICAL    NAND           CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 1 1 0    **
C               ************************************************
C
 2300 CONTINUE
      DO2310I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO
 2310 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 24--                                 **
C               **  TREAT THE LOGICAL    NOR            CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 0 0 0    **
C               ************************************************
C
 2400 CONTINUE
      DO2410I=1,N1
      Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE
 2410 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ***************************************************
C               **  STEP 25--                                    **
C               **  TREAT THE LOGICAL    IMPLICATION       CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 1 0 1       **
C               ***************************************************
C
 2500 CONTINUE
      DO2510I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2510 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 26--                                 **
C               **  TREAT THE LOGICAL    EQUIVALENCE    CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  1 0 0 1    **
C               ************************************************
C
 2600 CONTINUE
      DO2610I=1,N1
      Y3(I)=ZERO
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE
 2610 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *********************************************
C               **  STEP 27--                              **
C               **  TREAT THE LOGICAL    NOT         CASE  **
C               **  0 1      YIELDS  1 0                   **
C               *********************************************
C
 2700 CONTINUE
      DO2710I=1,N1
      Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX)Y3(I)=ONE
 2710 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               ************************************************
C               **  STEP 28--                                 **
C               **  TREAT THE LOGICAL    XOR            CASE  **
C               **  0 0 1 1   &   0 1 0 1  YIELDS  0 1 1 0    **
C               ************************************************
C
 2800 CONTINUE
      DO2810I=1,N1
      Y3(I)=ONE
      IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND.
     1   ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO
      IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND.
     1   ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO
 2810 CONTINUE
C
      ITYP3='VECT'
      N3=N1
      GOTO9000
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LOGARI--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,ISUBRO,IACASE,IWRITE
 9012 FORMAT('IBUGA3,ISUBRO,IACASE,IWRITE = ',A4,2X,A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)IERROR
 9013 FORMAT('IERROR = ',A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9017)N1,N3
 9017 FORMAT('N1,N3 = ',2I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9018)SCAL3,ITYP3
 9018 FORMAT('SCAL3,ITYP3 = ',E15.7,2X,A4)
      CALL DPWRST('XXX','BUG ')
      IF(ITYP3.EQ.'SCAL')GOTO9090
      DO9021I=1,N1
      WRITE(ICOUT,9022)I,Y1(I),Y2(I)
 9022 FORMAT('I,Y1(I),Y2(I) = ',I8,2E13.5)
      CALL DPWRST('XXX','BUG ')
 9021 CONTINUE
      DO9031I=1,N3
      WRITE(ICOUT,9032)I,Y3(I)
 9032 FORMAT('I,Y3(I) = ',I8,E13.5)
      CALL DPWRST('XXX','BUG ')
 9031 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGGAM(X,ALG)
C
C     THIS PROGRAM CALCULATES THE LOG(TO BASE E) OF THE GAMMA FUNCTION
C     THE INPUT IS SINGLE PRECISION X
C     THE OUTPUT IS SINGLE PRECISION ALG
C     ALL INTERNAL OPERATIONS ARE DONE IN SINGLE PRECISION
C     THE ALGORITHM IS TO USE THE RECURSION FORMULA G(X)=G(X+1)/X
C     UNTIL X IS LARGE ENOUGH TO USE AN ASYMPTOTIC FORMULA FOR G(X)--THE CUT-OFF
C     POINT USED WAS X = 10
C     THE ASYMPTOTIC FORMULA USED IS IN AMS 55, PAGE 257, 6.1.41 (THE FIRST 9
C     TERMS OF THE SERIES WERE USED--I.E., OUT TO X**-17)
C     ALTHOUGH THE DATA STATEMENT DEFINES 10 COEFFICIENTS, THE PROGRAM MAKES USE
C     OF ONLY 9 COEFFICIENTS (THE ERROR BEING BOUNDED BY THE TENTH COEFFICIENT
C     DIVIDED BY X**19
C     SUBROUTINES NEEDED--NONE
C     PRINTING--NONE UNLESS AN ERROR CONDITION EXISTS
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --FEBRUARY  1981.
C     UPDATED         --FEBRUARY  1982.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION Y,Y2,Y3,Y4,Y5,DEN,A,B,C,D
C
      DIMENSION D(10)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
      DATA C/ .918938533204672741D0/
      DATA D(1),D(2),D(3),D(4),D(5)
     1                 /+.833333333333333333D-1,-.277777777777777778D-2,
     1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417
     151D-3/
      DATA D(6),D(7),D(8),D(9),D(10)
     1     /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359
     147712418D-1,+.179644372368830573D0,-.139243221690590111D1/
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(X.LE.0.0D0)GOTO50
      GOTO90
   50 WRITE(ICOUT,5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,45)X
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LOGGAM SUBROUTINE IS NON-POSITIVE *****')
   45 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D22.15,' *****')
C
      Y=X
      DEN=1.0D0
  100 IF(Y.GE.10.0D0)GOTO200
      DEN=DEN*Y
      Y=Y+1
      GOTO100
  200 Y2=Y*Y
      Y3=Y*Y2
      Y4=Y2*Y2
      Y5=Y2*Y3
      A=(Y-0.5D0)*DLOG(Y)-Y+C
      B=D(1)/Y+D(2)/Y3+D(3)/Y5+D(4)/(Y2*Y5)+D(5)/(Y4*Y5)+
     1D(6)/(Y*Y5*Y5)+D(7)/(Y3*Y5*Y5)+D(8)/(Y5*Y5*Y5)+D(9)/(Y2*Y5*Y5*Y5)
      ALG=(A+B)-DLOG(DEN)
C
      RETURN
      END
      SUBROUTINE LOGIST(N,X,X0,AK,IERROR)
C
C     PURPOSE--THIS SUBROUTINE GENERATES N LOGISTIC NUMBERS
C              (A CLASSIC CHAOS THEORY SEQUENCE)
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF LOGISTIC NUMBERS
C                                TO BE GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                LOGISTIC NUMBERS
C                                WILL BE PLACED.
C                     --X0     = THE STARTING VALUE
C                                (THIS WILL BE THE FIRST VALUE
C                                OF THE OUTPUT SEQUENCE)
C                     --AK    = THE INDEX FOR THE SYSTEM
C     OUTPUT--N LOGISTIC-SEQUENCE NUMBERS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--89.6
C     ORIGINAL VERSION--APRIL 1989.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IERROR
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CPUMA3=CPUMAX/3.0
C
C               ******************************************
C               **  TREAT THE LOGISTIC SEQUENCE CASE    **
C               ******************************************
C
C               *******************************************
C               **  STEP 1--                             **
C               **  TEST THE INPUT ARGUMENTS FOR ERRORS  **
C               *******************************************
C
      IF(N.GE.1)GOTO190
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,101)
  101 FORMAT('***** ERROR IN LOGIST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,102)
  102 FORMAT('      THE LENGTH OF THE DESIRED SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,103)
  103 FORMAT('      OF LOGISTIC NUMBERS MUST BE 1 OR LARGER;')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,104)
  104 FORMAT('      SUCH WAS NOT THE CASE HERE.')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,105)N
  105 FORMAT('      N = ',I8)
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
  190 CONTINUE
C
C               ******************************
C               **  STEP 2--                **
C               **  GENERATE THE SEQUENCE   **
C               ******************************
C
      X(1)=X0
      IF(N.LT.2)GOTO1190
      DO1100I=2,N
      I2=I
      IM1=I-1
      X(I)=AK*X(IM1)*(1.0-X(IM1))
      IF(X(I).GE.CPUMA3)GOTO1150
 1100 CONTINUE
      GOTO1190
C
 1150 CONTINUE
      I2P1=I2+1
      WRITE(ICOUT,1151)
 1151 FORMAT('***** ERROR IN LOGIST--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1152)
 1152 FORMAT('      A NUMBER IN THE LOGISTIC SEQUENCE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1153)
 1153 FORMAT('      HAS JUST EXCEEDED THE ')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1154)
 1154 FORMAT('      LARGEST FLOATING POINT NUMBER')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1155)
 1155 FORMAT('      ALLOWABLE FOR THIS COMPUTER (',E15.7,').')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1156)
 1156 FORMAT('      THE VALUE CAUSING THE OVERFLOW WAS')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1157)I2P1
 1157 FORMAT('      THE ',I8,'-TH NUMBER IN THE')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1158)
 1158 FORMAT('      LOGISTIC SEQUENCE.')
      CALL DPWRST('XXX','BUG ')
      IERROR='YES'
      GOTO9000
C
 1190 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LOGIT(X,N1,Y,N2,PSTAMV,IWRITE,XIDTEM,STAT,
     1                  IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE BIAS CORRECTED
C             LOGARITHM OF THE ODDS RATIO.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C                     --PSTAMV = THE MISSING VALUE CODE
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED LOG ODDS RATIO
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LOG ODDS RATIO BETWEEN THE 2 SETS
C             OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--ODDDIS.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE 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--2007/4
C     ORIGINAL VERSION--APRIL     2007.
C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
C                                       OF ENTRIES IS <= 4.  IN THIS
C                                       CASE, ASSUME WE HAVE RAW DATA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOGI'
      ISUBN2='T   '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LOGIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N1,N2
   53   FORMAT('N1,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MAX(N1,N2)
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N1.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN THE BIAS CORRECTED ',
     1         'LOG ODDS RATIO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N1
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N2.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1213)
 1213   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE SECOND ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N2
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C               ********************************************
C               **  STEP 22--                             **
C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
C               **  TWO DISTINCT VALUES (1 INDICATES A    **
C               **  SUCCESS, 0 INDICATES A FAILURE).      **
C               ********************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N1.EQ.2 .AND. N2.EQ.2)THEN
        N11=INT(X(1)+0.5)
        N21=INT(X(2)+0.5)
        N12=INT(Y(1)+0.5)
        N22=INT(Y(2)+0.5)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
C
        IF(N11.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N21.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N12.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N22.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        AN11=REAL(N11)
        AN21=REAL(N21)
        AN12=REAL(N12)
        AN22=REAL(N22)
        GOTO3000
      ENDIF
C
 1349 CONTINUE
C
      CALL ODDDIS(X,N1,PSTAMV,IWRITE,XIDTEM,N11,N21,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      CALL ODDDIS(Y,N2,PSTAMV,IWRITE,XIDTEM,N12,N22,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      AN11=REAL(N11)
      AN21=REAL(N21)
      AN12=REAL(N12)
      AN22=REAL(N22)
      GOTO3000
C
C     COMPUTE THE BIAS CORRECTED LOG OF THE ODDS RATIO.
C
 3000 CONTINUE
      AN1=AN11+AN21
      AN2=AN12+AN22
      AN=AN1 + AN2
C
      P11=AN11/AN1
      P21=AN21/AN1
      P12=AN12/AN2
      P22=AN22/AN2
C
      STAT=LOG((AN11+0.5)*(AN22+0.5)/((AN12+0.5)*(AN21+0.5)))
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF' .OR. IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)STAT
  811 FORMAT('THE BIAS CORRECTED LOG ODDS RATIO = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF LOGIT--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,N11,N12,N21,N22
 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)P11,P12,P21,P22
 9014   FORMAT('P11,P12,P21,P22 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)STAT
 9015   FORMAT('STAT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LOGISE(X,N1,Y,N2,PSTAMV,IWRITE,XIDTEM,STAT,
     1                  IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE STANDARD ERROR OF THE
C              BIAS CORRECTED LOGARITHM OF THE ODDS RATIO.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE FIRST SET
C                                OF DATA.
C                     --N1     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --Y      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED) OBSERVATIONS
C                                WHICH CONSTITUTE THE SECOND SET
C                                OF DATA.
C                     --N2     = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR Y.
C     OUTPUT ARGUMENTS--STAT   = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED STANDARD ERROR OF THE
C                                LOG ODDS RATIO (BIAS CORRECTED)
C                                BETWEEN THE 2 SETS OF DATA
C                                IN THE INPUT VECTORS X AND Y.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE STANDARD ERROR OF THE LOG ODDS RATIO BETWEEN
C             THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--ODDDIS.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTIUTE 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--2007/4
C     ORIGINAL VERSION--APRIL     2007.
C     UPDATED         --AUGUST    2007. IF 2X2 CASE, CHECK IF SUM
C                                       OF ENTRIES IS <= 4.  IN THIS
C                                       CASE, ASSUME WE HAVE RAW DATA
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISTEPN
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(*)
      DIMENSION XIDTEM(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOGI'
      ISUBN2='SE  '
      IERROR='NO'
C
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LOGISE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3
   52   FORMAT('IBUGA3 = ',A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N1,N2
   53   FORMAT('N1,N2 = ',2I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MAX(N1,N2)
          WRITE(ICOUT,56)I,X(I),Y(I)
   56     FORMAT('I,X(I),Y(I) = ',I8,2G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ********************************************
C               **  STEP 21--                             **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IF(N1.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
 1201   FORMAT('***** ERROR IN STANDARD ERROR OF BIAS CORRECTED ',
     1         'LOG ODDS RATIO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1203)
 1203   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N1
 1205   FORMAT('SAMPLE SIZE = ',I8)
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N2.LT.2)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1201)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1213)
 1213   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE SECOND ',
     1         'RESPONSE VARIABLES IS LESS THAN TWO')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,1205)N2
        CALL DPWRST('XXX','WRIT')
        IERROR='YES'
        GOTO9000
      ENDIF
C
C     NOTE: CHECK FOR SPECIAL CASE N = 2.  IN THIS CASE,
C           ASSUME WE HAVE A 2X2 TABLE OF COUNTS INSTEAD
C           OF RAW DATA.
C
      IF(N1.EQ.2 .AND. N2.EQ.2)THEN
        N11=INT(X(1)+0.5)
        N21=INT(X(2)+0.5)
        N12=INT(Y(1)+0.5)
        N22=INT(Y(2)+0.5)
C
C       CHECK IF ALL ENTRIES 0 OR 1. IF SO, ASSUME
C       RAW DATA CASE.
C
        IF((N11.EQ.0 .OR. N11.EQ.1) .AND.
     1     (N12.EQ.0 .OR. N12.EQ.1) .AND.
     1     (N21.EQ.0 .OR. N21.EQ.1) .AND.
     1     (N22.EQ.0 .OR. N22.EQ.1)) GOTO1349
C
        IF(N11.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1311)
 1311     FORMAT('      ROW 1 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N21.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1321)
 1321     FORMAT('      ROW 2 COLUMN 1 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N12.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1331)
 1331     FORMAT('      ROW 1 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ELSEIF(N22.LT.0)THEN
          WRITE(ICOUT,999)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1201)
          CALL DPWRST('XXX','BUG ')
          WRITE(ICOUT,1341)
 1341     FORMAT('      ROW 2 COLUMN 2 OF THE COUNTS TABLE IS ',
     1           'NEGATIVE.')
          CALL DPWRST('XXX','BUG ')
        ENDIF
C
        AN11=REAL(N11)
        AN21=REAL(N21)
        AN12=REAL(N12)
        AN22=REAL(N22)
        GOTO3000
      ENDIF
C
C
C               ********************************************
C               **  STEP 22--                             **
C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
C               **  TWO DISTINCT VALUES (1 INDICATES A    **
C               **  SUCCESS, 0 INDICATES A FAILURE).      **
C               ********************************************
C
 1349 CONTINUE
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL ODDDIS(X,N1,PSTAMV,IWRITE,XIDTEM,N11,N21,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      CALL ODDDIS(Y,N2,PSTAMV,IWRITE,XIDTEM,N12,N22,NOUT,
     1            IBUGA3,IERROR)
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'ON')GOTO9000
      AN11=REAL(N11)
      AN21=REAL(N21)
      AN12=REAL(N12)
      AN22=REAL(N22)
      GOTO3000
C
C     COMPUTE THE BIAS CORRECTED LOG OF THE ODDS RATIO.
C
 3000 CONTINUE
      AN1=AN11+AN21
      AN2=AN12+AN22
      AN=AN1 + AN2
C
      P11=AN11/AN1
      P21=AN21/AN1
      P12=AN12/AN2
      P22=AN22/AN2
C
      STAT=SQRT((1.0/(AN11+0.5)) + (1.0/(AN21+0.5)) +
     1         (1.0/(AN12+0.5)) + (1.0/(AN22+0.5)))
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'OFF')GOTO890
      IF(IWRITE.EQ.'OFF' .OR. IWRITE.EQ.'NO')GOTO890
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,811)STAT
  811 FORMAT('THE STANDARD ERROR OF BIAS CORRECTED LOG ODDS ',
     1       'RATIO = ',G15.7)
      CALL DPWRST('XXX','BUG ')
  890 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END OF LOGISE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N,N11,N12,N21,N22
 9013   FORMAT('N,N11,N12,N21,N22 = ',5I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)P11,P12,P21,P22
 9014   FORMAT('P11,P12,P21,P22 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)STAT
 9015   FORMAT('STAT = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LOGCDF(X,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      IF(X.GE.0.0)GOTO150
      CDF=EXP(X)/(1.0+EXP(X))
      RETURN
  150 CDF=1.0/(1.0+EXP(-X))
      RETURN
C
      END
      SUBROUTINE LOGCHA(X,CHAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE CUMULATIVE HAZARD FUNCTION
C              F(X) = 1/(1+EXP(-X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION CUMULATIVE
C                                HAZARD FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL
C                 DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      CHAZ=LOG(1.0+EXP(-X))
C
      RETURN
      END
      SUBROUTINE LOGFUN (N, X, FVEC, IFLAG, XDATA, NOBS)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LOGISTIC MAXIMUM LIKELIHOOD EQUATIONS.
C
C              SUM[i=1 to n][1+EXP{-(X(i)-ahat)/bhat}]**(-1)-N/2 = 0
C
C              (X(i)-ahat)/bhat)/SUM[i=1 to n][1+EXP{-(X(i)-ahat)}]**(-1)
C              - 0.5*SUM[i=1 to n][(X(i)-ahat)/bhat] - 0.5*N = 0
C
C              CALLED BY SNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C     EXAMPLE--PARETO MAXIMUM LIKELIHOOD Y
C     REFERENCE--CHARLES ANTLE, LAWRENCE KLIMKO, AND WILLIAM
C                HARKNESS, (1970), "CONFIDENCE INTERVALS FOR THE
C                PARAMETERS OF THE LOGISTIC DISTRIBUTION", BIOMETRIKA,
C                PP. 397-402.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 CENTER FOR APPLIED MATHEMATICS
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2003/10
C     ORIGINAL VERSION--OCTOBER   2003.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION X(*)
      DOUBLE PRECISION FVEC(*)
      REAL XDATA(*)
C
      DOUBLE PRECISION DN
      DOUBLE PRECISION DA
      DOUBLE PRECISION DB
      DOUBLE PRECISION DX
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DSUM3
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      N=2
      IFLAG=0
C
      DN=DBLE(NOBS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DSUM3=0.0D0
      DA=X(1)
      DB=X(2)
      DO100I=1,NOBS
        DX=DBLE(XDATA(I))
        DTERM1=(DX - DA)/DB
        DTERM2=1.0D0 + DEXP(-DTERM1)
        DSUM1=DSUM1 + 1.0D0/DTERM2
        DSUM2=DSUM2 + DTERM1/DTERM2
        DSUM3=DSUM3 + DTERM1
  100 CONTINUE
C
      DTERM1=DSUM1 - 0.5D0*DN
      DTERM2=DSUM2 - 0.5D0*DSUM3 - 0.5D0*DN
C
C COMPUTE NONLINEAR FUNCTIONS
C
      FVEC(1) = DTERM1
      FVEC(2) = DTERM2
C
      RETURN
      END
      SUBROUTINE LOGHAZ(X,HAZ)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE HAZARD FUNCTION
C              F(X) = 1/(1+EXP(-X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE HAZARD
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--HAZ    = THE SINGLE PRECISION HAZARD
C                                FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION HAZARD
C             FUNCTION VALUE HAZ.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL
C                 DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-975-2899
C     ORIGINAL VERSION--OCTOBER   2003.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      HAZ=1.0/(1.0+EXP(-X))
C
      RETURN
      END
      SUBROUTINE LOGLI1(Y,N,ALOC,SCALE,ALIK,AIC,AICC,BIC,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR
C              THE LOGISTIC DISTRIBUTION.  THIS IS FOR THE RAW DATA
C              CASE (I.E., NO GROUPING AND NO CENSORING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C     WRITTEN BY--ALAN HECKERT
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--2009/10
C     ORIGINAL VERSION--OCTOBER   2009.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRITE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DS
      DOUBLE PRECISION DU
      DOUBLE PRECISION DN
      DOUBLE PRECISION DNP
      DOUBLE PRECISION DLIK
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM3
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOGL'
      ISUBN2='I1  '
      IERROR='NO'
C
      ALIK=-99.0
      AIC=-99.0
      AICC=-99.0
      BIC=-99.0
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LOGLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO
   52   FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,55)N,ALOC,SCALE
   55   FORMAT('N,ALOC,SCALE = ',I8,2G15.7)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  COMPUTE LIKELIHOOD FUNCTION         **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IERFLG=0
      IERROR='NO'
      IWRITE='OFF'
C
C     THE LOGISTIC LOG-LIKELIHOOD FUNCTION CAN BE GIVEN AS:
C
C     SUM[i=1 to N][(X(I)-LOC)/SCALE)]  - 2*N*LOG(SCALE) -
C     2*SUM[i=1 to N][LOG(1 + EXP((X(I)-LOC)/SCALE)]
C
      DN=DBLE(N)
      DS=DBLE(SCALE)
      DU=DBLE(ALOC)
      DTERM1=-2.0D0*DN*DLOG(DS)
      DSUM1=0.0D0
      DSUM2=0.0D0
      DO1000I=1,N
        DX=DBLE(Y(I))
        DSUM1=DSUM1 + (DX-DU)/DS
        DSUM2=DSUM2 + DLOG(1.0D0 + DEXP((DX-DU)/DS))
 1000 CONTINUE
C
      DLIK=DSUM1 + DTERM1 - 2.0D0*DSUM2
      ALIK=REAL(DLIK)
      DNP=2.0D0
      AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP)
      DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0)
      AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3)
      BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GLI1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LOGLI1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9013)DSUM1,DSUM2,DTERM1,DTERM3
 9013   FORMAT('DSUM1,DSUM2,DTERM1,DTERM3 = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC
 9014   FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LOGML1(Y,N,MAXNXT,
     1                  DTEMP1,
     1                  XMEAN,XSD,XMIN,XMAX,
     1                  ALOC,ASCALE,
     1                  ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES
C              FOR THE LOGISTIC DISTRIBUTION FOR THE RAW DATA CASE
C              (I.E., NO CENSORING AND NO GROUPING).
C
C              IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN
C              PERFORMED.
C
C              PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED
C              FROM MULTIPLE PLACES (DPMLLO WILL GENERATE THE OUTPUT
C              FOR THE LOGISTIC MLE COMMAND).
C
C     REFERENCE--CHARLES ANTLE, LAWRENCE KLIMKO, AND WILLIAM
C                HARKNESS, (1970), "CONFIDENCE INTERVALS FOR THE
C                PARAMETERS OF THE LOGISTIC DISTRIBUTION", BIOMETRIKA,
C                PP. 397-402.
C     WRITTEN BY--ALAN HECKERT
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--2009/9
C     ORIGINAL VERSION--OCTOBER   2009. EXTRACTED AS A SEPARATE
C                                       SUBROUTINE (FROM DPMLLO)
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*40 IDIST
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
      INTEGER IFLAG
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DOUBLE PRECISION DTEMP1(*)
C
      DOUBLE PRECISION TOL
      DOUBLE PRECISION XPAR(2)
      DOUBLE PRECISION FVEC(2)
C
      EXTERNAL LOGFUN
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      DATA PI/3.14159265358979/
C
      ISUBN1='LOGM'
      ISUBN2='L1  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,51)
   51   FORMAT('**** AT THE BEGINNING OF LOGML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT
   52   FORMAT('IBUGA3,ISUBRO,N,MAXNXT = ',A4,2X,A4,2X,2I8)
        CALL DPWRST('XXX','WRIT')
        DO56I=1,MIN(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 1--                            **
C               **  CARRY OUT CALCULATIONS              **
C               **  FOR LOGISTIC MLE ESTIMATE           **
C               ******************************************
C
      ISTEPN='1'
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')
     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      IDIST='LOGISTIC'
      IFLAG=0
      CALL SUMRAW(Y,N,IDIST,IFLAG,
     1            XMEAN,XVAR,XSD,XMIN,XMAX,
     1            ISUBRO,IBUGA3,IERROR)
C
      XPAR(1)=DBLE(XMEAN)
      XPAR(2)=DBLE((SQRT(3.0)/PI)*XSD)
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')THEN
        WRITE(ICOUT,101)XPAR(1),XPAR(2)
  101   FORMAT('XPAR(1),XPAR(2) = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      IOPT=2
      TOL=1.0D-6
      NVAR=2
      NPRINT=-1
      INFO=0
      JAC=0
      LWA=MAXNXT
      CALL DNSQE(LOGFUN,JAC,IOPT,NVAR,XPAR,FVEC,TOL,NPRINT,INFO,
     1           DTEMP1,MAXNXT,Y,N)
C
      ALOC=REAL(XPAR(1))
      ASCALE=REAL(XPAR(2))
C
      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GML1')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9011)
 9011   FORMAT('**** AT THE END OF LOGML1--')
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9055)N,XMEAN,XSD,XMIN,XMAX
 9055   FORMAT('N,XMEAN,XSD,XMIN,XMAX = ',I8,4G15.7)
        CALL DPWRST('XXX','WRIT')
        WRITE(ICOUT,9056)ALOC,ASCALE
 9056   FORMAT('ALOC,ASCALE = ',2G15.7)
        CALL DPWRST('XXX','WRIT')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LOGPDF(X,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS.
C     NO INPUT ARGUMENT ERRORS POSSIBLE
C     FOR THIS DISTRIBUTION.
C
C-----START POINT-----------------------------------------------------
C
      PDF=EXP(X)/((1.0+EXP(X))**2)
C
      RETURN
      END
      SUBROUTINE LOGPPF(P,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT
C                                POINT FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LOGPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
CCCCC CALL QCORR(P,Q)
CCCCC PPF=LOG(P/Q)
      PPF=LOG(P/(1.0-P))
C
      RETURN
      END
      SUBROUTINE LOGRAN(N,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOGISTIC DISTRIBUTION
C             WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--TOCHER, THE ART OF SIMULATION,
C                 1963, PAGES 14-15.
C               --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS,
C                 1964, PAGE 36.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGE 230.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --DECEMBER  1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)GOTO50
      GOTO90
   50 WRITE(ICOUT, 5)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,47)N
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ',
     1'LOGRAN SUBROUTINE IS NON-POSITIVE *****')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     GENERATE N UNIFORM (0,1) RANDOM NUMBERS;
C
      CALL UNIRAN(N,ISEED,X)
C
C     GENERATE N LOGISTIC RANDOM NUMBERS
C     USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD.
C
      DO100I=1,N
      X(I)=LOG(X(I)/(1.0-X(I)))
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOGRD(X,N,NX,XG,T)
C     THIS SUBROUTINE PLACES A SET OF INTERVALS OVER THE SET OF POINTS
C     (X(I), I=1,...,N).  THIS IS DONE BY PLACING APPROXIMATELY EQUAL
C     NUMBERS OF THEM WITHIN EACH INTERVAL.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        N   - INPUT.  THE NUMBER OF POINTS IN THE ARRAY X.
C        X   - INPUT.  THE ARRAY OF X POINTS.
C        NX  - INPUT.  THE DESIRED NUMBER OF INTERVALS.
C        XG  - OUTPUT.  THE COORDINATES OF THE INTERVAL ENDPOINTS.
C        T   - WORK ARRAY OF DIMENSION AT LEAST N.
C
C     SUBROUTINES USED
C        SLATEC:  SSORT
C
      DIMENSION X(*),XG(*),T(*)
C
      DO 100 I=1,N
        T(I) = X(I)
  100 CONTINUE
C
CCCCC CALL SSORT(T,T,N,1)
      CALL SORT(T,N,T)
C
      FINC = REAL(N-1)/REAL(NX+1)
      DO 140 J=1,NX
        FK = J*FINC + 1.
        K = INT(FK)
        WK1 = FK - K
        XG(J+1) = (1. - WK1)*T(K) + WK1*T(K+1)
  140 CONTINUE
C
      XG(1) = T(1)
      XG(NX+2) = T(N)
C
      RETURN
      END
      SUBROUTINE LOGSF(P,SF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY
C              FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION
C              WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3).
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = EXP(X)/(1+EXP(X)).
C              NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION
C              IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION,
C              AND ALSO IS THE RECIPROCAL OF THE PROBABILITY
C              DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X).
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                (BETWEEN 0.0 AND 1.0)
C                                AT WHICH THE SPARSITY
C                                FUNCTION IS TO BE EVALUATED.
C     OUTPUT ARGUMENTS--SF     = THE SINGLE PRECISION
C                                SPARSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION SPARSITY
C             FUNCTION VALUE SF.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN.
C     REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, 'THE PERCENT POINT FUNCTION',
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGES 1-21.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY (205.03)
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE:  301-921-2315
C     ORIGINAL VERSION--APRIL     1994.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C---------------------------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.0.OR.P.GE.1.0)GOTO50
      GOTO90
   50 CONTINUE
      WRITE(ICOUT,1)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,46)P
      CALL DPWRST('XXX','BUG ')
      RETURN
   90 CONTINUE
    1 FORMAT(
     1'***** FATAL ERROR--THE FIRST  INPUT ARGUMENT TO THE LOGSF')
    2 FORMAT(
     1'SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL *****')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****')
C
C-----START POINT-----------------------------------------------------
C
      SF=1.0/(P-P*P)
C
      RETURN
      END
      SUBROUTINE LOSCDF(X,P,IR,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS P AND
C              IR.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= IR.
C              THIS DISTRIBUTION HAS THE PROBABILITY MASS FUNCTION
C              p(X;P,IR) = (2*X-IR  X)*(1-P)**(X-IR)*(P)**X
C                          *(IR/(2*X-IR))   X = IR, IR+ 1, ...
C                                  (X*(X-K)!)
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.  IT CAN ALSO BE USED TO MODEL A
C              QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON
C              PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS
C              EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE
C              ARE R INITIAL CUSTOMERS.  THE LOST GAMES DISTRIBUTION
C              IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS
C              SERVED UNTIL THE QUEUE FIRST VANISHES WITH
C              P = LAMBDA/(LAMBDA+MU).
C
C              NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF
C              THE PDF.  HOWEVER, WE USE P > 0.5 (I.E., THE
C              PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN
C              HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY
C              GAMBLER WINS ON A GIVEN HAND.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE AN INTEGR >= IR.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --IR     = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOST GAMES DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE AN INTEGER >= IR
C                 --0.5 < P < 1,  AND IR >= 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 445-447.
C               --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLANG, PP. 758-759.
C               --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED
C                 WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF
C                 THE ROYAL STATISTICAL SOCIETY, SERIES B, 30,
C                 PP. 401-410.
C               --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE
C                 BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
CCCCC DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.5 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSCDF ',
     1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL')
C
      IF(IR.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IR
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSCDF IS ',
     1' NEGATIVE')
      INTX=INT(X+0.5)
      IF(INTX.LT.IR)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)INTX
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSCDF IS LESS ',
     1'THAN THE THIRD ARUGMENT')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
   48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8)
C
      DP=DBLE(P)
      DR=DBLE(IR)
      DCDF=0.0D0
C
CCCCC DO100I=INTX,IR,-1
CCCCC   DX=DBLE(I)
CCCCC   DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) -
CCCCC1         DLNGAM(DX-DR+1.0D0)
CCCCC   DTERM2=(DX-DR)*DLOG(1.0D0-DP) + DX*DLOG(DP)
CCCCC   DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR)
CCCCC   DPDF=DEXP(DTERM1 + DTERM2 + DTERM3)
CCCCC   DCDF=DCDF+DPDF
CC100 CONTINUE
C
CCCCC CDF=REAL(DCDF)
C
C     USE THE RECURRENCE RELATION (FROM KEMP AND KEMP):
C
C     P(X;P,R) = C*P(X-1;P,R)
C
C     WHERE
C
C        C = (2*X-R-1)*(2*X-R-2)*P*(1-P)/[X*(X-R)]
C
      DC1=DLOG(DP) + DLOG(1.0D0 - DP)
      DPDF=DR*DLOG(DP)
      DPDFSV=DPDF
      DCDF=DEXP(DPDF)
C
      IF(INTX.GT.IR)THEN
        DO200I=IR+1,INTX
          DX=DBLE(I)
          DC2=DLOG(2.0D0*DX-DR-1.0D0) + DLOG(2.0D0*DX-DR-2.0D0)
          DC3=DLOG(DX) + DLOG(DX-DR)
          DPDF=DC2 - DC3 + DC1 + DPDFSV
          DCDF=DCDF + DEXP(DPDF)
          DPDFSV=DPDF
  200   CONTINUE
      ENDIF
C
      CDF=REAL(DCDF)
C
 9999 CONTINUE

      RETURN
      END
      SUBROUTINE LOSPDF(X,P,IR,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS P AND
C              IR.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= IR.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;P,IR) = (2*X-IR  X)*(1-P)**(X-IR)*(P)**X
C                          *(IR/(2*X-IR))   X = IR, IR+ 1, ...
C                                  (X*(X-K)!)
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.  IT CAN ALSO BE USED TO MODEL A
C              QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON
C              PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS
C              EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE
C              ARE R INITIAL CUSTOMERS.  THE LOST GAMES DISTRIBUTION
C              IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS
C              SERVED UNTIL THE QUEUE FIRST VANISHES WITH
C              P = LAMBDA/(LAMBDA+MU).
C
C              NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF
C              THE PDF.  HOWEVER, WE USE P > 0.5 (I.E., THE
C              PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN
C              HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY
C              GAMBLER WINS ON A GIVEN HAND.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY MASS
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE AN INTEGR >= IR.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --IR     = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF
C             FOR THE LOST GAMES DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0.5 < P < 1,  AND IR >= 1
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 445-447.
C               --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLANG, PP. 758-759.
C               --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED
C                 WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF
C                 THE ROYAL STATISTICAL SOCIETY, SERIES B, 30,
C                 PP. 401-410.
C               --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE
C                 BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DR
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(P.LE.0.5 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSPDF ',
     1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL')
C
      IF(IR.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IR
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSPDF IS ',
     1' NON-POSITIVE')
      INTX=INT(X+0.5)
      IF(INTX.LT.IR)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,48)INTX
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSPDF IS LESS ',
     1'THAN THE THIRD ARUGMENT')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
   48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8)
C
      DX=DBLE(INTX)
      DP=DBLE(P)
      DR=DBLE(IR)
C
      DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) -
     1       DLNGAM(DX-DR+1.0D0)
      DTERM2=(DX-DR)*DLOG(1.0D0-DP) + DX*DLOG(DP)
      DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR)
      DPDF=DEXP(DTERM1 + DTERM2 + DTERM3)
C
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LOSPPF(P,PPAR,IR,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE LOST GAMES DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS PPAR AND
C              IR.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= IR.
C              THIS DISTRIBUTION HAS THE PROBABILITY MASS FUNCTION
C              p(X;P,IR) = (2*X-IR  X)*(1-P)**(X-IR)*(P)**X
C                          *(IR/(2*X-IR))   X = IR, IR+ 1, ...
C                                  (X*(X-K)!)
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.  IT CAN ALSO BE USED TO MODEL A
C              QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON
C              PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS
C              EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE
C              ARE R INITIAL CUSTOMERS.  THE LOST GAMES DISTRIBUTION
C              IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS
C              SERVED UNTIL THE QUEUE FIRST VANISHES WITH
C              P = LAMBDA/(LAMBDA+MU).
C
C              NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF
C              THE PDF.  HOWEVER, WE USE P > 0.5 (I.E., THE
C              PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN
C              HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY
C              GAMBLER WINS ON A GIVEN HAND.
C
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                0 <= P <= 1.
C                     --PPAR   = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --IR     = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF FOR THE LOST GAMES DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P <= 1
C                 --0.5 < P < 1,  AND IR >= 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--DLNGAM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 445-447.
C               --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLANG, PP. 758-759.
C               --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED
C                 WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF
C                 THE ROYAL STATISTICAL SOCIETY, SERIES B, 30,
C                 PP. 401-410.
C               --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE
C                 BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DPPAR
      DOUBLE PRECISION DR
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DPDFSV
      DOUBLE PRECISION DCDF
CCCCC DOUBLE PRECISION DTERM1
CCCCC DOUBLE PRECISION DTERM2
CCCCC DOUBLE PRECISION DTERM3
CCCCC DOUBLE PRECISION DLNGAM
      DOUBLE PRECISION DC1
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DC3
      DOUBLE PRECISION DEPS
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(PPAR.LE.0.5 .OR. PPAR.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSPPF ',
     1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL')
C
      IF(IR.LT.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IR
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSPPF IS ',
     1' NEGATIVE')
C
      IF(P.LT.0.0 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,13)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9999
      ENDIF
   13 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSPPF ',
     1' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
C     USE THE RECURRENCE RELATION (FROM KEMP AND KEMP):
C
C     P(X;P,R) = C*P(X-1;P,R)
C
C     WHERE
C
C        C = (2*X-R-1)*(2*X-R-2)*P*(1-P)/[X*(X-R)]
C
      DEPS=1.0D-7
      DPPAR=DBLE(PPAR)
      DP=DBLE(P)
      DR=DBLE(IR)
      I=IR
      DPDFSV=DR*DLOG(DPPAR)
      DCDF=DEXP(DPDFSV)
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=REAL(IR)
        GOTO9999
      ENDIF
C
      DC1=DLOG(DPPAR) + DLOG(1.0D0 - DPPAR)
  100 CONTINUE
        I=I+1
        IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN
          WRITE(ICOUT,55)
   55     FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ',
     1           'EXCEEDS THE LARGEST MACHINE INTEGER.')
          CALL DPWRST('XXX','BUG ')
          PPF=REAL(I)
          GOTO9999
        ENDIF
        DX=DBLE(I)
CCCCC   DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) -
CCCCC1         DLNGAM(DX-DR+1.0D0)
CCCCC   DTERM2=(DX-DR)*DLOG(1.0D0-DPPAR) + DX*DLOG(DPPAR)
CCCCC   DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR)
CCCCC   DPDF=DEXP(DTERM1 + DTERM2 + DTERM3)
CCCCC   DCDF=DCDF+DPDF
        DC2=DLOG(2.0D0*DX-DR-1.0D0) + DLOG(2.0D0*DX-DR-2.0D0)
        DC3=DLOG(DX) + DLOG(DX-DR)
        DPDF=DC2 - DC3 + DC1 + DPDFSV
        DCDF=DCDF + DEXP(DPDF)
        DPDFSV=DPDF
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
      GOTO100
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LOSRAN(N,P,IR,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOST GAMES DISTRIBUTION
C              WITH SHAPE PARAMETERS P AND IR.
C              IR.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= IR.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;P,IR) = (2*X-IR  X)*(1-P)**(X-IR)*(P)**X
C                          *(IR/(2*X-IR))   X = IR, IR+ 1, ...
C                                  (X*(X-K)!)
C              THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S
C              RUIN" PROBLEM.  IT CAN ALSO BE USED TO MODEL A
C              QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON
C              PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS
C              EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE
C              ARE R INITIAL CUSTOMERS.  THE LOST GAMES DISTRIBUTION
C              IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS
C              SERVED UNTIL THE QUEUE FIRST VANISHES WITH
C              P = LAMBDA/(LAMBDA+MU).
C
C              NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF
C              THE PDF.  HOWEVER, WE USE P > 0.5 (I.E., THE
C              PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN
C              HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY
C              GAMBLER WINS ON A GIVEN HAND.
C
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --P      = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --IR     = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N FROM THE LOST GAMES
C             DISTRIBUTION WITH SHAPE PARAMETERS P AND IR.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --0 < P < 1, IR A NON-NEGATIVE INTEGER
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LOSPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 445-447.
C               --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE
C                 GENERATION", SPRINGER-VERLANG, PP. 758-759.
C               --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED
C                 WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF
C                 THE ROYAL STATISTICAL SOCIETY, SERIES B, 30,
C                 PP. 401-410.
C               --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE
C                 BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      INTEGER N
      INTEGER IR
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1'LOST GAMES RANDOM NUMBERS IS NON-POSITIVE')
C
      IF(P.LE.0.5 .OR. P.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   11 FORMAT('***** ERROR--THE P PARAMETER FOR THE LOST GAMES')
   12 FORMAT('      RANDOM NUMBERS IS OUTSIDE THE ALLOWABLE (0.5,1) ',
     1       'INTERVAL')
C
      IF(IR.LT.0)THEN
        WRITE(ICOUT,21)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)IR
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
   21 FORMAT('***** ERROR--THE R PARAMETER FOR THE LOST GAMES ',
     1       'RANDOM NUMBERS IS NON-POSITIVE')
C
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        XTEMP=X(I)
        CALL LOSPPF(XTEMP,P,IR,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOLIP (NXG,XG,NYG,YG,NPI,XI,YI,NP,MP,MPM,NMAX,D)
C
C     THIS SUBROUTINE DETERMINES THE LOCAL INTERPOLATION POINTS FOR THE
C     GRID VERSION OF FRANKE'S METHOD OF SURFACE INTERPOLATION.
C     MINPTS POINTS ARE REQUIRED FOR EACH REGION.
C     IF FEWER THAN MINPTS POINTS ARE FOUND IN THE REGION, THE NEXT
C     CLOSEST POINTS (IN THE SUP NORM AFTER THE CURRENT RECTANGLE IS
C     TRANSFORMED ONTO (0,1)) ARE USED.  MINPTS IS SET TO 3, WHICH IS
C     THE RECOMMENDED VALUE, ALTHOUGH IT MAY BE ALTERED.
C
C     THE ARGUMENTS ARE AS FOLLOWS.
C
C        NXG  - INPUT.  NUMBER OF VERTICAL GRID LINES.
C        XG   - INPUT.  THE COORDINATES OF THE VERTICAL GRID LINES, IN
C                       INCREASING ORDER
C        NYG  - INPUT.  NUMBER OF HORIZONTAL GRID LINES.
C        YG   - INPUT.  THE COORDINATES OF THE HORIZONTAL GRID LINES,
C                       IN INCREASING ORDER.
C        NPI  - INPUT.  THE NUMBER OF DATA POINTS.
C        XI   - \
C        YI   - INPUT.  THE DATA POINTS (XI,YI), I=1,...,NPI.
C        FI   - /
C        NP   - OUTPUT.  AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN
C                       THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS ARE STORED.
C        MP   - OUTPUT.  AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE
C                       LOCAL INTERPOLATION POINTS.
C        MPM  - INPUT.  DIMENSION OF THE ARRAY MP IN THE CALLING PROGRAM
C        NMAX - OUTPUT.  THE MAXIMUM NUMBER OF INTERPOLATION POINTS
C                        OVER ALL THE REGIONS.
C        D    - A WORK ARRAY OF DIMENSION AT LEAST NPI.
C
      DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), D(*)
      DATA MINPTS/3/
      IJ = 1
      NP(1) = 1
      NMAX = 0
      L = 0
C
      DO 200 J=1,NYG
        YGA = (YG(J+2)+YG(J))/2.
        DYG = YG(J+2)-YG(J)
C
        DO 180 I=1,NXG
          XGA = (XG(I+2)+XG(I))/2.
          DXG = XG(I+2)-XG(I)
          IJ = IJ+1
C
C         DETERMINE THE POINTS IN THE (I,J)TH RECTANGLE.
C
          DO 120 NK=1,NPI
            D(NK) = AMAX1(ABS(XI(NK) - XGA)/DXG,ABS(YI(NK) - YGA)/DYG)
            IF(D(NK).GT..6125)GO TO 120
            D(NK) = 1.E10
            L = L + 1
            LL = MIN0(L,MPM)
            MP(LL) = NK
  120     CONTINUE
C
          NP(IJ) = L+1
          IF (NP(IJ)-NP(IJ-1).GE.MINPTS) GO TO 180
C
C         ADD THE CLOSEST POINTS IF THERE ARE LESS THAN MINPTS IN THE
C         RECTANGLE.
C
          LM = MINPTS-(NP(IJ)-NP(IJ-1))
C
          DO 160 II=1,LM
            L = L+1
            LL = MIN0(L,MPM)
            MP(LL) = 1
            DM = D(1)
C
            DO 140 NK=2,NPI
              IF (D(NK).GE.DM) GO TO 140
              DM = D(NK)
              MP(LL) = NK
  140       CONTINUE
C
            NK = MP(LL)
            D(NK) = 1.E10
  160     CONTINUE
C
          NP(IJ) = L+1
          NMAX = MAX0(NMAX,NP(IJ)-NP(IJ-1))
C
  180   CONTINUE
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOTPS (MODE,NPPR,NPI,XI,YI,FI,NXO,XO,NYO,YO,IWK,NIWK,
     1                  NIWKU,WK,NWK,NWKU,FO,KER)
C***START PROLOGUE LOTPS
C
C     THIS VERSION IS DATED 03/04/82.
C
C                RICHARD FRANKE
C                DEPARTMENT OF MATHEMATICS
C                NAVAL POSTGRADUATE SCHOOL
C                MONTEREY, CALIFORNIA  93940
C                     (408)646-2758 / 2206
C
C
C
C     REFERENCE
C        SMOOTH INTERPOLATION OF SCATTERED DATA BY LOCAL THIN
C        PLATE SPLINES, COMPUTERS AND MATHEMATICS WITH
C        APPLICATIONS 8(1982)???-???+8
C                    OR
C        NAVAL POSTGRADUATE SCHOOL TR#NPS-53-81-002, 1981
C        (AVAILABLE FROM NTIS, AD-A098 232/2)
C
C     ABSTRACT
C        SUBROUTINE LOTPS SERVES AS THE USER INTERFACE FOR A SET OF
C        SUBROUTINES WHICH SOLVE THE SCATTERED DATA INTERPOLATION
C        PROBLEM.  A SMOOTH FUNCTION PASSING THROUGH THE GIVEN POINTS
C        (XI(K),YI(K),FI(K)),K=1,...,NPI IS CONSTRUCTED.
C        THE RESULT RETURNED IS AN ARRAY OF VALUES, FO(I,J), OF THE INT-
C        ERPOLATION FUNCTION AT GRID POINTS, (XO(I),YO(J)),I=1,...,NXO,
C        J=1,...,NYO.
C        THE METHOD USED INVOLVES CONSTRUCTION OF LOCALLY DEFINED 'THIN
C        PLATE SPLINES', WHICH ARE THEN BLENDED TOGETHER SMOOTHLY
C        THROUGH THE USE OF A PARTITION OF UNITY DEFINED ON A
C        RECTANGULAR GRID ON THE PLANE.  THE FUNCTIONS IN THE PARTITION
C        OF UNITY ARE UNIVARIATE PIECEWISE HERMITE CUBIC POLYNOMIALS.
C
C     CAUTIONS
C        THE USER SHOULD BE AWARE THAT FOR SOME DATA THE INTERPOLATION
C        FUNCTION MAY BE ILL-BEHAVED.  SOME INVESTIGATION OF ITS
C        BEHAVIOR FOR THE TYPE OF DATA TO BE INPUT SHOULD BE UNDERTAKEN
C        BEFORE IMBEDDING ANY SCHEME FOR SCATTERED DATA INTERPOLATION
C        INTO ANOTHER PROGRAM.
C
C     DESCRIPTION OF ARGUMENTS
C
C        MODE - INPUT.  INDICATES THE STATUS OF THE CALCULATION.
C                 = 1,  SET UP THE PROBLEM.  COMPUTE THE COEFFICIENTS
C                       FOR THE LOCAL APPROXIMATIONS BY THIN PLATE
C                       SPLINES, AND RETURN THE GRID OF INTERPOLATED
C                       FUNCTION VALUES INDICATED BY NXO, XO, NYO, YO
C                       IN THE ARRAY FO.
C                 = 2,  THIS MODE VALUE IS A CONVENIENCE FOR USERS WHO
C                       WISH TO CALL THE ROUTINE TO EVALUATE THE
C                       SURFACE REPEATEDLY ON DIFFERENT GRIDS OF
C                       POINTS.  A CALL TO LOTPS WITH MODE = 1 HAS
C                       BEEN MADE PREVIOUSLY, NOW CALCULATE
C                       THE GRID OF INTERPOLATED POINTS INDICATED
C                       BY NXO, XO, NYO, YO IN IN THE ARRAY FO.  THE
C                       PROGRAM ASSUMES THAT THE ARRAYS XI, YI, IWK,
C                       AND WK ARE UNCHANGED FROM THE PREVIOUS CALL.
C        NPPR - INPUT.  DESIRED AVERAGE NUMBER OF POINTS PER REGION.
C                       THE SUGGESTED VALUE FOR THE NOVICE USER IS TEN,
C                       WHICH USUALLY GIVES GOOD RESULTS.  THIS PAR-
C                       AMETER HAS TO DO WITH THE LOCAL PROPERTY OF THE
C                       SURFACE.  THE INFLUENCE REGION OF A POINT HAS
C                       AREA WHICH IS ROUGHLY PROPORTIONAL TO NPPR.
C                       UNDER CERTAIN CONDITIONS, SUCH AS TO PRESERVE
C                       ROTATIONAL INVARIANCE, OR TO FORCE CERTAIN
C                       SETS OF POINTS TO BELONG TO THE SAME REGION,
C                       THE USER MAY SPECIFY HIS OWN GRID LINES.
C                       IF THE USER WISHES TO SPECIFY HIS OWN GRID LINES
C                       X TILDA AND Y TILDA, HE MAY DO SO BY SETTING
C                       NPPR = 0 AND SETTING NECESSARY VALUES IN THE
C                       ARRAYS IWK AND WK, AS NOTED BELOW.  DATA WHICH
C                       HAS A POOR DISTRIBUTION OVER THE REGION OF INT-
C                       EREST SHOULD PROBABLY HAVE THE GRID SPECIFIED.
C                       THIS IS ALSO ADVISABLE IF THE X-Y POINTS OCCUR
C                       ALONG LINES.  SEE THE REFERENCE FOR ADDITIONAL
C                       DETAILS.
C        NPI  - INPUT.  NUMBER OF INPUT DATA POINTS.
C        XI   - \
C        YI   - INPUT ARRAYS.  THE DATA POINTS (XI,YI,FI), I=1,...,NPI.
C        FI   - /
C        NXO  - INPUT.  THE NUMBER OF XO VALUES AT WHICH THE INTERP-
C                       OLATION FUNCTION IS TO BE CALCULATED.
C        XO   - INPUT ARRAY.  THE VALUES OF X AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.  THESE SHOULD
C                       BE IN INCREASING ORDER FOR MOST EFFICIENT
C                       EVALUATION, HOWEVER, THEY ONLY NEED TO BE
C                       MONOTONIC.
C        NYO  - INPUT.  THE NUMBER OF YO VALUES AT WHICH THE INTERP-
C                       OLATION FUNCTION IS TO BE CALCULATED.
C        YO   - INPUT ARRAY.  THE VALUES OF Y AT WHICH THE INTERPOLATION
C                       FUNCTION IS TO BE CALCULATED.  THESE SHOULD
C                       BE IN INCREASING ORDER FOR MOST EFFICIENT
C                       EVALUATION, HOWEVER, THEY ONLY NEED TO BE
C                       MONOTONIC.
C        IWK  - INPUT/OUTPUT ARRAY.  THIS ARRAY IS OUTPUT WHEN MODE = 1
C                       AND IS INPUT WHEN MODE = 2.  THIS MUST BE
C                       AN ARRAY DIMENSIONED APPROXIMATELY 7*NPI.  THE
C                       EXACT DIMENSION IS NOT KNOWN A PRIORI, BUT
C                       WILL BE RETURNED AS THE VALUE OF NIWKU.
C                       WHEN NPPR IS INPUT AS ZERO THE USER MUST
C                       SPECIFY THE NUMBER OF VERTICAL GRID LINES (THE
C                       NUMBER OF X TILDA VALUES) IN IWK(1) AND THE
C                       NUMBER OF HORIZONTAL GRID LINES (THE NUMBER OF
C                       Y TILDA VALUES) IN IWK(2).
C        NIWK - INPUT.  ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE
C                       DIMENSION OF THE ARRAY IWK IN THE CALLING
C                       PROGRAM.
C        NIWKU- OUTPUT.  THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE
C                       ARRAY IWK.
C        WK   - INPUT/OUTPUT ARRAY.  THIS ARRAY IS OUTPUT WHEN MODE = 1
C                       AND IS INPUT WHEN MODE = 2.  THIS MUST BE AN
C                       ARRAY DIMENSIONED APPROXIMATELY 7*NPI PLUS
C                       THE NUMBER NEEDED TO SET UP AND SOLVE THE SYSTEM
C                       OF EQUATIONS FOR THE LOCAL APPROXIMATIONS.  FOR
C                       NPPR NONZERO THIS WILL BE ABOUT 2.5*NPPR*NPPR
C                       PLUS 11*NPPR.  THE EXACT DIMENSION IS NOT KNOWN
C                       A PRIORI, BUT WILL BE RETURNED AS THE VALUE OF
C                       NWKU.
C                       WHEN NPPR IS INPUT AS ZERO THE USER MUST SPECIFY
C                       THE VALUES OF X TILDA AND Y TILDA AS FOLLOWS.
C                       WK(2), ... , WK(NXG+1) ARE THE NXG (= IWK(1))
C                       X GRID VALUES, X(I) TILDA, IN INCREASING ORDER.
C                       TYPICALLY WK(1) = MIN X(I), ALTHOUGH IT NEED
C                       NOT BE.  WK(1) MUST BE LESS THAN OR EQUAL TO
C                       WK(2), AND SHOULD BE LESS THAN OR EQUAL TO
C                       MIN X(I).  WK(NXG+2) IS USUALLY MAX X(I), AL-
C                       THOUGH IT NEED NOT BE.  WK(NXG+2) MUST BE
C                       GREATER THAN WK(NXG+1), AND SHOULD BE GREATER
C                       THAN OR EQUAL TO MAX X(I).
C                       THE VALUES OF WK(NXG+3), ... , WK(NXG+NYG+4)
C                       ARE THE Y GRID VALUES, Y(I) TILDA, AND MUST
C                       SATISFY DUAL CONDITIONS.
C        NWK  - INPUT.  ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE
C                       DIMENSION OF THE ARRAY WK IN THE CALLING
C                       PROGRAM.
C        NWKU - OUTPUT.  THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE
C                       ARRAY WK.
C        FO   - OUTPUT ARRAY.  VALUES OF THE INTERPOLATION FUNCTION AT
C                       THE GRID OF POINTS INDICATED BY NXO, XO, NYO, YO
C                       FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE
C                       CALLING PROGRAM.
C        KER  - OUTPUT.  RETURN INDICATOR.
C                 = 0,  NORMAL RETURN.
C                 = NONZERO, ERROR CONDITION ENCOUNTERED.
C
C     ERROR MESSAGES
C        NO. 1   FATAL         SINGULAR MATRIX IN THE CALCULATION OF
C                              LOCAL THIN PLATE SPLINES.  TRY LARGER
C                              VALUE FOR NPPR AND/OR MINPTS.  (MINPTS
C                              IS IN SUBROUTINE LOLIP.)
C        NO. 2   RECOVERABLE   FIRST CALL TO LOTPS MUST BE WITH MODE=1
C        NO. 3   FATAL         PREVIOUS ERROR RETURN FROM SUBROUTINE
C                              LOCAL NOT CORRECTED.
C        NO. 4   FATAL         ARRAY IWK AND/OR WK NOT DIMENSIONED LARGE
C                              ENOUGH.  REDIMENSION AS GIVEN BY NIWKU
C                              AND NWKU.
C        NO. 5   RECOVERABLE   MODE IS OUT OF RANGE.
C
C     SUBROUTINES USED
C
C        THIS PACKAGE:  LOGRD, LOLIP, LOCAL, LOEVL.
C        LINPACK: SGECO, SGESL
C        SLATEC:  SSORT, XERROR
C
C***END PROLOGUE
      DIMENSION XI(NPI), YI(NPI), FI(NPI), IWK(NIWK), WK(NWK),
     1 XO(NXO), YO(NYO), FO(NXO,NYO)
      DATA KERO/-1/
C
      IABWK=0
      IALWK=0
      MPWK=0
      NYGWK=0
C
      IF (MODE.LT.1.OR.MODE.GT.2) GO TO 220
      KER = 0
C
C     ON INITIAL ENTRY MODE = 1, THE GRID LINES ARE SET UP,
C     LOCAL INTERPOLATION POINTS ARE DETERMINED AND LOCAL APPROXIMATIONS
C     ARE COMPUTED.
C
      IF (MODE.EQ.2) GO TO 140
      NXGWK = 1
      NPWK = 3
      IF (NPPR.LE.0) GO TO 100
      NXG = INT(SQRT(4.*REAL(NPI)/REAL(NPPR))-.5)
      NXG = MAX0(NXG,1)
      NYG = NXG
      IWK(1) = NXG
      IWK(2) = NYG
      GO TO 120
  100 NXG = IWK(1)
      NYG = IWK(2)
  120 IALWK = NXG+NYG+5
      IABWK = IALWK + 3*NXG*NYG
      NYGWK = NXG+3
      MPWK = NXG*NYG+4
C
      IF(NPPR.LE.0)GO TO 130
      CALL LOGRD(XI,NPI,NXG,WK(NXGWK),WK(IALWK))
      CALL LOGRD(YI,NPI,NYG,WK(NYGWK),WK(IALWK))
  130 CONTINUE
C
C     DETERMINE THE LOCAL INTERPOLATION POINTS FOR THE REGIONS.
      MWK = NWK - MPWK + 1
      CALL LOLIP (NXG,WK(NXGWK),NYG,WK(NYGWK),NPI,XI,YI,IWK(NPWK),
     1IWK(MPWK),MWK,NMAX,WK(IALWK))
      NCFM = IABWK +IWK(MPWK - 1)-1
      NWKU = NCFM + (NMAX+3)*(NMAX+5) - 1
      NIPVT = NXG*NYG+3+IWK(MPWK-1)
      NIWKU = NIPVT + NMAX + 2
      IF (NIWKU.GT.NIWK) GO TO 200
      IF (NWKU.GT.NWK) GO TO 200
C
C     COMPUTE THE LOCAL APPROXIMATIONS.
      CALL LOCAL (XI,YI,FI,NXG,WK(NXGWK),NYG,WK(NYGWK),IWK(NPWK),
     1 IWK(MPWK),WK(IALWK),WK(IABWK),WK(NCFM),IWK(NIPVT),IER)
      KERO = IER
      IF (IER.NE.0) GO TO 160
  140 IF (KERO.NE.0) GO TO 180
C
C     COMPUTE THE FUNCTION VALUES ON THE DESIRED GRID OF POINTS.
C
      CALL LOEVL (XI,YI,IWK(1),WK(NXGWK),IWK(2),WK(NYGWK),IWK(NPWK),
     1 IWK(MPWK),WK(IALWK),WK(IABWK),NXO,XO,NYO,YO,FO)
      RETURN
C
C     ERROR RETURNS
C
  160 KER = IER
CCCCC IF(IER.NE.0)CALL XERROR('LOTPS-SINGULAR MATRIX IN LOCAL; INCREAS
CCCCC1E NPPR OR SPECIFY OWN GRID LINES',71,1,2)
      RETURN
  180 KER = 3
      IF (KERO.LT.0) GO TO 190
CCCCC  CALL XERROR('LOTPS-PREVIOUS ERROR FROM SUBROUTINE LOCAL HAS NOT
CCCCC1BEEN CORRECTED.',65,3,2)
      RETURN
  190 KER = 2
CCCCC CALL XERROR('LOTPS-FIRST CALL TO LOTPS MUST BE WITH MODE = 1',
CCCCC1 47,2,1)
      RETURN
  200 KER = 4
CCCCC CALL XERROR('LOTPS-WORK ARRAYS IWK AND/OR WK NOT DIMENSIONED LAR
CCCCC1GE ENOUGH',60,4,2)
      RETURN
  220 KER = 5
CCCCC CALL XERROR('LOTPS-MODE IS OUT OF RANGE.  MUST BE 1 OR 2',43,5,
CCCCC1 1)
      RETURN
      END
      SUBROUTINE LOWESS(Y,X,N,ALOWFR,ALOWDG,
CCCCC MARCH 1994.  ADD ARGUMENT.
CCCCC SUBROUTINE LOWESS(Y,X,N,ALOWFR,
     1XTEMP1,XTEMP2,YS,XS,WH,WV,XTEMP7,MAXNXT,
     1PRED2,RES2,ISUBRO,IBUGA3,IERROR)
C
C     PURPOSE--THIS ROUTINE PERFORMS A LOWESS FIT/SMOOTH
C              OF THE DATA IN Y AND X
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--88/2
C     ORIGINAL VERSION--FEBRUARY  1988.
C     UPDATED         --MAY       1989.  ERROR BRANCHES AFTER CALLS
C     UPDATED         --MARCH     1994.  SUPPORT QUADRATIC LOWESS FITS
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISUBRO
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
      CHARACTER*4 ISTEPN
C
C---------------------------------------------------------------------
C
      DIMENSION Y(*)
      DIMENSION X(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
      DIMENSION YS(*)
      DIMENSION XS(*)
      DIMENSION WH(*)
      DIMENSION WV(*)
      DIMENSION XTEMP7(*)
      DIMENSION PRED2(*)
      DIMENSION RES2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOWE'
      ISUBN2='SS  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('**** AT THE BEGINNING OF LOWESS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)ISUBRO,IBUGA3,IERROR
   52 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,61)N,ALOWFR
   61 FORMAT('N,ALOWFR = ',I8,E15.7)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO64
      DO62I=1,N
      WRITE(ICOUT,63)I,Y(I),X(I)
   63 FORMAT('I,Y(I),X(I) = ',I8,2E15.7)
      CALL DPWRST('XXX','BUG ')
   62 CONTINUE
   64 CONTINUE
   90 CONTINUE
C
C               ***********************************
C               **  STEP 11--                    **
C               **  SORT THE DATA                **
C               **  ACCORDING TO THE HORIZONTAL  **
C               **  AXIS VARIABLE.               **
C               **  RECORD THE ORDER OF THE      **
C               **  INCOMING DATA.               **
C               ***********************************
C
      ISTEPN='11'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL SORTC(X,Y,N,XS,YS)
C
      DO1100I=1,N
      XTEMP1(I)=I
 1100 CONTINUE
      CALL SORTC(X,XTEMP1,N,XS,XTEMP7)
C
      AN=N
C
C               ***********************************************
C               **  STEP 12--                                **
C               **  COMPUTE THE TOTAL                        **
C               **  NUMBER OF NEIGHBORS IN  A NEIGHBORHOOD   **
C               ***********************************************
C
      ISTEPN='12'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      NN=INT(ALOWFR*AN+0.5)
      ANN=NN
C
C               ***********************************************
C               **  STEP 21--                                **
C               **  SET THE VERTICAL (ROBUSTNESS) WEIGHTS    **
C               **  EQUAL TO UNITY PRIOR TO COMPUTING        **
C               **  INITIAL PREDICTED VALUES                 **
C               ***********************************************
C
      ISTEPN='21'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2100I=1,N
      WV(I)=1.0
 2100 CONTINUE
C
C               ************************************************
C               **  STEP 22--                                 **
C               **  LOOP THROUGH EACH OF THE                  **
C               **  N HORIZONTAL DATA POINTS                  **
C               **  FROM SMALLEST TO LARGEST.                 **
C               **  FOR EACH DATA POINT--                     **
C               **     1) COMPUTE NEIGHBORHOOD LIMITS         **
C               **     2) COMPUTE HORIZONTAL WEIGHTS          **
C               **        FOR EACH NEIGHBORHOOD POINT         **
C               **     3) COMPUTE A INITIAL PREDICTED VALUE   **
C               **        FOR THAT POINT VIA A                **
C               **        WEIGHTED LINEAR FIT                 **
C               **        USING HORIZONTAL WEIGHTS ONLY.      **
C               ************************************************
C
      ISTEPN='22'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO2200IT=1,N
C
      CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      DEL1=XS(IT)-XS(I1)
      DEL2=XS(I2)-XS(IT)
      XMAXHF=DEL1
      IF(DEL2.GT.DEL1)XMAXHF=DEL2
      CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF,
     1WH,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      I3=IT
      I4=IT
CCCCC MARCH 1994.  ADD CHECK FOR QUADRATIC DEGREE.
      IF(ALOWDG.GT.1.5)THEN
      CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ELSE
      CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ENDIF
      IF(IERROR.EQ.'YES')GOTO9000
C
 2200 CONTINUE
C
C               *************************************************
C               **  STEP 31--                                  **
C               **  BASED ON THE INITIAL PREDICTED VALUES      **
C               **  AND THE CONSEQUENTIAL RESIDUALS,           **
C               **  COMPUTE VERTICAL (ROBUSTNESS) WEIGHTS      **
C               **  FOR ALL N DATA POINTS                      **
C               *************************************************
C
      ISTEPN='31'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      CALL WEIGHV(RES2,N,XTEMP1,XTEMP2,MAXNXT,
     1WV,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
C               ************************************************
C               **  STEP 32--                                 **
C               **  AGAIN LOOP THROUGH EACH OF THE            **
C               **  N HORIZONTAL DATA POINTS                  **
C               **  FROM SMALLEST TO LARGEST.                 **
C               **  FOR EACH DATA POINT--                     **
C               **     1) COMPUTE NEIGHBORHOOD LIMITS         **
C               **     2) COMPUTE HORIZONTAL WEIGHTS          **
C               **        FOR EACH NEIGHBORHOOD POINT         **
C               **     3) COMPUTE A FINAL PREDICTED VALUE     **
C               **        FOR THAT POINT VIA A                **
C               **        WEIGHTED LINEAR FIT                 **
C               **        USING BOTH THE HORIZONTAL WEIGHTS   **
C               **        AND THE VERTICAL WEIGHTS            **
C               ************************************************
C
      ISTEPN='32'
      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
C
      DO3200IT=1,N
C
      CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      DEL1=XS(IT)-XS(I1)
      DEL2=XS(I2)-XS(IT)
      XMAXHF=DEL1
      IF(DEL2.GT.DEL1)XMAXHF=DEL2
      CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF,
     1WH,ISUBRO,IBUGA3,IERROR)
      IF(IERROR.EQ.'YES')GOTO9000
C
      I3=IT
      I4=IT
CCCCC MARCH 1994.  ADD CHECK FOR QUADRATIC DEGREE.
      IF(ALOWDG.GT.1.5)THEN
      CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ELSE
      CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4,
     1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR)
      ENDIF
      IF(IERROR.EQ.'YES')GOTO9000
C
 3200 CONTINUE
C
      DO3300I=1,N
      XTEMP1(I)=PRED2(I)
      XTEMP2(I)=RES2(I)
 3300 CONTINUE
C
      DO3400I=1,N
      J=INT(XTEMP7(I)+0.5)
      PRED2(J)=XTEMP1(I)
      RES2(J)=XTEMP2(I)
 3400 CONTINUE
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('**** AT THE END       OF LOWESS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR
 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9021)N,ALOWFR,NN
 9021 FORMAT('N,ALOWFR,NN = ',I8,E15.7,I8)
      CALL DPWRST('XXX','BUG ')
      IF(N.LE.0)GOTO9024
      DO9022I=1,N
      WRITE(ICOUT,9023)I,Y(I),X(I),PRED2(I),RES2(I)
 9023 FORMAT('I,Y(I),X(I),PRED2(I),RES2(I) = ',I8,4E11.3)
      CALL DPWRST('XXX','BUG ')
 9022 CONTINUE
 9024 CONTINUE
      IF(N.LE.0)GOTO9034
      DO9032I=1,N
      WRITE(ICOUT,9033)I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I)
 9033 FORMAT('I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I) = ',
     1I8,6E11.3)
      CALL DPWRST('XXX','BUG ')
 9032 CONTINUE
 9034 CONTINUE
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LOWHIN(X,N,IWRITE,XTEMP,MAXNXT,XLOWHI,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE LOWER HINGE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XLOWHI = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE LOWER HINGE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LOWER HINGE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOWH'
      ISUBN2='IN  '
      IERROR='NO'
C
      IARG1=0
      IARG2=0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LOWHIN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ***************************
C               **  COMPUTE LOWER HINGE  **
C               ***************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR. N.GT.MAXNXT)THEN
        IERROR='YES'
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LOWER HINGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)MAXNXT
  113   FORMAT('      VARIABLE IS LESS THAN 1 OR GREATER THAN ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ELSEIF(N.EQ.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,121)
  121   FORMAT('***** WARNING IN LOWER HINGE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,123)
  123   FORMAT('      THERE IS ONLY A SINGLE RESPONSE VALUE.')
        CALL DPWRST('XXX','BUG ')
        XLOWHI=X(1)
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,121)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,136)HOLD
  136 FORMAT('      THE RESPONSE VALUES ARE EQUAL TO ',G15.7)
      CALL DPWRST('XXX','BUG ')
      XLOWHI=HOLD
      GOTO9000
  139 CONTINUE
C
C               ********************************
C               **  STEP 2--                  **
C               **  COMPUTE THE LOWER HINGE.  **
C               ********************************
C
      CALL SORT(X,N,XTEMP)
C
      N2=(N+1)/2
      IARG1=(N2+1)/2
      IARG2=(N2+1)-IARG1
      XLOWHI=(XTEMP(IARG1)+XTEMP(IARG2))/2.0
C
C               j******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XLOWHI
  811   FORMAT('THE LOWER HINGE OF THE ',I8,' OBSERVATIONS = ',G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LOWHIN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IERROR,IARG1,IARG2,XLOWHI
 9012   FORMAT('IERROR,IARG1,IARG2,XLOWHI = ',A4,2X,2I8,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE LOWQUA(X,N,IWRITE,XTEMP,MAXNXT,XLOWQU,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE LOWER QUARTILE
C              OF THE DATA IN THE INPUT VECTOR X.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XLOWQU = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE LOWER QUARTILE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LOWER QUARTILE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1966)
C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
C                          DENOTED BY QUOTES RATHER THAN NH.
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JUNE      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --OCTOBER   2008. WEIGHTING OF NEAREST TWO
C                                       POINTS WAS REVERSED
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LOWQ'
      ISUBN2='UA  '
      IERROR='NO'
C
      NI=0
      NIP1=0
C
      ANI=0.0
      A2NI=0.0
      REM=0.0
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LOWQUA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)N,IBUGA3
   53   FORMAT('N,IBUGA3 = ',I8,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ******************************
C               **  COMPUTE LOWER QUARTILE  **
C               ******************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR. N.GT.MAXNXT)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LOWER QUARTILE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
     1         'VARIABLE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      MUST BE BETWEEN 1 AND ',I8,' (INCLUSIVELY).')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,121)
CC121   FORMAT('***** WARNING IN LOWER QUARTILE--',
CCCCC1         'THERE IS ONLY ONE RESPONSE VALUE.')
CCCCC   CALL DPWRST('XXX','BUG ')
        XLOWQU=X(1)
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,136)HOLD
CC136 FORMAT('***** WARNING IN LOWER QUARTILE--',
CCCCC1       'THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
CCCCC CALL DPWRST('XXX','BUG ')
      XLOWQU=HOLD
      GOTO9000
  139 CONTINUE
C
C               ***********************************
C               **  STEP 2--                     **
C               **  COMPUTE THE LOWER QUARTILE.  **
C               ***********************************
C
      CALL SORT(X,N,XTEMP)
C
      P=0.25
C
      ANI=P*(AN+1.0)
      NI=INT(ANI)
      A2NI=NI
      REM=ANI-A2NI
      NIP1=NI+1
      IF(NI.LE.1)NI=1
      IF(NI.GE.N)NI=N
      IF(NIP1.LE.1)NIP1=1
      IF(NIP1.GE.N)NIP1=N
CCCCC 10/20/2008: WEIGHTING IS BACKWARDS
CCCCC XLOWQU=REM*XTEMP(NI)+(1.0-REM)*XTEMP(NIP1)
      XLOWQU=(1.0-REM)*XTEMP(NI)+REM*XTEMP(NIP1)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND.IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XLOWQU
  811   FORMAT('THE LOWER QUARTILE OF THE ',I8,' OBSERVATIONS = ',
     1         G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LOWQUA--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)ANI,NI,A2NI,REM,NIP1
 9014   FORMAT('ANI,NI,A2NI,REM,NIP1 = ',G15.7,I8,2G15.7,I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)IERROR,XLOWQU
 9015   FORMAT('IERROR,XLOWQU = ',A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION LPLFUN (ALPHA,X)
C
C     PURPOSE--THIS ROUTINE IS USED IN FINDING THE Lp LOCATION
C              ESTIMATE.  THIS FUNCTION FINDS THE ROOT OF
C
C              SUM[i=1 to n][|X(i)-alpha|**(p-1)*SIGN(x(i)-ALPHA) = 0
C
C              CALLED BY DFZER2 ROUTINE FOR FINDING THE ROOT OF A
C              FUNCTION.
C     EXAMPLE--LET A = LP LOCATION Y
C     REFERENCES--FRANCESCA PENNECCHI AND LUCA CALLEGARO, "BETWEEN
C                 THE MEAN AND THE MEDIAN: THE Lp ESTIMATOR",
C                 METROLOGIA, 43, 2006, PP. 213-219.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2007/11
C     ORIGINAL VERSION--NOVEMBER   2007.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION X(*)
C
      INTEGER N
      DOUBLE PRECISION DP
      COMMON/LPLCOM/DP,N
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DX
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      DSUM=0.0D0
      DO100I=1,N
        DX=X(I)
        DTERM1=DX-ALPHA
        IF(DTERM1.GE.0.0D0)THEN
          DFACT=1.0D0
        ELSE
          DFACT=-1.0D0
        ENDIF
        DSUM=DSUM + DFACT*DABS(DTERM1)**(DP-1.0D0)
  100 CONTINUE
C
      LPLFUN=DSUM
C
      RETURN
      END
      SUBROUTINE LPLOC(X,N,P,IWRITE,XTEMP,DTEMP,MAXNXT,XLP,
     1                 IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE LP LOCATION
C              ESTIMATE OF THE DATA IN THE INPUT VECTOR X.
C
C              GIVEN THE MODEL
C
C                 X(i) = ALPHA + E(i)
C
C              THE L(p) ESTIMATOR OF ALPHA IS
C
C                 L(p)(X(i)) = Arg(alpha)
C                     MIN{(SUM[i=1 to n][|X(i) - ALPHA|**p)**(1/p)}
C
C              OR EQUIVALENTLY
C
C                 L(p)(X(i)) = Arg(alpha)
C                     MIN{SUM[i=1 to n][|X(i) - ALPHA|**p}
C
C              THIS ESTIMATE IS THE SOLUTION OF THE EQUATION
C
C              SUM[i=1 to n][|X(i)-alpha|**(p-1)*SIGN(x(i)-ALPHA) = 0
C
C              THERE ARE 3 SPECIAL CASES:
C
C               P = 1   - SAMPLE MEDIAN
C               P = 2   - SAMPLE MEAN
C               P = INF - SAMPLE MID-RANGE
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --P      = THE SINGLE PRECISION VALUE OF THE
C                                "p" PARAMETER.
C     OUTPUT ARGUMENTS--XLP    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE LP LOCATION ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE LP LOCATION ESTIMATE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FRANCESCA PENNECCHI AND LUCA CALLEGARO, "BETWEEN
C                 THE MEAN AND THE MEDIAN: THE Lp ESTIMATOR",
C                 METROLOGIA, 43, 2006, PP. 213-219.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--NOVEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DOUBLE PRECISION DTEMP(*)
C
      DOUBLE PRECISION LPLFUN
      EXTERNAL LPLFUN
      DOUBLE PRECISION DP
      COMMON/LPLCOM/DP,IN
C
      DOUBLE PRECISION DXLOW
      DOUBLE PRECISION DXUP
      DOUBLE PRECISION DXSTRT
      DOUBLE PRECISION DAE
      DOUBLE PRECISION DRE
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LPLO'
      ISUBN2='C   '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LPLOC--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N,P
   52   FORMAT('IBUGA3,N,P = ',A4,2X,I10,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MIN(N,100)
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,E15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************
C               **  COMPUTE LPLOC   **
C               **********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR.N.GT.MAXNXT)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN LP LOCATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1 OR GREATER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      THAN ',I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I10,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(P.LT.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,122)
  122   FORMAT('      THE P PARAMETER IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,127)P
  127   FORMAT('      THE VALUE OF P = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XLP=X(1)
        GOTO8000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XLP=HOLD
      GOTO8000
  139 CONTINUE
C
      EPS=1.0E-6
      ATEMP=ABS(P-1.0)
      IF(ATEMP.LE.EPS)THEN
        CALL MEDIAN(X,N,IWRITE,XTEMP,MAXNXT,XLP,IBUGA3,IERROR)
        GOTO8000
      ENDIF
      ATEMP=ABS(P-2.0)
      IF(ATEMP.LE.EPS)THEN
        CALL MEAN(X,N,IWRITE,XLP,IBUGA3,IERROR)
        GOTO8000
      ENDIF
      IF(P.GT.10.0)THEN
        CALL MIDRAN(X,N,IWRITE,XLP,IBUGA3,IERROR)
        GOTO8000
      ENDIF
C
C               ***************************
C               **  STEP 2--             **
C               **  COMPUTE THE LPLOC.   **
C               ***************************
C
C     STEP 1: USE MEDIAN AS STARTING VALUE.
C
      CALL SORT(X,N,XTEMP)
C
      IEVODD=N-(N/2)*2
      NMID=N/2
      NMIDP1=NMID+1
      IF(IEVODD.EQ.0)XMED=(XTEMP(NMID)+XTEMP(NMIDP1))/2.0
      IF(IEVODD.EQ.1)XMED=XTEMP(NMIDP1)
C
C     STEP 2: USE DFZER2 TO FIND ROOT OF EQUATION.
C
      IN=N
      DP=DBLE(P)
      DO200I=1,N
        DTEMP(I)=DBLE(XTEMP(I))
  200 CONTINUE
C
      DXSTRT=DBLE(XMED)
      DAE=0.000001D0
      DRE=DAE
      IFLAG=0
      DXLOW=DBLE(XTEMP(1))
      DXUP=DBLE(XTEMP(N))
      CALL DFZER2(LPLFUN,DXLOW,DXUP,DXSTRT,DRE,DAE,IFLAG,DTEMP)
C
      XLP=REAL(DXLOW)
C
      IF(IFLAG.EQ.2)THEN
C
C  NOTE: SUPPRESS THIS MESSAGE FOR NOW.
CCCCC   WRITE(ICOUT,999)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,111)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE(ICOUT,1113)
C1113   FORMAT('      ESTIMATE OF LPLOC MAY NOT BE COMPUTED TO ',
CCCCC1         'DESIRED TOLERANCE.')
CCCCC   CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.3)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1121)
 1121   FORMAT('***** WARNING FROM LP LOCATION ESTIMATE--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1123)
 1123   FORMAT('      ESTIMATE MAY BE NEAR A SINGULAR POINT.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.4)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1133)
 1133   FORMAT('      APPROPRIATE BRACKETING INTERVAL NOT FOUND.')
        CALL DPWRST('XXX','BUG ')
      ELSEIF(IFLAG.EQ.5)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1121)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,1143)
 1143   FORMAT('      MAXIMUM ITERATIONS EXCEEDED.')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
 8000 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XLP,P
  811   FORMAT('THE Lp LOCATION ESTIMATE OF THE ',I8,
     1         ' OBSERVATIONS = ',G15.7,'(P = ',F5.2,')')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF LPLOC--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)N
 9013 FORMAT('N = ',I8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9015)XMED
 9015 FORMAT('XMED = ',E15.7)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE LPOCDF(X,LAMBDA,THETA,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE LAGRANGE-POISSON DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND
C              THETA.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)*
C                                  (THETA+LAMBDA*X)**(X-1)/
C                                  (X*(X-K)!)
C                                  X >= 0; 0 < LAMBDA < 1; THETA > 0.
C              NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND
C              RE-PARAMETERIZED VERSION OF THE BOREL-TANNER
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGR
C                     --LAMBDA = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE CDF
C             FOR THE LAGRANGE-POISSON DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0 < LAMBDA < 1,  AND THETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--LNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 394-400.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/5
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL THETA
      REAL LAMBDA
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLAMB
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      CDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(THETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
      INTX=INT(X+0.5)
      IF(INTX.LT.0)THEN
        CDF=0.0
        GOTO9999
      ENDIF
C
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LPOCDF ',
     1       'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.')
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LPOCDF ',
     1       'IS NON-POSITIVE.')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DLAMB=DBLE(LAMBDA)
      DTHETA=DBLE(THETA)
      DCDF=0.0D0
C
      IF(INTX.EQ.0)THEN
        DCDF=DEXP(-DTHETA)
      ELSEIF(INTX.EQ.1)THEN
        DCDF=DEXP(-DTHETA) + DTHETA*DEXP(-DTHETA-DLAMB)
      ELSE
        DO100I=INTX,0,-1
          DX=DBLE(I)
          DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) +
     1           (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX)
          DTERM2=DLNGAM(DX+1.0D0)
          DPDF=DEXP(DTERM1 - DTERM2)
          DCDF=DCDF + DPDF
  100   CONTINUE
      ENDIF
C
      CDF=REAL(DCDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LPOFUN(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LAGRANGE-POISSON WEIGHTED DISCREPENCIES (A
C              MODIFICATION OF MAXIMUM LIKELIHOOD) EQUATIONS.
C
C              SUM[i=1 to k][Y(i) - LPOPDF(X)]*
C                 [(X*(THETA+LAMBDA)/(THETA*(THETA+LAMBDA*X)) - 1] = 0
C
C              SUM[i=1 to k][Y(i) - LPOPDF(X)]*
C                 [(X*(X-1)/(THETA+LAMBDA*X)) - X] = 0
C
C              WITH THETA AND LAMBDA DENOTING THE SHAPE PARAMETERS.
C              THIS ROUTINE ASSUMES THE DATA IS IN THE FORM
C
C                   X(I)  FREQ(I)
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C              SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO
C              TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE
C              (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E.,
C              THE X).
C     EXAMPLE--LAGRANGE-POISSON MAXIMUM LIKELIHOOD Y
C     REFERENCE --FELIX FAMOYE AND CARL M. -S. LEE (1992),
C                 "ESTIMATION OF GENERALIZED POISSON DISTRIBUTION",
C                 COMMUNICATIONS IN STATISTICS -- SIMULATION,
C                 21(1), PP. 173-188.
C     WRITTEN BY--ALAN HECKERT
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL Y(*)
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DLAMB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
      DOUBLE PRECISION XBAR
      COMMON/LPOCOM/XBAR,MAXNXT,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      IFLAG=0
      N=2
C
      DLAMB=XPAR(1)
      DTHETA=XPAR(2)
C
      IINDX=MAXNXT/2
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,K
C
        DX=DBLE(Y(IINDX+I))
        DFREQ=Y(I)
C
        CALL LPOPDF(REAL(DX),REAL(DLAMB),REAL(DTHETA),PDF)
        DTERM1=(DFREQ-DBLE(PDF))
C
        DTERM2=DX*(DTHETA+DLAMB)/(DTHETA*(DTHETA+DLAMB*DX))
        DSUM1=DSUM1 + DTERM1*(DTERM2 - 1.0D0)
        DTERM3=DX*(DX-1.0D0)/(DTHETA+DLAMB*DX) - DX
        DSUM2=DSUM2 + DTERM1*DTERM3
C
  200 CONTINUE
C
      FVEC(1)=DSUM1
      FVEC(2)=DSUM2
C
      RETURN
      END
      SUBROUTINE LPOFU2(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LAGRANGE POISSON MAXIMUM LIKELIHOOD EQUATION.
C
C              THE MAXIMUM LIKELIHOOD ESTIMATE OF LAMBDA IS
C              THE SOLUTION OF THE EQUATION:
C
C                 SUM[X=0 to K][X*(X-1)*N(X)/(XBAR+(X-XBAR)*LAMBDA)] -
C                 N*XBAR = 0
C
C              THIS ROUTINE ASSUMES THE DATA IS IN THE FORM
C
C                   X(I)  FREQ(I)
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C              SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO
C              TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE
C              (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E.,
C              THE X).
C     EXAMPLE--LAGRANGE POISSON MAXIMUM LIKELIHOOD Y
C     REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 9.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/7
C     ORIGINAL VERSION--JULY      2006.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL Y(*)
C
      DOUBLE PRECISION DLAMBD
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DN
      DOUBLE PRECISION DX
      DOUBLE PRECISION DFREQ
C
      DOUBLE PRECISION XBAR
      COMMON/LPOCOM/XBAR,MAXROW,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IFLAG=0
      N=2
C
      DLAMBD=XPAR(1)
      DN=DBLE(NTOT)
      IINDX=MAXROW/2
C
      DTERM1=DN*XBAR
C
      DSUM1=0.0D0
      DO100I=0,K
        DX=DBLE(Y(IINDX+I))
        DFREQ=Y(I+1)
        DSUM1=DSUM1 + DX*(DX-1.0D0)*DFREQ/(XBAR+(DX-XBAR)*DLAMBD)
  100 CONTINUE
C
      FVEC(1)=DSUM1 - DTERM1
C
      RETURN
      END
      SUBROUTINE LPOFU3(N,XPAR,FVEC,IFLAG,Y,K)
C
C     PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE
C              LAGRANGE-POISSON EWRC METHOD.  EWRC IS A
C              COMBINATION OF THE WEIGHTED DISCREPENCIES AND
C              MAXIMUM LIKELIHOOD METHODS.  THE EWRC ESTIMATES
C              ARE THE SOLUTIONS OF THE FOLLOWING EQUATIONS:
C
C              SUM[i=1 to k][Y(i)*(Y(i) - LPOPDF(X))]*
C                 [(X*(THETA+LAMBDA)/(THETA*(THETA+LAMBDA*X)) - 1] = 0
C
C              SUM[i=1 to k][Y(i)*(Y(i) - LPOPDF(X))]*
C                 [(X*(X-1)/(THETA+LAMBDA*X)) - X] = 0
C
C              WITH THETA AND LAMBDA DENOTING THE SHAPE PARAMETERS.
C              THIS ROUTINE ASSUMES THE DATA IS IN THE FORM
C
C                   X(I)  FREQ(I)
C
C              CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS
C              NONLINEAR EQUATIONS.  NOTE THAT THE CALLING SEQUENCE
C              DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF
C              OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST.
C              SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO
C              TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE
C              (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E.,
C              THE X).
C     EXAMPLE--LAGRANGE-POISSON MAXIMUM LIKELIHOOD Y
C     REFERENCE --FELIX FAMOYE AND CARL M. -S. LEE (1992),
C                 "ESTIMATION OF GENERALIZED POISSON DISTRIBUTION",
C                 COMMUNICATIONS IN STATISTICS -- SIMULATION,
C                 21(1), PP. 173-188.
C               --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY
C                 DISTRIBUTIONS", BIRKHAUSER, CHAPTER 9.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBUG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/8
C     ORIGINAL VERSION--AUGUST    2006.
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION XPAR(*)
      DOUBLE PRECISION FVEC(*)
      REAL Y(*)
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DLAMB
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DTERM3
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
C
      DOUBLE PRECISION XBAR
      COMMON/LPOCOM/XBAR,MAXNXT,NTOT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C  COMPUTE SOME SUMS
C
      IFLAG=0
      N=2
C
      DLAMB=XPAR(1)
      DTHETA=XPAR(2)
C
      IINDX=MAXNXT/2
C
      DSUM1=0.0D0
      DSUM2=0.0D0
C
      DO200I=1,K
C
        DX=DBLE(Y(IINDX+I))
        DFREQ=Y(I)
C
        CALL LPOPDF(REAL(DX),REAL(DLAMB),REAL(DTHETA),PDF)
        DTERM1=DFREQ*(DFREQ-DBLE(PDF))
C
        DTERM2=DX*(DTHETA+DLAMB)/(DTHETA*(DTHETA+DLAMB*DX))
        DSUM1=DSUM1 + DTERM1*(DTERM2 - 1.0D0)
        DTERM3=DX*(DX-1.0D0)/(DTHETA+DLAMB*DX) - DX
        DSUM2=DSUM2 + DTERM1*DTERM3
C
  200 CONTINUE
C
      FVEC(1)=DSUM1
      FVEC(2)=DSUM2
C
      RETURN
      END
      SUBROUTINE LPOPDF(X,LAMBDA,THETA,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE X
C              FOR THE LAGRANGE-POISSON DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND
C              THETA.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)*
C                                  (THETA+LAMBDA*X)**(X-1)/
C                                  (X*(X-K)!)
C                                  X >= 0; 0 < LAMBDA < 1; THETA > 0.
C              NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND
C              RE-PARAMETERIZED VERSION OF THE BOREL-TANNER
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGR
C                     --LAMBDA = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                MASS FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF
C             FOR THE LAGRANGE-POISSON DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER
C                 --0 < LAMBDA < 1,  AND THETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--LNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 394-400.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/5
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL THETA
      REAL LAMBDA
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLAMB
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PDF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
      IF(THETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
      INTX=INT(X+0.5)
      IF(INTX.LT.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)INTX
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9999
      ENDIF
C
    5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE LPOPDF ',
     1'SUBROUTINE IS NON-POSITIVE')
   11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ',
     1' LPOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ',
     1' LPOPDF SUBROUTINE IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
C
      DX=DBLE(INTX)
      DLAMB=DBLE(LAMBDA)
      DTHETA=DBLE(THETA)
C
      IF(INTX.EQ.0)THEN
        DPDF=DEXP(-DTHETA)
      ELSEIF(INTX.EQ.1)THEN
        DPDF=DTHETA*DEXP(-DTHETA-DLAMB)
      ELSE
        DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) +
     1         (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX)
        DTERM2=DLNGAM(DX+1.0D0)
        DPDF=DEXP(DTERM1 - DTERM2)
      ENDIF
      PDF=REAL(DPDF)
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LPOPPF(P,LAMBDA,THETA,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE AT THE SINGLE PRECISION VALUE P
C              FOR THE LAGRANGE-POISSON DISTRIBUTION
C              WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND
C              THETA.  THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)*
C                                  (THETA+LAMBDA*X)**(X-1)/
C                                  (X*(X-K)!)
C                                  X >= 0; 0 < LAMBDA < 1; THETA > 0.
C              NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND
C              RE-PARAMETERIZED VERSION OF THE BOREL-TANNER
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE
C                                AT WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE A NON-NEGATIVE INTEGR
C                     --LAMBDA = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION PERCENT POINT
C                                FUNCTION VALUE
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF
C             FOR THE LAGRANGE-POISSON DISTRIBUTION
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--0 <= P < 1
C                 --0 < LAMBDA < 1,  AND THETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--LNGAMM.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 394-400.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL BUREAU OF STANDARDS.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/5
C     ORIGINAL VERSION--MAY       2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL P
      REAL THETA
      REAL LAMBDA
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DLAMB
      DOUBLE PRECISION DTHETA
      DOUBLE PRECISION DCDF
      DOUBLE PRECISION DPDF
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DEPS
      DOUBLE PRECISION DLNGAM
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      PPF=0.0
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      PPF=0.0
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
        WRITE(ICOUT,1)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)P
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(THETA.LE.0.0)THEN
        WRITE(ICOUT,12)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
    1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LPOPPF ',
     1       'IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.')
   11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LPOPPF ',
     1       'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL')
   12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LPOPPF ',
     1       'IS NON-POSITIVE')
   46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7)
C
      DP=DBLE(P)
      DLAMB=DBLE(LAMBDA)
      DTHETA=DBLE(THETA)
C
      IF(P.LE.0.0)THEN
        PPF=0.0
        GOTO9999
      ENDIF
C
C     COMPUTE PDF FOR X = 0
C
      DEPS=1.0D-7
      DCDF=DEXP(-DTHETA)
C
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=0.0
        GOTO9999
      ENDIF
      I=0
C
      DCDF=DCDF + DTHETA*DEXP(-DTHETA-DLAMB)
      IF(DCDF.GE.DP-DEPS)THEN
        PPF=1.0
        GOTO9999
      ENDIF
      I=1
C
  100 CONTINUE
        I=I+1
        IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN
          WRITE(ICOUT,55)
   55     FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ',
     1           'EXCEEDS THE LARGEST MACHINE INTEGER.')
          CALL DPWRST('XXX','BUG ')
          PPF=0.0
          GOTO9999
        ENDIF
        DX=DBLE(I)
        DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) +
     1         (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX)
        DTERM2=DLNGAM(DX+1.0D0)
        DPDF=DEXP(DTERM1 - DTERM2)
        DCDF=DCDF + DPDF
        IF(DCDF.GE.DP-DEPS)THEN
          PPF=REAL(I)
          GOTO9999
        ENDIF
      GOTO100
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LPORAN(N,LAMBDA,THETA,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LAGRANGE-POISSON DISTRIBUTION
C              WITH SHAPE PARAMETERS LAMBDA AND THETA.
C              THIS DISTRIBUTION IS DEFINED FOR ALL
C              NON-NEGATIVE INTEGER X >= 0.
C              THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION
C              p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)*
C                                  (THETA+LAMBDA*X)**(X-1)/
C                                  (X*(X-K)!)
C                                  X >= 0; 0 < LAMBDA < 1; THETA > 0.
C              NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND
C              RE-PARAMETERIZED VERSION OF THE BOREL-TANNER
C              DISTRIBUTION.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --LAMBDA = THE SINGLE PRECISION VALUE
C                                OF THE FIRST SHAPE PARAMETER.
C                     --THETA  = THE SINGLE PRECISION VALUE
C                                OF THE SECOND SHAPE PARAMETER.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LAGRANGE-POISSON DISTRIBUTION
C             WITH SHAPE PARAMETERS LAMBDA AND THETA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --0 < LAMBDA < 1, THETA > 0
C     OTHER DATAPAC   SUBROUTINES NEEDED--UNIRAN, LPOPPF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND KEMP (1992).  "UNIVARIATE
C                 DISCRETE DISTRIBUTIONS", SECOND EDITION,
C                 WILEY, PP. 394-400.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2899
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2006/6
C     ORIGINAL VERSION--JUNE      2006.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      REAL LAMBDA
      REAL THETA
      DIMENSION X(*)
C
CCCCC DIMENSION U(2)
C
CCCCC DOUBLE PRECISION PI
CCCCC DOUBLE PRECISION C
CCCCC DOUBLE PRECISION V
CCCCC DOUBLE PRECISION Y
CCCCC DOUBLE PRECISION DK
CCCCC DOUBLE PRECISION DLAMB
CCCCC DOUBLE PRECISION U1
CCCCC DOUBLE PRECISION W
CCCCC DOUBLE PRECISION WT
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT, 5)
    5   FORMAT('***** ERROR--THE REQUESTED NUMBER OF ',
     1         'LAGRANGE-POISSON RANDOM NUMBERS IS NON-POSITIVE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN
        WRITE(ICOUT,11)
   11   FORMAT('***** ERROR--THE LAMBDA PARAMETER FOR THE ',
     1         'LAGRANGE-POISSON RANDOM NUMBERS IS OUTSIDE THE ',
     1         '(0,1) INTERVAL.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)LAMBDA
   46   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.')
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ELSEIF(THETA.LE.0.0)THEN
        WRITE(ICOUT,12)
   12   FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ',
     1         'LAGRANGE-POISSON RANDOM NUMBERS IS NON-POSITIVE.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)THETA
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
C
C     GENERATE N LAGRANGE-POISSON DISTRIBUTION RANDOM NUMBERS
C     USING THE ALGORITHM GIVEN IN THE DEVROYE PAPER.
C
C     I DON'T THINK I HAVE THIS QUITE RIGHT, SO JUST USE
C     INVERSE PPF METHOD FOR NOW.
C
CCCCC NTEMP=2
CCCCC C=1.0D0/DSQRT(2.0D0*PI)
CCCCC DK=DBLE(IK)
CCCCC DLAMB=DBLE(LAMBDA)
C
CCCCC DO100I=1,N
C
C110    CONTINUE
CCCCC   CALL UNIRAN(NTEMP,ISEED,U)
CCCCC   U1=DBLE(U(1))
C
CCCCC   V=(1.0D0 + 4.0D0*C*DSQRT(DK))*U1
C
CCCCC   IF(V.LE.1.0D0)THEN
CCCCC     X(I)=REAL(IK)
CCCCC     GOTO100
CCCCC   ELSEIF(V.GT.1.0D0 .AND. V.LE.1.0D0+2.0D0*C*DSQRT(DK))THEN
CCCCC     Y=DK + 1.0D0 + (V - 1.0D0)**2/(4.0D0*C*C)
CCCCC     T=C/DSQRT(Y-1.0D0-DK)
CCCCC   ELSE
CCCCC     Y=DK + 1.0D0 + (2.0D0*DK*C/(1.0D0+4.0D0*C*DSQRT(DK)-V))**2
CCCCC     T=DK*C/(Y-1.0D0-DK)**1.5
CCCCC   ENDIF
C
CCCCC   W=DBLE(U(2))
CCCCC   WT=W*T
CCCCC   CALL LPOCDF(REAL(Y),LAMBDA,K,CDF)
CCCCC   CALL LPOPDF(REAL(Y),LAMBDA,K,PDF)
CCCCC   CALL LPOPDF(REAL(Y),LAMBDA,K,PPF)
CCCCC   IF(WT.LT.DBLE(PPF))THEN
CCCCC     IY=INT(Y+0.5)
CCCCC     X(I)=REAL(IY)
CCCCC     GOTO100
CCCCC   ELSE
CCCCC     GOTO110
CCCCC   ENDIF
C
C 100 CONTINUE
C
      CALL UNIRAN(N,ISEED,X)
      DO100I=1,N
        XTEMP=X(I)
        CALL LPOPPF(XTEMP,LAMBDA,THETA,PPF)
        X(I)=PPF
  100 CONTINUE
C
 9999 CONTINUE
C
      RETURN
      END
      SUBROUTINE LPVARI(X,N,P,IWRITE,XTEMP,DTEMP,MAXNXT,XLPVAR,
     1                 IQUASE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE APPROXIMATE VARIANCE
C              OF THE SAMPLE LP LOCATION ESTIMATE OF THE DATA IN THE
C              INPUT VECTOR X.
C
C              GIVEN THE MODEL
C
C                 X(i) = ALPHA + E(i)
C
C              THE L(p) ESTIMATOR OF ALPHA IS
C
C                 L(p)(X(i)) = Arg(alpha)
C                     MIN{(SUM[i=1 to n][|X(i) - ALPHA|**p)**(1/p)}
C
C              OR EQUIVALENTLY
C
C                 L(p)(X(i)) = Arg(alpha)
C                     MIN{SUM[i=1 to n][|X(i) - ALPHA|**p}
C
C              THIS ESTIMATE IS THE SOLUTION OF THE EQUATION
C
C              SUM[i=1 to n][|X(i)-alpha|**(p-1)*SIGN(x(i)-ALPHA) = 0
C
C              THERE ARE 3 SPECIAL CASES:
C
C               P = 1   - SAMPLE MEDIAN
C               P = 2   - SAMPLE MEAN
C               P = INF - SAMPLE MID-RANGE
C
C               THE ESTIMATE OF THE ASYMPTOTIC VARIANCE IS THEN:
C
C               w(p)^2 = m(2*p-2)/[(p-1)*m(p-2)]**2
C
C               WHERE
C
C               m(r) = (1/n)*SUM[i=1 to n][|X(i)-Lp(X(i))|**r]
C
C               THE VARIANCE OF THE LP ESTIMATE IS THEN OBTAINED
C               BY DIVIDING w(p)^2 BY N.
C
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C                     --P      = THE SINGLE PRECISION VALUE OF THE
C                                "p" PARAMETER.
C     OUTPUT ARGUMENTS--XLPVAR = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED VARIANCE OF THE SAMPLE
C                                LP LOCATION ESTIMATE.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE VARIANCE OF
C             THE SAMPLE LP LOCATION ESTIMATE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, LPLOC.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--DABS.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--FRANCESCA PENNECCHI AND LUCA CALLEGARO, "BETWEEN
C                 THE MEAN AND THE MEDIAN: THE Lp ESTIMATOR",
C                 METROLOGIA, 43, 2006, PP. 213-219.
C
C     NOTE--SEEMS TO BE DISCREPANCY WITH FRANCESCA RESULTS IN
C           PAPER AND RESULT RETURNED HERE.  BOOTSTRAP ESTIMATE
C           IS CLOSE TO REPORTED RESULT, SUGGESTING THAT THE
C           PUBLISHED FORMULA MAY BE IN ERROR.  FRANCESCA WILL
C           INVESTIGATE, CODE BELOW WILL BE ADJUSTED WHEN I
C           HEAR BACK FROM HER.
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     ORIGINAL VERSION--NOVEMBER  2007.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IQUASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DOUBLE PRECISION DTEMP(*)
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DP
      DOUBLE PRECISION DSUM1
      DOUBLE PRECISION DSUM2
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DR1
      DOUBLE PRECISION DR2
      DOUBLE PRECISION DLP
      DOUBLE PRECISION DLPVAR
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='LPVA'
      ISUBN2='RI  '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF LPVARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N,P
   52   FORMAT('IBUGA3,N,P = ',A4,2X,I10,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,MIN(N,100)
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               **********************
C               **  COMPUTE LPLOC   **
C               **********************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1 .OR.N.GT.MAXNXT)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN VARIANCE OF LP LOCATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS IN THE')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,113)
  113   FORMAT('      RESPONSE VARIABLE IS LESS THAN 1 OR GREATER')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,115)MAXNXT
  115   FORMAT('      THAN ',I10)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I10,'.')
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(P.LT.1.0)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,122)
  122   FORMAT('      THE P PARAMETER IS LESS THAN 1.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,127)P
  127   FORMAT('      THE VALUE OF P = ',G15.7)
        CALL DPWRST('XXX','BUG ')
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XLPVAR=0.0
        GOTO8000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XLPVAR=0.0
      GOTO8000
  139 CONTINUE
C
      CALL LPLOC(X,N,P,IWRITE,XTEMP,DTEMP,MAXNXT,XLP,
     1           IBUGA3,IERROR)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE VARIANCE OF THE   **
C               **  Lp ESTIMATE.                  **
C               ************************************
C
       EPS=1.0E-06
       IF(ABS(P-1.0).LE.EPS)THEN
         P100=0.5
         CALL QUANSE(P100,X,N,IWRITE,XTEMP,MAXNXT,IQUASE,XLPVAR,
     1               IBUGA3,IERROR)
       ELSE
         DLP=DBLE(XLP)
         DP=DBLE(P)
         DSUM1=0.0D0
         DSUM2=0.0D0
         DR1=2.0D0*DP - 2.0D0
         DR2=DP - 2.0D0
C
         DO1000I=1,N
           DX=DBLE(X(I))
           DTERM1=DABS(DX-DLP)**DR1
           DTERM2=DABS(DX-DLP)**DR2
           DSUM1=DSUM1 + DTERM1
           DSUM2=DSUM2 + DTERM2
 1000   CONTINUE
C
        DTERM1=DSUM1/(DSUM2**2)
        DTERM2=DBLE(N)/((DP-1.0D0)**2)
        DLPVAR=DTERM1*DTERM2/DBLE(N)
        XLPVAR=REAL(DLPVAR)
      ENDIF
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
 8000 CONTINUE
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N
  811   FORMAT('THE VARIANCE OF THE Lp LOCATION ESTIMATE OF THE ',I8,
     1         ' OBSERVATIONS')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,813)XLPVAR,P
  813   FORMAT('= ',G15.7,'(P = ',F5.2,')')
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF LPVARI--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR
 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)N
 9013   FORMAT('N = ',I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)XLP,XLPVAR
 9015   FORMAT('XLP,XLPVAR = ',2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9017)DR1,DR2,DSUM1,DSUM2
 9017   FORMAT('DR1,DR2,DSUM1,DSUM2 = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      LOGICAL FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END
      SUBROUTINE LSNCDF(X,ALMBDA,SD,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING NORMAL
C              DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C                 LSNCDF(X,LAMBDA,SD) = SNCDF(LOG(X)/SD,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETERS = LAMBDA AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SNCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ISKNDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ***************************************
C               **  STEP 1--                         **
C               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      ISKNDF='DEFA'
      CALL SNCDF(LOG(X)/SD,ALMBDA,ISKNDF,CDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNPDF(X,ALMBDA,SD,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING NORMAL
C              DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 LSNPDF(X,LAMBDA,SD) = (1/(SD*X))*
C                                       SNPDF(LOG(X)/SD,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETER = LAMBDA.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NODPDF, NODCDF..
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DOUBLE PRECISION DX
      DOUBLE PRECISION DLMBDA
      DOUBLE PRECISION DSD
      DOUBLE PRECISION DTERM1
      DOUBLE PRECISION DTERM2
      DOUBLE PRECISION DPDF
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ***************************************
C               **  STEP 1--                         **
C               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.EQ.0.0)THEN
        PDF=0.0
        GOTO9000
      ELSEIF(X.LT.0.0)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)X
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    5 FORMAT('**** ERROR: ARGUMENT FOR LOG-SKEW-NORMAL DISTRIBUTION ',
     1       'IS NON-POSITIVE.')
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL DISTRIBUTION IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      DX=DBLE(X)
      DLMBDA=DBLE(ALMBDA)
      DSD=DBLE(SD)
C
      CALL NODCDF(DLOG(DX)*DLMBDA/DSD,DTERM1)
      CALL NODPDF(DLOG(DX)/DSD,DTERM2)
      DPDF=2.0D0*DTERM1*DTERM2
      DPDF=(1.0D0/(DSD*DX))*DPDF
      PDF=REAL(DPDF)
      GOTO9000
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNPPF(P,ALMBDA,SD,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = LAMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              TAKING THE EXPONENT OF THE SKEW-NORMAL PPF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --ALMBDA = THE FIRST SHAPE PARAMETER
C                     --SD     = THE SECOND SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--SNPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      CHARACTER*4 ISKNDF
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE LSNPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-NORMAL PPF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
      ISKNDF='DEFA'
      CALL SNPPF(P,ALMBDA,ISKNDF,PPF2)
      PPF=EXP(PPF2*SD)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSNRAN(N,ALMBDA,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-SKEWED-NORMAL DISTRIBUTION
C              WITH SHAPE PARAMETERS = ALMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              LOG-SKEWED-NORMAL RANDOM NUMBERS ARE FOUND BY
C              EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --ALMBDA = THE FIRST SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-NORMAL DISTRIBUTION.
C                     --SD     = THE SECOND SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-NORMAL DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-SKEWED-NORMAL DISTRIBUTION
C             WITH SHAPE PARAMETERS = ALMBDA AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--NORRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS
C                 DISTRIBUTION.  ALGORITHM FOR RANDOM NUMBERS
C                 ADAPTED FROM AZZALINI'S R FUNCTIONS FOR SKEW
C                 NORMAL.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION Y(2)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9999
      ENDIF
    5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-NORMAL DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
C
C     ALGORITM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY.
C
      DO100I=1,N
C
        CALL NORRAN(2,ISEED,Y)
        U1=Y(1)
        U2=Y(2)
        ATEMP=ALMBDA*U1
        IF(U2.GT.ATEMP)U1=-U1
        X(I)=EXP(SD*U1)
C
  100 CONTINUE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LSTCDF(X,NU,ALMBDA,SD,CDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE CUMULATIVE DISTRIBUTION FUNCTION
C                 LSTCDF(X,NU,LAMBDA,SD) = STCDF(LOG(X)/SD,NU,LAMBDA)
C              WITH SNPDF DENOTING THE SKEW-T PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE CUMULATIVE DISTRIBUTION
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--CDF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION
C             FUNCTION VALUE CDF FOR THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STCDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----DATA STATEMENTS-------------------------------------------------
C
C-----START POINT-----------------------------------------------------
C
C               ***************************************
C               **  STEP 1--                         **
C               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        CDF=0.0
        GOTO9000
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        CDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T CDF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL STCDF(LOG(X)/SD,NU,ALMBDA,CDF)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTPDF(X,NU,ALMBDA,SD,PDF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE
C              SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION).
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C                 LSTPDF(X,NU,LAMBDA,SD) = (1/(SD*X))*
C                             STPDF(LOG(X)/SD,NU,LAMBDA,SD)
C              WITH SNPDF DENOTING THE SKEW-T PROBABILITY
C              DENSITY FUNCTION.
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PROBABILITY DENSITY
C                                FUNCTION IS TO BE EVALUATED.
C                                X SHOULD BE NON-NEGATIVE.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PDF    = THE SINGLE PRECISION PROBABILITY
C                                DENSITY FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY
C             FUNCTION VALUE PDF FOR THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STPDF
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C               ***************************************
C               **  STEP 1--                         **
C               **  CHECK INPUT ARGUMENTS FOR ERRORS **
C               ***************************************
C
      IF(X.LE.0.0)THEN
        PDF=0.0
        GOTO9000
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PDF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T PDF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T PDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
C               ************************************
C               **  STEP 2--                      **
C               **  COMPUTE THE DENSITY FUNCTION  **
C               ************************************
C
      CALL STPDF(LOG(X)/SD,NU,ALMBDA,PDF)
      PDF=(1.0/(SD*X))*PDF
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTPPF(P,NU,ALMBDA,SD,PPF)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, LAMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE
C              PERCENT POINT FUNCTION IS COMPUTED BY
C              TAKING THE EXPONENT OF THE SKEW-T PPF FUNCTION.
C     INPUT  ARGUMENTS--P      = THE SINGLE PRECISION VALUE AT
C                                WHICH THE PERCENT POINT
C                                FUNCTION IS TO BE EVALUATED.
C                     --NU     = THE FIRST SHAPE PARAMETER
C                     --ALMBDA = THE SECOND SHAPE PARAMETER
C                     --SD     = THE THIRD SHAPE PARAMETER
C     OUTPUT ARGUMENTS--PPF    = THE SINGLE PRECISION CUMULATIVE
C                                DISTRIBUTION FUNCTION VALUE.
C     OUTPUT--THE SINGLE PRECISION PERCENT POINT
C             FUNCTION VALUE PPF.
C     PRINTING--NONE.
C     RESTRICTIONS--NONE.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STPPF.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--EXP.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C
      IF(P.LT.0.0.OR.P.GE.1.0)THEN
         WRITE(ICOUT,61)
   61    FORMAT('***** ERROR--THE FIRST  INPUT ARGUMENT ',
     1          'TO THE LSTPPF SUBROUTINE ')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,62)
   62    FORMAT('      IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,63)P
   63    FORMAT('      VALUE OF ARGUMENT = ',G15.7)
         CALL DPWRST('XXX','BUG ')
         PPF=0.0
         GOTO9000
      ENDIF
C
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,46)NU
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        PPF=0.0
        GOTO9000
      ENDIF
    6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T PPF IS NON-POSITIVE.')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T PPF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
   46 FORMAT('     VALUE OF THE ARGUMENT IS ',I8)
C
      CALL STPPF(P,NU,ALMBDA,PPF2)
      PPF=EXP(PPF2*SD)
C
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE LSTRAN(N,NU,ALMBDA,SD,ISEED,X)
C
C     PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N
C              FROM THE LOG-SKEWED-T DISTRIBUTION
C              WITH SHAPE PARAMETERS = NU, ALMBDA AND SD.
C              THIS DISTRIBUTION IS DEFINED FOR POSITIVE X.
C              LOG-SKEWED-T RANDOM NUMBERS ARE FOUND BY
C              EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS.
C     INPUT  ARGUMENTS--N      = THE DESIRED INTEGER NUMBER
C                                OF RANDOM NUMBERS TO BE
C                                GENERATED.
C                     --NU     = THE FIRST SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C                     --ALMBDA = THE SECOND SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C                     --SD     = THE THIRD SHAPE (PARAMETER) FOR THE
C                                LOG-SKEWED-T DISTRIBUTION.
C     OUTPUT ARGUMENTS--X      = A SINGLE PRECISION VECTOR
C                                (OF DIMENSION AT LEAST N)
C                                INTO WHICH THE GENERATED
C                                RANDOM SAMPLE WILL BE PLACED.
C     OUTPUT--A RANDOM SAMPLE OF SIZE N
C             FROM THE LOG-SKEWED-T DISTRIBUTION
C             WITH SHAPE PARAMETERS = NU, ALMBDA, AND SD.
C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
C                   OF N FOR THIS SUBROUTINE.
C                 --ALMBDA CAN BE ANY REAL NUMBER.
C     OTHER DATAPAC   SUBROUTINES NEEDED--STRAN.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS
C                 UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION,
C                 JOHN WILEY, 1994, PAGE 454.
C               --"Log-Skew-Normal and Log-Skew-t Distributions as
C                 Models for Family Income Data", Azzalini, Cappello,
C                 and Kotz, paper downloaded from Azzalini's web
C                 site.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATION 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 NATION INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--2004.3
C     ORIGINAL VERSION--MARCH     2004.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
C     CHECK THE INPUT ARGUMENTS FOR ERRORS
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,5)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,6)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)N
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(NU.LE.0)THEN
        WRITE(ICOUT,7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,47)NU
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
      IF(SD.LE.0.0)THEN
        WRITE(ICOUT,9)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,45)SD
        CALL DPWRST('XXX','BUG ')
        GOTO9000
      ENDIF
    5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-T DISTRIBUTION,')
    6 FORMAT('       THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ',
     1      'NON-POSITIVE.')
   47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****')
    7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ',
     1       'FREEDOM) SHAPE PARAMETER OF')
    8 FORMAT('     THE LOG-SKEW-T CDF IS NON-POSITIVE.')
    9 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ',
     1       'THE LOG-SKEW-T CDF IS NON-POSITIVE.')
   45 FORMAT('     VALUE OF THE ARGUMENT IS ',G15.7)
C
C     TRANSFORM SKEWED T RANDOM NUMBERS
C
      CALL STRAN(N,NU,ALMBDA,ISEED,X)
C
      DO100I=1,N
        X(I)=EXP(SD*X(I))
  100 CONTINUE
C
 9000 CONTINUE
      RETURN
      END
      subroutine ma(x, n, len, ave)
c
c  This routine is part of the Bill Cleveland seasonal loess
c  program.
c
      integer n, len, i, j, k, m, newn
      real x(n), ave(n), flen, v
      newn = n-len+1
      flen = real(len)
      v = 0.0
      do 23083 i = 1,len
      v = v+x(i)
23083 continue
      ave(1) = v/flen
      if(.not.(newn .gt. 1))goto 23085
      k = len
      m = 0
      do 23087 j = 2, newn
      k = k+1
      m = m+1
      v = v-x(m)+x(k)
      ave(j) = v/flen
23087 continue
23085 continue
      return
      end
      SUBROUTINE MAD(X,N,IWRITE,XTEMP,XTEMP2,MAXNXT,XMAD,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              SAMPLE MEDIAN ABSOLUTE DEVIATION (WITH DENOMINATOR N)
C              OF THE DATA IN THE INPUT VECTOR X.
C              THE SAMPLE MEDIAN ABSOLUTE DEVIATION = (THE MEDIAN OF
C              THE ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / N).
C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
C                                (UNSORTED OR SORTED) OBSERVATIONS.
C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
C                                IN THE VECTOR X.
C     OUTPUT ARGUMENTS--XMAD    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED SAMPLE MEDIAN ABSOLUTE DEVIATION.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             SAMPLE MEDIAN ABSOLUTE DEVIATION (WITH DENOMINATOR N-1).
C     OTHER DATAPAC   SUBROUTINES NEEDED--MEDIAN AND SORT.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION.
C     LANGUAGE--ANSI FORTRAN (1977)
C     REFERENCES--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION'
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--95/3
C     ORIGINAL VERSION--MARCH     1995.
C     UPDATED         --JULY      2010. ADD EXTRA DUMMY ARRAY SO
C                                       DON'T HAVE TO MODIFY ORIGINAL
C                                       X ARRAY
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 IWRIT2
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION X(*)
      DIMENSION XTEMP(*)
      DIMENSION XTEMP2(*)
C
C---------------------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAD '
      ISUBN2='    '
      IERROR='NO'
C
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF MAD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,52)IBUGA3,N
   52   FORMAT('IBUGA3,N = ',A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO55I=1,N
          WRITE(ICOUT,56)I,X(I)
   56     FORMAT('I,X(I) = ',I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   55   CONTINUE
      ENDIF
C
C               ******************************************
C               **  COMPUTE MEDIAN ABSOLUTE DEVIATION  **
C               ******************************************
C
C               ********************************************
C               **  STEP 1--                              **
C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
C               ********************************************
C
      AN=N
C
      IF(N.LT.1)THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,111)
  111   FORMAT('***** ERROR IN MEDIAN ABSOLUTE DEVIATION--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,112)
  112   FORMAT('      THE RESPONSE VARIABLE HAS LESS THAN ONE ',
     1         'OBSERVATION.')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,117)N
  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS = ',I8,'.')
        CALL DPWRST('XXX','BUG ')
        XMAD=CPUMIN
        IERROR='YES'
        GOTO9000
      ENDIF
C
      IF(N.EQ.1)THEN
        XMAD=0.0
        GOTO9000
      ENDIF
C
      HOLD=X(1)
      DO135I=2,N
        IF(X(I).NE.HOLD)GOTO139
  135 CONTINUE
      XMAD=0.0
      GOTO9000
  139 CONTINUE
C
C               ***********************************************
C               **  STEP 2--                                 **
C               **  COMPUTE THE MEDIAN ABSOLUTE DEVIATION.   **
C               ***********************************************
C
      IWRIT2='OFF'
      CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR)
C
      DO300I=1,N
        XTEMP2(I)=ABS(X(I)-XMED)
  300 CONTINUE
      CALL MEDIAN(XTEMP2,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR)
C
C               *******************************
C               **  STEP 3--                 **
C               **  WRITE OUT A LINE         **
C               **  OF SUMMARY INFORMATION.  **
C               *******************************
C
      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,811)N,XMAD
  811   FORMAT('THE MEDIAN ABSOLUTE DEVIATION OF THE ',I8,
     1         ' OBSERVATIONS = ',E15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'ON')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF MAD--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9012)IBUGA3,IERROR,N,XMED,XMAD
 9012   FORMAT('IBUGA3,IERROR,N,XMED,XMAD = ',A4,2X,A4,2X,I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE MAHDIS(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,
     1Y1,Y2,INDEX,DMEAN,
     1ICASE,IWRITE,IBUGA3,IERROR)
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE
C              MAHALONBIS DISTANCE OF A MATRIX.
C     INPUT  ARGUMENTS--AMAT1  = THE SINGLE PRECISION MATRIX
C                     --MAXROM = THE INTEGER ROW DIMENSION OF AMAT
C                     --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT
C                     --NR1    = THE INTEGER NUMBER OF ROWS OF AMAT
C                     --NC1    = THE INTEGER NUMBER OF COLUMNS OF AMAT
C     OUTPUT ARGUMENTS--AMAT3    = THE SINGLE PRECISION VALUE OF THE
C                                COMPUTED MAHALANOBIS DISTANCE MATRIX.
C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE
C             MAHALANOBIS DISTANCE MATRIX.
C     NOTE--THIS ROUTINE ASSUMES THE ERROR CHECKING (FOR EQUAL
C           ROWS AND COLUMNS, MATCHING DIMENSIONS FOR X AND AMAT)
C           IS DONE BT THE CALLING SUBROUTINE.
C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
C     LANGUAGE--ANSI FORTRAN (1977)
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 INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--98.7
C     ORIGINAL VERSION--JULY      1998.
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASE
      CHARACTER*4 IWRITE
      CHARACTER*4 IBUGA3
      CHARACTER*4 IERROR
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
C---------------------------------------------------------------------
C
      DIMENSION AMAT1(MAXROM,MAXCOM)
      DIMENSION AMAT2(MAXROM,MAXCOM)
      DIMENSION AMAT3(MAXROM,MAXCOM)
      DIMENSION Y1(*)
      DIMENSION Y2(*)
      DIMENSION INDEX(*)
      DOUBLE PRECISION DMEAN(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAHD'
      ISUBN2='IS  '
      IWRITE='NO'
      IERROR='NO'
C
      IF(IBUGA3.EQ.'OFF')GOTO90
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,51)
   51 FORMAT('***** AT THE BEGINNING OF MAHDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,52)IBUGA3,ICASE
   52 FORMAT('IBUGA3,ICASE = ',2A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,53)NR1,NC1
   53 FORMAT('NR1, NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
   90 CONTINUE
C
C               **********************************
C               **  COMPUTE MAHALNOBIS DISTANCE **
C               **********************************
C
      IF(ICASE.EQ.'COLU')THEN
        CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
         CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y1)
C
         IF(1.0+RCOND.EQ.1.0)THEN
           WRITE(ICOUT,999)
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,5171)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,5172)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,5173)
           CALL DPWRST('XXX','ERRO ')
           IERROR='YES'
           GOTO9000
         ENDIF
 5171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 5172 FORMAT('    PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER',
     1       ' ROWS.')
 5173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL ROWS.')
C
         IJOB=1
         CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB)
         DO5111I=1,NC1
           DO5113J=1,I
             IF(I.EQ.J)THEN
               AMAT3(I,I)=0.0
             ELSE
               DO5117K=1,NR1
                 Y1(K)=AMAT1(K,I)-AMAT1(K,J)
 5117          CONTINUE
               CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NR1,NR1,Y1,IWRITE,
     1                     XQUAD,IBUGA3,IERROR)
               AMAT3(I,J)=XQUAD
               AMAT3(J,I)=XQUAD
             ENDIF
 5113      CONTINUE
 5111    CONTINUE
      ELSE
        CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN,
     1            ICASE,IBUGA3,IERROR)
         CALL SGECO(AMAT2,MAXROM,NR1,INDEX,RCOND,Y1)
C
         IF(1.0+RCOND.EQ.1.0)THEN
           WRITE(ICOUT,999)
           CALL DPWRST('XXX','BUG ')
           WRITE(ICOUT,6171)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,6172)
           CALL DPWRST('XXX','ERRO ')
           WRITE(ICOUT,6173)
           CALL DPWRST('XXX','ERRO ')
           IERROR='YES'
           GOTO9000
         ENDIF
 6171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ',
     1       'THE COVARIANCE MATRIX.')
 6172 FORMAT('    PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER',
     1       ' ROWS.')
 6173 FORMAT('    SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ',
     1       'ORIGINAL ROWS.')
C
         IJOB=1
         CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB)
         DO6111I=1,NR1
           DO6113J=1,I
             IF(I.EQ.J)THEN
               AMAT3(I,I)=0.0
             ELSE
               DO6117K=1,NC1
                 Y1(K)=AMAT1(I,K)-AMAT1(J,K)
 6117          CONTINUE
               CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y1,IWRITE,
     1                     XQUAD,IBUGA3,IERROR)
               AMAT3(I,J)=XQUAD
               AMAT3(J,I)=XQUAD
             ENDIF
 6113      CONTINUE
 6111    CONTINUE
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT.      **
C               *****************
C
 9000 CONTINUE
      IF(IBUGA3.EQ.'OFF')GOTO9090
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9011)
 9011 FORMAT('***** AT THE END       OF MAHDIS--')
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9012)IBUGA3,IERROR
 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,9013)NR1,NC1
 9013 FORMAT('NR1,NC1 = ',2I8)
      CALL DPWRST('XXX','BUG ')
 9090 CONTINUE
C
      RETURN
      END
      SUBROUTINE MAINAN(ICASAN,ISEED,ANOPL1,ANOPL2,
     1                  TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
     1                  IFTEXP,IFTORD,ALOWFR,ALOWDG,IBOOSS,
     1                  ICAPSW,IFORSW,
     1                  IBUGAN,IBUGA2,IBUGA3,
     1                  IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR)
C
C     PURPOSE--THIS IS SUBROUTING MAINAN.
C              (THE   AN    AT THE END OF    MAINAN   STANDS FOR   ANALYSIS)
C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES ANALYSIS COMMANDS.
C              THE ANALYSIS COMMANDS SEARCHED FOR BY MAINAN ARE AS FOLLOWS--
C
C              CODE AT END: H => HTML OUTPUT IMPLEMENTED
C                           L => LATEX OUTPUT IMPLEMENTED
C                           R => RICH TEXT FORMAT OUTOUT IMPLEMENTED
C
C                  TABULATE/CROSS TABULATE                     (HLR)
C                  POSITIONAL TABULATION                       (HLR)
C
C                  ANALYSIS OF VARIANCE                        (HLR)
C                  MEDIAN POLISH                               (HLR)
C                  KRUSKAL-WALLIS TEST                         (HLR)
C                  VAN DER WAERDEN TEST                        (HLR)
C                  KENDALL TAU      INDEPENDENCE TEST          (HLR)
C                  RANK CORRELATION INDEPENDENCE TEST          (HLR)
C                  FRIEDMAN TEST                               (HLR)
C                  QUADE TEST                                  (HLR)
C                  PAGE TEST                                   (HLR)
C                  DURBIN TEST                                 (HLR)
C                  COCHRAN TEST                                (HLR)
C                  EQUAL SLOPES TEST                           (HLR)
C
C                  CONSENSUS MEANS                             (HLR)
C                  E691 INTERLAB                               (HLR)
C                  ONE SAMPLE PROFICIENCY TEST                 (HLR)
C                  TWO SAMPLE PROFICIENCY TEST                 (HLR)
C                  LIMIT OF DETECTION                          (HLR)
C
C                  CONFIDENCE LIMITS                           (HLR)
C                  PREDICTION LIMITS                           (HLR)
C                  PREDICTION BOUNDS                           (HLR)
C                  TOLERANCE LIMITS                            (HLR)
C                  BIWEIGHT CONFIDENCE LIMITS                  (HLR)
C                  TRIMMED MEAN CONFIDENCE LIMITS              (HLR)
C                  MEDIAN CONFIDENCE LIMITS                    (HLR)
C                  SD CONFIDENCE LIMITS                        (HLR)
C                  SD PREDICTION LIMITS                        (HLR)
C                  COEF OF VARIATION CONFIDENCE LIMITS         (HLR)
C                  COMMON COEF OF VARI CONFIDENCE LIMITS       (HLR)
C                  COEF OF DISPERSION CONFIDENCE LIMITS        (HLR)
C                  COEF OF QUARTILE DISP CONFIDENCE LIMITS     (HLR)
C                  QUANTILE CONFIDENCE LIMITS                  (HLR)
C                  DIFFERENCE OF MEANS CONFIDENCE LIMITS       (HLR)
C                  CORRELATION CONFIDENCE LIMITS               (HLR)
C                  HEDGES G CONFIDENCE LIMITS                  (HLR)
C
C                  PROPORTION CONFIDENCE LIMITS                (HLR)
C                  DIFFERENCE OF PROPORTION CONFIDENCE LIMITS  (HLR)
C                  BINOMIAL PROPORTION TEST                    (HLR)
C                  CHI-SQUARED INDEPENDENCE TEST Y1 Y2         (HLR)
C                  ODDS RATIO INDEPENDENCE TEST Y1 Y2          (HLR)
C                  FISHER EXACT TEST Y1 Y2                     (HLR)
C                  MCNEMAR TEST Y1 Y2                          (HLR)
C                  ODDS RATIO CHI-SQUARE TEST Y1 Y2 X          (HLR)
C                  MANTEL-HAENSZEL TEST Y1 Y2 X                (HLR)
C
C                  EXACT ... RATIONAL FIT                      (HLR)
C                  ... FIT                                     (HLR)
C                  ... PRE-FIT
C                  ... SMOOTH
C                  ... SPLINE FIT                              (HLR)
C                  YATES ANALYSIS = DEX FIT = 2**K FIT =       (HLR)
C                                    2**K DEX FIT
C                  (YATES) PHD ANALYSIS                        (HLR)
C                  ORTHOGONAL DISTANCE FIT
C                  BOOTSTRAP FIT                               (HLR)
C                  BEST CP Y X1 TO XK                          (HLR)
C                  LOWESS                                      (HLR)
C                  SEASONAL LOWESS
C                  LINEAR CALIBRATION                          (HLR)
C                  QUADRATIC CALIBRATION                       (HLR)
C
C                  LET
C                  LET FUNCTION
C
C                  RUNS                                        (HLR)
C                  LJUNG-BOX TEST                              (HLR)
C                      (AUTOCORRELATION TEST FOR RANDOMNESS)
C                  MEAN SUCCESSIVE DIFFERENCES TEST            (HLR)
C                      (RANDOMNESS TEST - TRENDS)
C                  COX STUART TEST Y                           (HLR)
C                      (SIGN TEST FOR TREND)
C                  FREQUENCY TEST (FOR RANDOMNESS)             (HLR)
C                  FREQUENCY WITHIN A BLOCK TEST (RANDOMNESS)  (HLR)
C                  CUMULATIVE SUM RANDOMNESS TEST              (HLR)
C
C                  COMPLETE SPATIAL RANDOMNESS TEST            (HLR)
C
C                  T TEST Y1 Y2 or Y MU or MU Y                (HLR)
C                  SIGN TEST Y1 Y2 or Y MU or MU Y OR Y1 Y2 D0 (HLR)
C                  WILCOXON SIGNED RANK TEST Y1 Y2 or Y1 Y2 D0 (HLR)
C                                            or Y MU
C                  MANN-WHITNEY RANK SUM TEST Y1 Y2            (HLR)
C                  FISHER TWO SAMPLE RANDOMIZATION TEST Y1 Y2  (HLR)
C
C                  CHI-SQUARED TEST Y SIGMA or SIGMA Y         (HLR)
C                  COEFFICIENT OF VARIATION TEST Y X GAMMA0    (HLR)
C                  COEFFICIENT OF VARIATION TEST Y1 X1 Y2 X2   (HLR)
C                  F TEST Y1 Y2                                (HLR)
C                  KLOTZ TEST Y1 Y2                            (HLR)
C                  SQUARED RANKS TEST Y X                      (HLR)
C                  MEDIAN TEST Y X                             (HLR)
C                  F LOCATION TEST Y X                         (HLR)
C                  BARTLETT'S TEST Y X1 X2 X3 X4 X5            (HLR)
C                  LEVENE TEST Y X                             (HLR)
C                  COCHRAN VARIANCE OUTLIER TEST Y X           (HLR)
C                  ANDERSON DARLING K-SAMPLE TEST Y X          (HLR)
C
C                  WILKS-SHAPIRO NORMALITY TEST Y              (HLR)
C                  JARQUE BERA   NORMALITY TEST Y              (HLR)
C                  POISSON DISPERSION      TEST Y              (HLR)
C                  <DIST> ANDERSON-DARLING GOOD OF FIT TEST Y  (HLR)
C                  <DIST> CHI-SQUARED GOODNESS OF FIT TEST Y   (HLR)
C                  <DIST> KOLMOGOROV-SMIRNOV GOODNESS OF FIT   (HLR)
C                                            TEST Y
C                  <DIST> PPCC GOOD OF FIT TEST Y              (HLR)
C                  CHI-SQUARED 2 SAMPLE TEST Y1 Y2             (HLR)
C                  KOLMOGOROV-SMIRNOV 2 SAMPLE TEST Y1 Y2      (HLR)
C                  DISTRIBUTIONAL LIKELIHOOD RATIO TEST Y      (HLR)
C                  BEST DISTRIBUTIONAL FIT Y                   (HLR)
C
C                  DIXON TEST Y                                (HLR)
C                  GRUBB TEST Y                                (HLR)
C                  TIETJEN-MOORE TEST Y                        (HLR)
C                  EXTREME STUDENTIZED DEVIATE TEST Y          (HLR)
C                  DAVID TEST Y                                (HLR)
C                  SKEWNESS OUTLIER TEST Y                     (HLR)
C                  KURTOSIS OUTLIER TEST Y                     (HLR)
C
C                  RELIABILITY TREND TESTS Y                   (HLR)
C
C                  SUMMARY                                     (HLR)
C                  CAPABILITY ANALYSIS                         (HLR)
C
C                  DDS               DDS Y 6 5 DELT   3/94
C                  ARMA              ARMA Y 2 1 2 1 1 1 12
C
C                  RECIPE            RECIPE <FIT/ANOVA> Y <X1 .. XN>
C                  SIMCOV            SIMCOV <FIT/ANOVA> Y <X1 .. XN>
C                  BBASIS <WEIBULL/NORMAL/LOGNORMAL> Y         (HLR)
C                  ABASIS <WEIBULL/NORMAL/LOGNORMAL> Y         (HLR)
C
C                  MCCOOL WEIBULL LOCATION TEST Y X            (HLR)
C                  COMMON WEIBULL SHAPE TEST Y X               (HLR)
C
C                  <DIST> MAXIMUM LIKELIHOOD Y                 (HLR)
C
C                  SINGLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA
C                  DOUBLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA (NOT WORKING)
C
C                  K MEANS CLUSTER Y1 TO YK                    (HLR)
C                  NORMAL MIXTURE CLUSTER Y1 TO YK             (HLR)
C                  K MEDOIDS CLUSTER Y1 TO YK
C                  FUZZY CLUSTER Y1 TO YK
C                  AGNES CLUSTER Y1 TO YK
C                     (SINGLE LINKAGE, COMPLETE LINKAGE,
C                      AVERAGE LINKAGE, CENTROID LINKAGE,
C                      WARD'S LINKAGE, WEIGHTED AVERAGE LINKAGE,
C                      GOWER'S LINKAGE)
C                  DIANA CLUSTER Y1 TO YK
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--JANUARY   1981.
C     UPDATED         --MARCH     1981.
C     UPDATED         --JULY      1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --OCTOBER   1981.
C     UPDATED         --NOVEMBER  1981.
C     UPDATED         --MARCH     1982.
C     UPDATED         --MAY       1982.
C     UPDATED         --JULY      1987. YATES ANALYSIS
C     UPDATED         --FEBRUARY  1988. LOWESS FIT
C     UPDATED         --DECEMBER  1988. LOWESS FRACTION
C     UPDATED         --MAY       1989. EXPERIMENTAL SIMULATION
C     UPDATED         --JUNE      1989. (2**K) DEX FIT = YATES ANALYSIS
C     UPDATED         --NOVEMBER  1989. YATES ... CUTOFF BRANCH
C     UPDATED         --NOVEMBER  1989. YATES OUTPUT BRANCH
C     UPDATED         --NOVEMBER  1989. CROSS-TABULATION
C     UPDATED         --SEPTEMBER 1990. CAPABILITY ANALYSIS
C     UPDATED         --SEPTEMBER 1993. (YATES) PHD ANALYSIS
C     UPDATED         --FEBRUARY  1994. REWRITE T TEST SECTION
C     UPDATED         --FEBRUARY  1994. CHI-SQUARED TEST
C     UPDATED         --FEBRUARY  1994. F TEST
C     UPDATED         --FEBRUARY  1994. BARTLETT'S TEST
C     UPDATED         --FEBRUARY  1994. ADD ARGUMENT TO DPLET
C     UPDATED         --MARCH     1994. DDS
C     UPDATED         --JUNE      1994. ADD ARGUMENT TO DPLET
C     UPDATED         --FEBRUARY  1995. RENAME PHD TO DEX PHD (A MORE
C                                       GENERAL PHD COMMAND MAY BE
C                                       ADDED LATER)
C     UPDATED         --JULY      1995. RECIPE ANALYSIS (MARK VANGEL)
C     UPDATED         --JULY      1995. MANDEL (2-WAY) ANALYSIS
C     UPDATED         --OCTOBER   1995. IFTORD
C     UPDATED         --APRIL     1996. FLAG FOR PRESERVING THE CASE
C                                       ON STRINGS
C     UPDATED         --SEPTEMBER 1997. RECIPE AND SIMCOV
C     UPDATED         --SEPTEMBER 1997. GRUBB TEST
C     UPDATED         --SEPTEMBER 1997. LEVENE TEST
C     UPDATED         --SEPTEMBER 1997. F LOCATION TEST
C     UPDATED         --SEPTEMBER 1997. ANDERSON DARLING 1-SAMPLE TEST
C     UPDATED         --JANUARY   1998. NAME CONFLICT WITH RECIPE AND
C                                       RECIPROCAL PROB PLOT AND PPCC PLOT
C     UPDATED         --MARCH     1998. WEIBULL MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1998. BBASIS WEIBULL/NORMAL/LOGNORMAL Y
C     UPDATED         --MARCH     1998. ABASIS WEIBULL/NORMAL/LOGNORMAL Y
C     UPDATED         --MARCH     1998. K-SAMPLE ANDERSON DARLING
C     UPDATED         --APRIL     1998. OTHER DISTRIBUTIONS FOR MLE
C     UPDATED         --MAY       1998. DEHAAN AND CME
C     UPDATED         --MAY       1998. RELIABILITY TREND TESTS
C     UPDATED         --JUNE      1998. GAMMA, POWER, DOUBLE
C                                       EXPONENTIAL MLE
C     UPDATED         --NOVEMBER  1998. TOLERANCE LIMITS
C     UPDATED         --NOVEMBER  1998. CHI-SQUARE GOODNESS OF FIT
C     UPDATED         --NOVEMBER  1998. KOLMOGOROV-SMIRNOV GOODNESS OF FIT
C     UPDATED         --DECEMBER  1998. CHI-SQUARE 2 SAMPLE TEST
C     UPDATED         --FEBRUARY  1999. UPDATE LOWESS TO SUPPORT
C                                       SEASONAL LOESS
C     UPDATED         --FEBRUARY  1999. UPDATE SMOOTH TO SUPPORT
C                                       LOW PASS AND HIGH PASS FILTER
C     UPDATED         --MARCH     1999. WILKS-SHAPIRO NORMALITY TEST
C     UPDATED         --MARCH     1999. SINGLE SAMPLE ACCEPTANCE PLAN
C     UPDATED         --MARCH     1999. DOUBLE SAMPLE ACCEPTANCE PLAN
C     UPDATED         --MARCH     1999. BETA BINOMIAL MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1999. GENERALIZED EXTREME VALUE MAXIMUM LIKELIHOOD Y
C     UPDATED         --MARCH     1999. WILKS-SHAPIRO NORMALITY TEST
C     UPDATED         --MARCH     1999. PROPORTIONS CONFIDENCE LIMITS
C     UPDATED         --MARCH     1999. DIFFERENCE OF PROPORTIONS
C     UPDATED         --MARCH     1999. DIFFERENCE OF MEANS
C                                       CONFIDENCE LIMITS
C     UPDATED         --MAY       1999. ARMA FIT
C     UPDATED         --JUNE      1999. SIGN TEST
C     UPDATED         --JUNE      1999. KRUSKAL-WALLIS TEST
C     UPDATED         --JUNE      1999. WILCOXON SIGNED RANK TEST
C     UPDATED         --JULY      1999. MANN-WHITNEY TEST
C     UPDATED         --AUGUST    1999. FIX TO LEVENE TEST
C     UPDATED         --AUGUST    1999. FIX TO BARTLETT TEST
C     UPDATED         --OCTOBER   2000. CONSENSUS MEANS
C                                       (MANDEL-PAULE)
C     UPDATED         --OCTOBER   2000. BOB (BAYESIAN IMPLEMENTATION
C                                       OF CONCENSUS MEANS)
C     UPDATED         --APRIL     2001. ORTHOGONAL DISTANCE FIT
C     UPDATED         --JULY      2001. EV1 SYNONYMS FOR ANDERSON
C                                       DARLING TEST
C     UPDATED         --NOVEMBER  2001. BIWEIGHT CONFIDENCE INTEVAL
C     UPDATED         --MAY       2002. TWO-SIDED POWER MAXI LIKE
C     UPDATED         --JUNE      2002. BEST CP
C     UPDATED         --JULY      2002. BOOTSTRAP FIT
C     UPDATED         --AUGUST    2002. CALL LIST TO CROSS TABULAE,
C                                       TABULATE
C     UPDATED         --OCTOBER   2002. CALL LIST TO SUMMARY
C     UPDATED         --OCTOBER   2002. CALL LIST TO CONSENSUS MEAN
C     UPDATED         --FEBRUARY  2003. TRIMMED MEAN CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. MEDIAN CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. QUANTILE CONFIDENCE INTERVAL
C     UPDATED         --FEBRUARY  2003. LUJAN-BOX TEST FOR RANDOMNESS
C     UPDATED         --JULY      2003. JOHNSON SB MOMEMTS
C     UPDATED         --JULY      2003. JOHNSON SU MOMEMTS
C     UPDATED         --JULY      2003. LINEAR CALIBRATION
C     UPDATED         --JULY      2003. QUADRATIC CALIBRATION
C     UPDATED         --OCTOBER   2003. FRIEDMAN TEST
C     UPDATED         --OCTOBER   2003. LOGISTIC MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. CAUCHY MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. BETA MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. UNIFORM MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2003. ANDERSON-DARLING LOGISTIC
C     UPDATED         --NOVEMBER  2003. ANDERSON-DARLING UNIFORM
C     UPDATED         --NOVEMBER  2003. ANDERSON-DARLING DOUBLE
C                                       EXPONENTIAL
C     UPDATED         --NOVEMBER  2003. FREQUENCY TEST
C     UPDATED         --NOVEMBER  2003. FREQUENCY WITHIN A BLOCK TEST
C     UPDATED         --DECEMBER  2003. CUSUM BLOCK TEST
C     UPDATED         --MARCH     2004. LOGARITHMIC SERIES MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. NEGATIVE BINOMIAL MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. GEOMETRIC MAXIMUM LIKELIHOOD
C     UPDATED         --MARCH     2004. HYPERGEOMETRIC MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MARCH     2004. POLYA MAXIMUM LIKELIHOOD
C     UPDATED         --APRIL     2004. JOHNSON PERCENTILE
C     UPDATED         --OCTOBER   2004. COCHRAN TEST
C     UPDATED         --OCTOBER   2004. VAN DER WAERDEN TEST
C     UPDATED         --DECEMBER  2004. ANDERSON-DARLING GAMMA
C     UPDATED         --FEBRUARY  2005. E691 INTERLAB
C     UPDATED         --MAY       2005. FRECHET MAXIMUM LIKELIHOOD
C     UPDATED         --MAY       2005. ANDERSON DARLING FRECHET
C     UPDATED         --MAY       2005. ANDERSON DARLING CAUCHY
C     UPDATED         --AUGUST    2005. INVERTED WEIBULL MAXI LIKE
C     UPDATED         --DECEMBER  2005. ALLOW "NORMAL" AND
C                                       "NONPARAMETRIC" FOR TOLERANCE
C                                       LIMITS COMMAND
C     UPDATED         --JANUARY   2006. DURBIN TEST
C     UPDATED         --FEBRUARY  2006. ALLOW "GRUBB MINIMUM" AND
C                                       "GRUB MAXIMUM"
C     UPDATED         --MAY       2006. BOREL-TANNER MAXIMUM LIKELIHOOD
C     UPDATED         --MAY       2006. ZETA MAXIMUM LIKELIHOOD
C     UPDATED         --MAY       2006. BETA-GEOMETRIC MAXIMUM LIKELIHOOD
C     UPDATED         --JUNE      2006. LAGRANGE-POISSON MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --JUNE      2006. LOG-BETA MAXIMUM LIKELIHOOD
C     UPDATED         --JUNE      2006. POLYA-AEPPLI MAXIMUM LIKELIHOOD
C     UPDATED         --JULY      2006. GENERALIZED LOGARITHMIC SERIES
C                                       MAXIMUM LIKELIHOOD
C     UPDATED         --JULY      2006. GEETA MLE
C     UPDATED         --JULY      2006. QUASI BINOMIAL TYPE I MLE
C     UPDATED         --AUGUST    2006. CONSUL MLE
C     UPDATED         --AUGUST    2006. LAGRANGE KATZ MLE
C     UPDATED         --OCTOBER   2006. POWER LAW MLE
C     UPDATED         --DECEMBER  2006. GENERALIZED LOST GAMES MLE
C     UPDATED         --JANUARY   2007. GOMPERTZ MLE
C     UPDATED         --JANUARY   2007. GENERALIZED GAMMA MLE
C     UPDATED         --FEBRUARY  2007. TOPP AND LEONE MLE
C     UPDATED         --FEBRUARY  2007. EXPONENTIAL LAW MLE
C     UPDATED         --FEBRUARY  2007. ODDS RATIO INDEPENDENCE TEST
C     UPDATED         --MARCH     2007. CHI-SQUARE INDEPENDENCE TEST
C     UPDATED         --MARCH     2007. FISHER EXACT TEST
C     UPDATED         --MARCH     2007. MCNEMAR TEST
C     UPDATED         --MARCH     2007. MANTEL-HAENSZEL TEST
C     UPDATED         --MARCH     2007. KATZ MAXIMUM LIKELIHOOD
C     UPDATED         --APRIL     2007. CHECK FOR FATAL ERROR
C     UPDATED         --JUNE      2007. FOUR PARAMETER BETA
C                                       MAXIMUM LIKELIHOOD
C     UPDATED         --JUNE      2007. LOG BETA MAXIMUM LIKELIHOOD
C     UPDATED         --JUNE      2007. SLASH MAXIMUM LIKELIHOOD
C     UPDATED         --JUNE      2007. BETA NORMAL MAXIMUM LIKELIHOOD
C     UPDATED         --JULY      2007. REFLECTED GENERALIZED TOPP
C                                       AND LEONE MAXIMUM LIKELIHOOD
C     UPDATED         --SEPTEMBER 2007. IERRST
C     UPDATED         --OCTOBER   2007. BURR TYPE 10 MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2007. BURR TYPE 12 MAXIMUM LIKELIHOOD
C     UPDATED         --OCTOBER   2007. WAKEBY MLE
C     UPDATED         --FEBRUARY  2008. LOGISTIC-EXPONENTIAL MLE
C     UPDATED         --FEBRUARY  2008. MAXIMUM LIKELIHOOD MIXTURE
C                                       CLUSTERING
C                                       (UNDER DEVELOPMENT)
C     UPDATED         --FEBRUARY  2008. MULTIVARIATE NORMAL MIXTURE
C                                       CLUSTERING
C                                       (UNDER DEVELOPMENT)
C     UPDATED         --MARCH     2008. TRUNCATED PARETO MLE
C     UPDATED         --MARCH     2008. REFLECTED POWER MLE
C     UPDATED         --MARCH     2008. BRITTLE FRACTURE MLE
C     UPDATED         --JUNE      2008. PEARSON TYPE 3 MLE
C     UPDATED         --JUNE      2008. KAPPA MLE
C     UPDATED         --JULY      2008. INVERTED GAMMA MLE
C     UPDATED         --JULY      2008. VON MISES MLE
C     UPDATED         --AUGUST    2008. BINOMIAL PROPORTION TEST
C     UPDATED         --AUGUST    2008. CALL LIST TO DPPRCL
C     UPDATED         --JANUARY   2009. ONE SAMPLE PROFICIENCY TEST
C     UPDATED         --JANUARY   2009. TWO SAMPLE PROFICIENCY TEST
C     UPDATED         --JANUARY   2009. LIMIT OF DETECTION
C     UPDATED         --NOVEMBER  2009. TIETJEN-MOORE TEST
C     UPDATED         --NOVEMBER  2009. EXTREME STUDENTIZED DEVIATE TEST
C     UPDATED         --NOVEMBER  2009. DIXON TEST
C     UPDATED         --FEBRUARY  2010. MAKE TABULATE A SYNONYM FOR
C                                       CROSS TABULATE
C     UPDATED         --MARCH     2010. SUPPORT "MULTIPLE" AND "REPLICATED"
C                                       OPTIONS FOR CONFIDENCE LIMITS/
C                                       DIFFERENCE OF MEANS CONFIDENCE LIMITS,
C                                       BIWEIGHT CONFIDENCE LIMITS, TRIMMED
C                                       MEAN CONFIDENCE LIMITS,
C                                       MEDIAN CONFIDENCE LIMITS,
C                                       QUANTILE CONFIDENCE LIMITS,
C     UPDATED         --APRIL     2010. 3-PARAMETER WEIBULL
C     UPDATED         --NOVEMBER  2010. 2-PARAMETER BRITTLE FIBER WEIBULL
C     UPDATED         --MARCH     2011. BEST DISTRIBUTIONAL FIT
C     UPDATED         --MAY       2011. KLOTZ TEST
C     UPDATED         --JUNE      2011. SQUARED RANKS TEST
C     UPDATED         --JUNE      2011. COX STUART TEST
C     UPDATED         --JUNE      2011. MEDIAN TEST
C     UPDATED         --JUNE      2011. FISHER TWO SAMPLE RANDOMIZATION
C                                       TEST
C     UPDATED         --JULY      2011. QUADE TEST
C     UPDATED         --JUNE      2012. JARQUE BERA NORMALITY TEST
C     UPDATED         --JUNE      2012. CORRELATION CONFIDENCE LIMITS
C     UPDATED         --SEPTEMBER 2012. FOLD PHD DEX FIT INTO YATES
C                                       FIT
C     UPDATED         --JANUARY   2013. MEAN SUCCESSIVE DIFFERENCES TEST
C     UPDATED         --FEBRUARY  2013. PAGE TEST
C     UPDATED         --MARCH     2013. KENDALL TAU INDEPENDENCE TEST
C     UPDATED         --MARCH     2013. RANK CORRELATION INDEPENDENCE
C                                       TEST
C     UPDATED         --APRIL     2013. PREDICTION LIMITS/BOUNDS
C     UPDATED         --APRIL     2013. SD CONFIDENCE LIMITS
C     UPDATED         --APRIL     2013. SD PREDICTION LIMITS
C     UPDATED         --AUGUST    2013. MCCOOL WEIBULL LOCATION TEST
C     UPDATED         --NOVEMBER  2013. POISSON DISPERSION TEST
C     UPDATED         --JANUARY   2014. COMPLETE SPATIAL RANDOMNESS
C     UPDATED         --FEBRUARY  2014. ERROR PROCESSING TO DPERRO
C     UPDATED         --APRIL     2014. 3-PARAMETER LOGNORMAL
C     UPDATED         --APRIL     2014. 3-PARAMETER GAMMA
C     UPDATED         --APRIL     2014. COMMON WEIBULL SHAPE TEST
C     UPDATED         --APRIL     2014. 3-PARAMETER INVERSE GAUSSIAN
C     UPDATED         --MAY       2014. SINGLE CALL FOR MAXIMUM
C                                       LIKELIHOOD
C     UPDATED         --MAY       2014. DISTRIBUTIONAL LIKELIHOOD RATIO
C                                       TEST
C     UPDATED         --FEBRUARY  2015. ADJACENCY RANDOMNESS TEST AS
C                                       SYNONYM FOR MEAN SUCCESSIVE
C                                       DIFFERENCES TEST
C     UPDATED         --APRIL     2015. COCHRAN VARIANCE OUTLIER TEST
C     UPDATED         --JUNE      2015. ARGUMENT LIST TO DPLET
C     UPDATED         --OCTOBER   2015. EQUAL SLOPES TEST
C     UPDATED         --JANUARY   2017. COEFFICIENT OF VARIATION
C                                       CONFIDENCE LIMITS
C     UPDATED         --JANUARY   2017. COMMON COEFFICIENT OF VARIATION
C                                       CONFIDENCE LIMITS
C     UPDATED         --MARCH     2017. K MEANS CLUSTERING
C     UPDATED         --APRIL     2017. NORMAL MIXTURE CLUSTERING
C     UPDATED         --APRIL     2017. SINGLE LINKAGE CLUSTERING
C     UPDATED         --JUNE      2017. COEFFICIENT OF VARIATION TEST
C     UPDATED         --AUGUST    2017. K MEDOIDS CLUSTERING
C     UPDATED         --AUGUST    2017. LOGNORMAL CONFIDENCE LIMITS
C     UPDATED         --NOVEMBER  2017. COEFFICIENT OF DISPERSION
C                                       CONFIDENCE LIMITS
C     UPDATED         --DECEMBER  2017. COEFFICIENT OF QUARTILE DISPERSION
C                                       CONFIDENCE LIMITS
C     UPDATED         --AUGUST    2018. HEDGES G CONFIDENCE LIMIT
C     UPDATED         --OCTOBER   2019. RATIO OF MEANS CONFIDENCE LIMIT
C     UPDATED         --OCTOBER   2019. DAVID TEST
C     UPDATED         --OCTOBER   2019. SKEWNESS OUTLIER TEST
C     UPDATED         --OCTOBER   2019. KURTOSIS OUTLIER TEST
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 ICASAN
      CHARACTER*4 IFORSW
      CHARACTER*4 IBUGAN
      CHARACTER*4 IBUGA2
      CHARACTER*4 IBUGA3
      CHARACTER*4 IBUGCO
      CHARACTER*4 IBUGEV
      CHARACTER*4 IBUGQ
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IFTEXP
CCCCC AUGUST 1995.  ADD FOLLOWING LINE
      CHARACTER*4 IFTORD
CCCCC APRIL 1996.  ADD FOLLOWING LINE
      CHARACTER*10 ISFLAG
CCCCC SEPTEMBER 1997.  ADD FOLLOWING LINE
      CHARACTER*4 ICASDI
      CHARACTER*4 ICAPSW
      CHARACTER*4 IMULT
      CHARACTER*4 IREPL
C
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
      DIMENSION TEMP(*)
      DIMENSION TEMP2(*)
      DIMENSION XTEMP1(*)
      DIMENSION XTEMP2(*)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOMC.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOSU.INC'
      INCLUDE 'DPCOS2.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      ISUBN1='MAIN'
      ISUBN2='AN  '
      IFOUND='NO'
      IERROR='NO'
      ICASAN='UNKN'
C
      IF(IBUGAN.EQ.'ON' .OR. ISUBRO.EQ.'INAN')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('***** AT THE BEGINNING OF MAINAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)IBUGAN,IBUGA2,IBUGA3
   53   FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,55)IBUGCO,IBUGEV,IBUGQ
   55   FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,56)IFTEXP,IANGLU,ALOWFR
   56   FORMAT('IFTEXP,IANGLU,ALOWFR = ',A4,2X,A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,58)ICASAN,ISEED,ANOPL1,ANOPL2
   58   FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,2G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,60)IFOUND,IERROR,MAXNXT,NUMARG
   60   FORMAT('IFOUND,IERROR,MAXNXT,NUMARG = ',2(A4,2X),2I8)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,67)ICOM,ICOM2
   67   FORMAT('ICOM,ICOM2 = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        DO70I=1,NUMARG
          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1           I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
          CALL DPWRST('XXX','BUG ')
   70   CONTINUE
      ENDIF
C
C               *************************
C               **  SEARCH FOR         **
C               **  ANALYSIS COMMANDS  **
C               *************************
C
CCCCC THE FOLLOWING SECTION WAS MOVED HERE TO BE FIRST   MAY 1992 (JJF)
CCCCC TO AVOID MISPROCESSING OF   LET FUNCTION A = FIT   MAY 1992 (JJF)
C               ***********************************
C               **  TREAT THE LET FUNCTION CASE  **
C               ***********************************
C
CCCCC APRIL 1996.  IF ENTERED AS LET STRING, PRESERVE CASE.  IF
CCCCC ENTERED AS LET FUNCTION, CONVERT TO UPPER CASE
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')THEN
        ISFLAG='FUNCTION'
        GOTO1800
      ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
     1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')THEN
        ISFLAG='STRING'
        GOTO1800
      ELSE
        GOTO1899
      ENDIF
C
 1800 CONTINUE
      ICASAN='LETF'
      CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
CCCCC APRIL 1996.  ADD FOLLOWING LINE.
     1ISFLAG,
     1IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1899 CONTINUE
C
C               **********************************************
C               **  TREAT THE ANALYSIS OF PROPORTIONS CASE  **
C               **********************************************
C
CCCCC IF(ICOM.EQ.'ANOP'.AND.IHARG(1).NE.'LIMI'.AND.
CCCCC1IHARG2(1).NE.'TS  '.AND.IHARG(1).NE.'PLOT'.AND.
CCCCC1IHARG2(1).NE.'    ')GOTO100
CCCCC GOTO199
C
CC100 CONTINUE
CCCCC ICASAN='ANOP'
CCCCC CALL DPANOP(ANOPL1,ANOPL2,IBUGA2,IBUGA3,IBUGQ,
CCCCC1IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CC199 CONTINUE
C
C               *******************************************
C               **  TREAT THE ANALYSIS OF VARIANCE CASE  **
C               *******************************************
C
      IF(ICOM.EQ.'ANAL' .OR. ICOM.EQ.'ANOV')THEN
        ICASAN='ANOV'
        CALL DPANOV(ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        GOTO9000
      ENDIF
C
C               *********************************************
C               **  TREAT THE EXACT ... RATIONAL FIT CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'EXAC')THEN
        ICASAN='EXAC'
        CALL DPEXAC(ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *************************************
C               **  TREAT THE LOWESS FIT     CASE  **
C               *************************************
C
      IF(ICOM.EQ.'LOWE')THEN
        IF(IHARG(1).EQ.'TAIL')GOTO1199
        IF(IHARG(1).EQ.'PRED')GOTO1199
        IF(IHARG(1).EQ.'COEF' .AND. IHARG(2).EQ.'OF  '.AND.
     1     IHARG(3).EQ.'VARI')GOTO1199
        IF(IHARG(1).EQ.'COEF' .AND. IHARG(2).EQ.'OF  '.AND.
     1     IHARG(3).EQ.'DISP')GOTO1199
        IF(IHARG(1).EQ.'ONE ' .AND. IHARG(2).EQ.'SIDE')GOTO1199
        GOTO1100
      ENDIF
      IF(ICOM.EQ.'LOES')GOTO1100
      IF(ICOM.EQ.'SEAS')GOTO1100
      GOTO1199
C
 1100 CONTINUE
      ICASAN='LOWF'
CCCCC MARCH 1994.  ADD ARGUMENT.
CCCCC CALL DPLOW(ALOWFR,
      CALL DPLOW(ALOWFR,ALOWDG,ICAPSW,IFORSW,
     1           TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
     1           IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 1199 CONTINUE
C
C               ************************************************
C               **  TREAT THE ORTHOGONAL DISTANCE FIT   CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'ORTH'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'DIST')THEN
        IF(IHARG(2).EQ.'FIT' .OR. IHARG(2).EQ.'REGR')THEN
          ICASAN='ORTF'
          CALL DPORTH(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1                IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ******************************
C               **  TREAT THE ... FIT CASE  **
C               ******************************
C
CCCCC THE FOLLOWING 8 LINES WERE ADDED JUNE 1989
      IF(ICOM.EQ.'BOOT')GOTO1799
      IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.2.AND.
     1IHARG(2).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.2.AND.
     1IHARG(2).EQ.'FIT')GOTO1799
      IF(ICOM.EQ.'BEST'.AND.NUMARG.GE.2.AND.
     1IHARG(1).EQ.'DIST'.AND.IHARG(2).EQ.'FIT')GOTO1799
      IF(IHARG(1).EQ.'BEST'.AND.
     1IHARG(2).EQ.'DIST'.AND.IHARG(3).EQ.'FIT')GOTO1799
C
      IF(ICOM.EQ.'FIT ')GOTO1700
CCCCC CHECK FOR "RECIPE FIT" AND "SIMCOV FIT" CASES.  SEPTEMBER 1997
      IF(NUMARG.GE.1.AND.ICOM.NE.'SPLI'.AND.ICOM.NE.'PRE '.AND.
CCCCC1ICOM.NE.'LOWE'.AND.
     1ICOM.NE.'LOWE'.AND.ICOM.NE.'RECI'.AND.ICOM.NE.'SIMC'.AND.
     1IHARG(1).EQ.'FIT ')GOTO1700
      DO1710I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).NE.'SPLI'.AND.IHARG(1).NE.'PRE '
     1.AND.IHARG(IM1).NE.'OF'
     1.AND.IHARG(I).EQ.'FIT ')GOTO1700
 1710 CONTINUE
      GOTO1799
C
 1700 CONTINUE
      ICASAN='FIT'
      CALL DPFIT(ICAPSW,IFORSW,
     1           IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1           IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 1799 CONTINUE
C
C               ******************************
C               **  TREAT THE BEST CP CASE  **
C               ******************************
C
      IF(ICOM.EQ.'BEST'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'CP  ')THEN
        ICASAN='CP'
        CALL DPBECP(ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE BOOTSTRAP FIT **
C               ******************************
C
      IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND.
     1IHARG(1).EQ.'FIT ')THEN
        ICASAN='BFIT'
        CALL DPBOFI(ICAPSW,IFORSW,
     1              ISEED,IBOOSS,
     1              IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.2.AND.
     1       IHARG(1).EQ.'REPL'.AND.IHARG(2).EQ.'FIT ')THEN
        ICASAN='BFIT'
        CALL DPBOFI(ICAPSW,IFORSW,
     1              ISEED,IBOOSS,
     1              IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT HERE    MAY 1992 (JJF)
CCCCC AND MOVED UP TO THE TOP OF THIS SUBROUTINE      MAY 1992 (JJF)
CCCCC TO FIX MISPROCESSING OF    LET STRING A = FIT   MAY 1992 (JJF)
CCCCC           ***********************************
CCCCC           **  TREAT THE LET FUNCTION CASE  **
CCCCC           ***********************************
CCCCC
CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
CCCCC1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')GOTO1800
CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND.
CCCCC1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')GOTO1800
CCCCC GOTO1899
CCCCC
C1800 CONTINUE
CCCCC ICASAN='LETF'
CCCCC CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
CCCCC1IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC
C1899 CONTINUE
C
C               **************************
C               **  TREAT THE LET CASE  **
C               **************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'LET')THEN
        ICASAN='LET'
        CALL DPLET(IANGLU,ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,
     1             TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
CCCCC              AUGUST 1995.  ADD IFTORD
CCCCC              JUNE   2015.  ADD IFORSW
CCCCC1             IFTEXP,
     1             IFTEXP,IFTORD,IFORSW,
CCCCC              ADD FOLLOWING LINE.  FEBRUARY 1994.
CCCCC              ADD OPTACC ARGUMENT JUNE 1994
CCCCC              ADD IOTME, IOPTHE ARGUMENTS FEBRUARY 1995
     1             ROOTAC,OPTACC,IOPTME,IOPTHE,
     1             ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN      JULY 1995
C               ************************************
C               **  TREAT THE MEDIAN POLISH CASE  **
C               ************************************
C
      IF(ICOM.EQ.'MEDI'.AND.
     1   NUMARG.GE.1.AND.IHARG(1).EQ.'POLI'.AND.
     1   IHARG2(1).EQ.'SH  ')THEN
         ICASAN='MEPO'
         CALL DPMEPO(ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 1995
C               **********************************************
C               **  TREAT THE MANDEL (2-WAY) ANALYSIS CASE  **
C               **********************************************
C
CCCCC APRIL 1996.  FOLLOWING CODE IS NOT WORKING YET
CCCCC OCTOBER 2000.  UPDATE (CALL IT CONCENSUS MEANS OR
CCCCC MANDEL-PAULE, IT IMPLEMENTS BOTH MANDEL-PAULE AND
CCCCC MARK VANGEL'S MAXIMUM LIKELIHOOD APPROACH).
C
      IF(ICOM.EQ.'MAND'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PAUL')THEN
         ICASAN='MAND'
         CALL DPMAND(ICAPSW,IFORSW,ISEED,IBOOSS,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'CONS'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEAN')THEN
         ICASAN='MAND'
         CALL DPMAND(ICAPSW,IFORSW,ISEED,IBOOSS,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      FEBRUARY 2005
C               **********************************************
C               **  TREAT THE E691 INTERLAB           CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'E691'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'INTE'.AND.
     1   IHARG(2).EQ.'ANAL')THEN
         ICASAN='E691'
         CALL DPEINL(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'E691'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'INTE')THEN
         ICASAN='E691'
         CALL DPEINL(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      OCTOBER 2008
C               **************************************************
C               **  TREAT THE ONE SAMPLE PROFICIENCY TEST CASE  **
C               **************************************************
C
      IF(ICOM.EQ.'ONE '.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'SAMP'.AND.
     1   IHARG(2).EQ.'PROF'.AND.IHARG(3).EQ.'TEST')THEN
         ICASAN='1SPT'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DP1IPT(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'ONE '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1       IHARG(2).EQ.'PROF')THEN
         ICASAN='1SPT'
         ISHIFT=2
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DP1IPT(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      OCTOBER 2008
C               **************************************************
C               **  TREAT THE TWO SAMPLE PROFICIENCY TEST CASE  **
C               **************************************************
C
      IF(ICOM.EQ.'TWO '.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'SAMP'.AND.
     1   IHARG(2).EQ.'PROF'.AND.IHARG(3).EQ.'TEST')THEN
         ICASAN='2SPT'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DP2IPT(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'TWO '.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1       IHARG(2).EQ.'PROF')THEN
         ICASAN='2SPT'
         ISHIFT=2
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DP2IPT(ICAPSW,IFORSW,ISUBRO,
     1               IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JANUARY 2009
C               **************************************************
C               **  TREAT THE LIMIT OF DETECTION          CASE  **
C               **************************************************
C
      IMULT='OFF'
      IREPL='OFF'
      IF(ICOM.EQ.'DIRT'.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'LIMI'.AND.
     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'DETE')THEN
         ICASAN='LODD'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DPLODE(ICASAN,ICAPSW,IFORSW,IMULT,IREPL,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'CLEA'.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'LIMI'.AND.
     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'DETE')THEN
         ICASAN='LODC'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DPLODE(ICASAN,ICAPSW,IFORSW,IMULT,IREPL,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'REPL'.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'LIMI'.AND.
     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'DETE')THEN
         IREPL='ON'
         ICASAN='LODD'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DPLODE(ICASAN,ICAPSW,IFORSW,IMULT,IREPL,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'MULT'.AND.NUMARG.GE.3.AND.IHARG(1).EQ.'LIMI'.AND.
     1   IHARG(2).EQ.'OF  '.AND.IHARG(3).EQ.'DETE')THEN
         IMULT='ON'
         ICASAN='LODD'
         ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DPLODE(ICASAN,ICAPSW,IFORSW,IMULT,IREPL,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      ELSEIF(ICOM.EQ.'LIMI'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'OF  '.AND.
     1       IHARG(2).EQ.'DETE')THEN
         ICASAN='LODD'
         ISHIFT=2
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         CALL DPLODE(ICASAN,ICAPSW,IFORSW,IMULT,IREPL,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 2003
C               **********************************************
C               **  TREAT THE LINEAR CALIBRATION      CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN
         ICASAN='LICA'
         CALL DPLICA(ICAPSW,IFORSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      JULY 2003
C               **********************************************
C               **  TREAT THE QUADRATIC CALIBRATION   CASE  **
C               **********************************************
C
      IF(ICOM.EQ.'QUAD'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN
         ICASAN='QUCA'
         CALL DPLICA(ICAPSW,IFORSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED      MARCH 2017
C               *****************************************************
C               **  TREAT THE K-MEANS        CLUSTER         CASE  **
C               **  TREAT THE NORMAL MIXTURE CLUSTER         CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'K   '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEAN')THEN
         ICASAN='KMEA'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'NORM'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MIXT')THEN
         ICASAN='NMIX'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'K   '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEDO')THEN
         ICASAN='KMED'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'K   '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEDI')THEN
         ICASAN='KMED'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'SING'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'LINK')THEN
         ICASAN='SLIN'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'AGNE')THEN
         ICASAN='AGNE'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'DIAN')THEN
         ICASAN='DIAN'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'FANN' .OR. ICOM.EQ.'FUZZ')THEN
         ICASAN='FANN'
         CALL DPKMEA(ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C
C               **********************************
C               **  TREAT THE ... PRE-FIT CASE  **
C               **********************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'PRE '.AND.IHARG(1).EQ.'FIT ')
     1GOTO2200
      DO2210I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'PRE '.AND.IHARG(I).EQ.'FIT ')
     1GOTO2200
 2210 CONTINUE
      IF(ICOM.EQ.'PREF')GOTO2200
      DO2220I=1,4
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'PREF'.AND.
     1IHARG2(I).EQ.'IT  ')GOTO2200
 2220 CONTINUE
      GOTO2299
C
 2200 CONTINUE
      ICASAN='PREF'
      CALL DPPREF(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1            IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2299 CONTINUE
C
C               *********************************
C               **  TREAT THE ... SMOOTH CASE  **
C               *********************************
C
      IF(ICOM.EQ.'SMOO')GOTO2300
      IF(ICOM.EQ.'LOW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300
      IF(ICOM.EQ.'HIGH'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300
      DO2310I=1,3
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND.
     1IHARG2(I).EQ.'TH  ')GOTO2300
      IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND.
     1IHARG2(I).EQ.'THIN')GOTO2300
 2310 CONTINUE
      GOTO2399
C
 2300 CONTINUE
      ICASAN='SMOO'
      CALL DPSMOO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2399 CONTINUE
C
C               *************************************
C               **  TREAT THE ... SPLINE FIT CASE  **
C               *************************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'SPLI'.AND.IHARG(1).EQ.'FIT ')
     1GOTO2400
      DO2410I=2,5
      IM1=I-1
      IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'SPLI'.AND.IHARG(I).EQ.'FIT ')
     1GOTO2400
 2410 CONTINUE
      GOTO2499
C
 2400 CONTINUE
      ICASAN='SPLI'
      CALL DPSPL(IBUGA2,IBUGA3,IBUGQ,ISUBRO,
     1           ICASAN,ICAPSW,IFORSW,
     1           IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      GOTO9000
C
 2499 CONTINUE
C
C               ******************************
C               **  TREAT THE SUMMARY CASE  **
C               ******************************
C
      IF(ICOM.EQ.'SUMM' .OR. IHARG(1).EQ.'SUMM')THEN
        IF(IHARG(1).EQ.'HOMO'.AND.IHARG(2).EQ.'PLOT')GOTO2599
        IF(IHARG(1).EQ.'SUBS'.AND.IHARG(2).EQ.'HOMO'.AND.
     1     IHARG(3).EQ.'PLOT')GOTO2599
        IF(IHARG(1).EQ.'HIGH'.AND.IHARG(2).EQ.'HOMO'.AND.
     1     IHARG(3).EQ.'PLOT')GOTO2599
        ICASAN='SUMM'
        CALL DPSUMM(XTEMP1,XTEMP2,MAXNXT,
     1              ICASAN,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 2599 CONTINUE
C
C               ****************************************
C               **  TREAT THE FOLLOWING CASES:        **
C               **    1) PREDICTION LIMITS            **
C               **    2) PREDICTION BOUNDS            **
C               **    3) SD PREDICTION LIMITS         **
C               ****************************************
C
      IMULT='OFF'
      IREPL='OFF'
      IF(ICOM.EQ.'PRED' .OR. IHARG(1).EQ.'PRED' .OR.
     1   IHARG(2).EQ.'PRED' .OR. IHARG(3).EQ.'PRED' .OR.
     1   IHARG(4).EQ.'PRED' .OR. IHARG(5).EQ.'PRED' .OR.
     1   IHARG(6).EQ.'PRED' .OR. IHARG(7).EQ.'PRED')THEN
        CALL DPPRLI(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************************
C               **  TREAT THE SD CONFIDENCE LIMIT CASE **
C               *****************************************
C
      IMULT='OFF'
      IREPL='OFF'
      IF(ICOM.EQ.'CONF' .OR. IHARG(1).EQ.'CONF' .OR.
     1   IHARG(2).EQ.'CONF' .OR. IHARG(3).EQ.'CONF' .OR.
     1   IHARG(4).EQ.'CONF' .OR. IHARG(5).EQ.'CONF')THEN
        CALL DPSDCI(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************************************
C               **  TREAT THE COEF OF VARI CONFIDENCE LIMIT CASE **
C               **  TREAT THE COEF OF DISP CONFIDENCE LIMIT CASE **
C               ***************************************************
C
      IMULT='OFF'
      IREPL='OFF'
      IF(ICOM.EQ.'CONF' .OR. IHARG(1).EQ.'CONF' .OR.
     1   IHARG(2).EQ.'CONF' .OR. IHARG(3).EQ.'CONF' .OR.
     1   IHARG(4).EQ.'CONF' .OR. IHARG(5).EQ.'CONF' .OR.
     1   IHARG(6).EQ.'CONF' .OR. IHARG(7).EQ.'CONF')THEN
        CALL DPCVCI(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,ISEED,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *************************************************
C               **  TREAT THE BIWEIGHT CONFIDENCE LIMITS CASE  **
C               *************************************************
C
C     MARCH 2010: SUPPORT FOR "MULTIPLE" AND "REPLICATED" OPTIONS
C
      IMULT='OFF'
      IREPL='OFF'
      ISHIFT=0
      IF(ICOM.EQ.'BIWE')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF' .AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
        ENDIF
      ELSEIF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'BIWE' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IMULT='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ELSEIF(ICOM.EQ.'REPL' .AND. IHARG(1).EQ.'BIWE' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IREPL='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ENDIF
C
      IF(ISHIFT.GT.0)THEN
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICASAN='ONEV'
        CALL DPBWCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************************************
C               **  TREAT THE TRIMMED MEAN CONFIDENCE LIMITS CASE  **
C               *****************************************************
C
C     MARCH 2010: SUPPORT FOR "MULTIPLE" AND "REPLICATED" OPTIONS
C
      IMULT='OFF'
      IREPL='OFF'
      ISHIFT=0
      IF(ICOM.EQ.'TRIM' .AND. IHARG(1).EQ.'MEAN')THEN
        IF(NUMARG.GE.3.AND.IHARG(2).EQ.'CONF' .AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ELSEIF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'TRIM' .AND.
     1       IHARG(2).EQ.'MEAN' .AND. IHARG(3).EQ.'CONF')THEN
        IMULT='ON'
        IF(NUMARG.GE.4.AND.
     1    (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN
          ISHIFT=4
        ENDIF
      ELSEIF(ICOM.EQ.'REPL' .AND. IHARG(1).EQ.'TRIM' .AND.
     1       IHARG(2).EQ.'MEAN' .AND. IHARG(3).EQ.'CONF')THEN
        IREPL='ON'
        IF(NUMARG.GE.4.AND.
     1    (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN
          ISHIFT=4
        ENDIF
      ENDIF
C
      IF(ISHIFT.GT.0)THEN
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICASAN='TMCI'
        CALL DPTMCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************************************
C               **  TREAT THE MEDIAN       CONFIDENCE LIMITS CASE  **
C               **  TREAT THE QUANTILE     CONFIDENCE LIMITS CASE  **
C               *****************************************************
C
C     MARCH 2010: SUPPORT FOR "MULTIPLE" AND "REPLICATED" OPTIONS
C
      IMULT='OFF'
      IREPL='OFF'
      ISHIFT=0
C
      IF(ICOM.EQ.'MEDI')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF' .AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
        ENDIF
      ELSEIF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'MEDI' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IMULT='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ELSEIF(ICOM.EQ.'REPL' .AND. IHARG(1).EQ.'MEDI' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IREPL='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ENDIF
C
      IF(ISHIFT.GT.0)THEN
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICASAN='MECI'
        CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
      IF(ICOM.EQ.'QUAN')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF' .AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
        ENDIF
      ELSEIF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'QUAN' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IMULT='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ELSEIF(ICOM.EQ.'REPL' .AND. IHARG(1).EQ.'QUAN' .AND.
     1       IHARG(2).EQ.'CONF')THEN
        IREPL='ON'
        IF(NUMARG.GE.3.AND.
     1    (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
        ENDIF
      ENDIF
C
      IF(ISHIFT.GT.0)THEN
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICASAN='QUCI'
        CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************************************
C               **  TREAT THE PROPORTION CONFIDENCE LIMITS CASE  **
C               **  AND DIFFERENCE OF PROPORTION CONFIDENCE      **
C               **  LIMITS CASE                                  **
C               ***************************************************
C
      IF(ICOM.EQ.'PROP')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1    (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
          ISHIFT=2
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='PROP'
          CALL DPPRCL(MAXNXT,ICASAN,ANOPL1,ANOPL2,ICAPSW,IFORSW,
     1                ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
      IF(ICOM.EQ.'DIFF')THEN
        IF(NUMARG.GE.4.AND.IHARG(1).EQ.'OF  '.AND.
     1    IHARG(2).EQ.'PROP'.AND.IHARG(3).EQ.'CONF'.AND.
     1    (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN
          ISHIFT=4
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='DPRO'
          CALL DPPRCL(MAXNXT,ICASAN,ANOPL1,ANOPL2,ICAPSW,IFORSW,
     1                ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
        IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PROP'.AND.
     1     IHARG(2).EQ.'CONF'.AND.
     1     (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
          ISHIFT=3
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGA2,IERROR)
          ICASAN='DPRO'
          CALL DPPRCL(MAXNXT,ICASAN,ANOPL1,ANOPL2,ICAPSW,IFORSW,
     1                ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ****************************************
C               **  TREAT THE TOLERANCE  LIMITS CASE  **
C               ****************************************
C
      IF(ICOM.EQ.'TOLE' .OR. IHARG(1).EQ.'TOLE' .OR.
     1   IHARG(2).EQ.'TOLE' .OR. IHARG(3).EQ.'TOLE')THEN
         CALL DPTOLI(XTEMP1,XTEMP2,TEMP2,MAXNXT,
     1              ICASAN,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
      ENDIF
C
C               ******************************
C               **  TREAT THE RUNS    CASE  **
C               ******************************
C
      IF(ICOM.EQ.'RUNS' .OR. IHARG(1).EQ.'RUNS' .OR.
     1   IHARG(2).EQ.'RUNS')THEN
        ICASAN='RUNS'
        CALL DPRUN(XTEMP1,MAXNXT,ICASAN,ICAPSW,IFORSW,
     1             IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *********************************************
C               **  TREAT THE RELIABILTY TREND TESTS CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'RELI')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TREN'.AND.
     1     IHARG(2).EQ.'TEST')THEN
             ICASAN='TREN'
             ISHIFT=2
             CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                   IBUGA2,IERROR)
             CALL DPTREN(XTEMP2,MAXNXT,ICAPSW,IFORSW,
     1                   IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
             IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS REWRITTEN     FEBRUARY 1994
C               ******************************
C               **  TREAT THE T TEST  CASE  **
C               ******************************
C
      IF((ICOM.EQ.'T   ' .AND. IHARG(1).EQ.'TEST') .OR.
     1    (IHARG(1).EQ.'T   ' .AND. IHARG(2).EQ.'TEST') .OR.
     1    (IHARG(2).EQ.'T   ' .AND. IHARG(3).EQ.'TEST') .OR.
     1    (IHARG(3).EQ.'T   ' .AND. IHARG(4).EQ.'TEST') .OR.
     1    (IHARG(4).EQ.'T   ' .AND. IHARG(5).EQ.'TEST') .OR.
     1    (IHARG(5).EQ.'T   ' .AND. IHARG(6).EQ.'TEST')
     1   )THEN
        CALL DPTTES(XTEMP1,MAXNXT,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED         JUNE 2017
C               *****************************************************
C               **  TREAT THE COEFFICIENT OF VARIATION TEST  CASE  **
C               *****************************************************
C
      IF((ICOM.EQ.'ONE ' .AND. IHARG(1).EQ.'SAMP') .OR.
     1   (ICOM.EQ.'1   ' .AND. IHARG(1).EQ.'SAMP') .OR.
     1   (ICOM.EQ.'TWO ' .AND. IHARG(1).EQ.'SAMP') .OR.
     1   (ICOM.EQ.'2   ' .AND. IHARG(1).EQ.'SAMP'))THEN
        CALL DPCVTE(XTEMP1,XTEMP2,MAXNXT,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
C               *********************************
C               **  TREAT THE SIGN TEST  CASE  **
C               *********************************
C
      IF(ICOM.EQ.'SIGN' .OR. IHARG(1).EQ.'SIGN' .OR.
     1   IHARG(2).EQ.'SIGN')THEN
         CALL DPSIGN(XTEMP1,XTEMP2,MAXNXT,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
CCCCC THE FOLLOWING SECTION WAS REWRITTEN     MAY      2011
C               *************************************************
C               **  TREAT THE WILCOXON SIGNED RANK TEST  CASE  **
C               *************************************************
C
      IF((ICOM.EQ.'SIGN' .AND. IHARG(1).EQ.'RANK') .OR.
     1    (IHARG(1).EQ.'SIGN' .AND. IHARG(2).EQ.'RANK') .OR.
     1    (IHARG(2).EQ.'SIGN' .AND. IHARG(3).EQ.'RANK') .OR.
     1    (IHARG(3).EQ.'SIGN' .AND. IHARG(4).EQ.'RANK') .OR.
     1    (IHARG(4).EQ.'SIGN' .AND. IHARG(5).EQ.'RANK') .OR.
     1    (IHARG(5).EQ.'SIGN' .AND. IHARG(6).EQ.'RANK')
     1   )THEN
        CALL DPWILC(XTEMP1,XTEMP2,MAXNXT,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 1999
C               *************************************************
C               **  TREAT THE MANN-WHITNEY RANK SUM TEST  CASE **
C               *************************************************
C
      IF( (ICOM.EQ.'MANN'     .AND. IHARG(1).EQ.'WHIT') .OR.
     1    (IHARG(1).EQ.'MANN' .AND. IHARG(2).EQ.'WHIT') .OR.
     1    (IHARG(2).EQ.'MANN' .AND. IHARG(3).EQ.'WHIT') .OR.
     1    (IHARG(3).EQ.'MANN' .AND. IHARG(4).EQ.'WHIT') .OR.
     1    (ICOM.EQ.'RANK'     .AND. IHARG(1).EQ.'SUM ') .OR.
     1    (IHARG(1).EQ.'RANK' .AND. IHARG(2).EQ.'SUM ') .OR.
     1    (IHARG(2).EQ.'SIGN' .AND. IHARG(3).EQ.'RANK') .OR.
     1    (IHARG(3).EQ.'SIGN' .AND. IHARG(4).EQ.'RANK')
     1   )THEN
         CALL DPMANN(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2011
C               **************************************************
C               **  TREAT THE FISHER TWO SAMPLE RAND TEST  CASE **
C               **************************************************
C
      IF( (ICOM.EQ.'FISH'     .AND. IHARG(1).EQ.'TWO ') .OR.
     1    (IHARG(1).EQ.'FISH' .AND. IHARG(2).EQ.'TWO ') .OR.
     1    (IHARG(2).EQ.'FISH' .AND. IHARG(3).EQ.'TWO ') .OR.
     1    (IHARG(3).EQ.'FISH' .AND. IHARG(4).EQ.'TWO ')
     1   )THEN
         CALL DPFIRT(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 2011
C               ************************************
C               **  TREAT THE KLOTZ TEST     CASE **
C               ************************************
C
      IF(ICOM.EQ.'KLOT' .OR. IHARG(1).EQ.'KLOT' .OR.
     1   IHARG(2).EQ.'KLOT')THEN
         CALL DPKLOT(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2011
C               ********************************************
C               **  TREAT THE SQUARED RANKS TEST     CASE **
C               ********************************************
C
      IF((ICOM.EQ.'SQUA' .AND. IHARG(1).EQ.'RANK') .OR.
     1   (IHARG(1).EQ.'SQUA' .AND. IHARG(2).EQ.'RANK') .OR.
     1   (IHARG(2).EQ.'SQUA' .AND. IHARG(3).EQ.'RANK'))THEN
         CALL DPSQRA(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2011
C               ********************************************
C               **  TREAT THE MEDIAN        TEST     CASE **
C               ********************************************
C
      IF((ICOM.EQ.'MEDI' .AND. IHARG(1).EQ.'TEST') .OR.
     1   (IHARG(1).EQ.'MEDI' .AND. IHARG(2).EQ.'TEST') .OR.
     1   (IHARG(2).EQ.'MEDI' .AND. IHARG(3).EQ.'TEST'))THEN
         CALL DPMETE(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2011
C               ********************************************
C               **  TREAT THE COX STUART    TEST     CASE **
C               ********************************************
C
      IF((ICOM.EQ.'COX ' .AND. IHARG(1).EQ.'STUA') .OR.
     1   (IHARG(1).EQ.'COX ' .AND. IHARG(2).EQ.'STUA') .OR.
     1   (IHARG(2).EQ.'COX ' .AND. IHARG(3).EQ.'STUA'))THEN
         CALL DPCXTE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ***********************************************
C               **  TREAT THE CHI-SQUARED TEST  CASE  OR THE **
C               **  TREAT THE CHI-SQUARED INDEPENDENCE TEST  **
C               ***********************************************
C
      IF(ICOM.EQ.'CHI ')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SQUA')THEN
            IF(NUMARG.GE.3.AND.IHARG(2).EQ.'INDE'.AND.
     1         IHARG(3).EQ.'TEST')THEN
               ISHIFT=3
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CHIS'
               CALL DPCHIS(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'INDE')THEN
               ISHIFT=2
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CHIS'
               CALL DPCHIS(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN
               ISHIFT=2
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CSTE'
               CALL DPCSTE(MAXNXT,ICAPSW,IFORSW,ICASAN,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ELSEIF(NUMARG.GE.4.AND.IHARG(2).EQ.'LOWE' .AND.
     1             IHARG(3).EQ.'TAIL' .AND. IHARG(4).EQ.'TEST')THEN
               ISHIFT=4
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CSLT'
               CALL DPCSTE(MAXNXT,ICAPSW,IFORSW,ICASAN,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ELSEIF(NUMARG.GE.4.AND.IHARG(2).EQ.'UPPE' .AND.
     1             IHARG(3).EQ.'TAIL' .AND. IHARG(4).EQ.'TEST')THEN
               ISHIFT=4
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CSUT'
               CALL DPCSTE(MAXNXT,ICAPSW,IFORSW,ICASAN,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ELSEIF(NUMARG.GE.4.AND.IHARG(2).EQ.'TWO ' .AND.
     1             IHARG(3).EQ.'TAIL' .AND. IHARG(4).EQ.'TEST')THEN
               ISHIFT=4
               CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1         IBUGA2,IERROR)
               ICASAN='CS2T'
               CALL DPCSTE(MAXNXT,ICAPSW,IFORSW,ICASAN,
     1                     IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
            ENDIF
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2007
C               ***********************************************
C               **  TREAT THE FISHER EXACT             TEST  **
C               ***********************************************
C
      IF(ICOM.EQ.'FISH')THEN
        IF(NUMARG.GE.2.AND.IHARG(1).EQ.'EXAC'.AND.
     1    IHARG(2).EQ.'TEST')THEN
          ISHIFT=2
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1    IBUGA2,IERROR)
          ICASAN='FISH'
          CALL DPFISH(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'EXAC')THEN
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1    IBUGA2,IERROR)
          ICASAN='FISH'
          CALL DPFISH(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1    IBUGA2,IERROR)
          ICASAN='FISH'
          CALL DPFISH(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 1998
C               *************************************************
C               **  TREAT THE CHI-SQUARED 2 SAMPLE TEST  CASE  **
C               *************************************************
C
CCCCC 2011/3: SUPPORT "GROUPED" KEYWORD
C
      IF(ICOM.EQ.'CHI '.OR.ICOM.EQ.'CHIS'.OR.ICOM.EQ.'2'.OR.
     1   ICOM.EQ.'TWO')THEN
         CALL DP2CHS(TEMP,TEMP2,XTEMP1,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'GROU' .OR. IHARG(1).EQ.'CHI '.OR.
     1       IHARG(1).EQ.'CHIS'.OR.IHARG(1).EQ.'2'.OR.
     1       IHARG(1).EQ.'TWO')THEN
         CALL DP2CHS(TEMP,TEMP2,XTEMP1,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 1998
C               *******************************************************
C               **  TREAT THE KOLMOGOROV-SMIRNOV 2 SAMPLE TEST  CASE **
C               *******************************************************
C
      IF(ICOM.EQ.'KOLM'.OR.ICOM.EQ.'2'.OR.
     1   ICOM.EQ.'TWO' .OR. ICOM.EQ.'KS')THEN
         CALL DP2KST(TEMP,TEMP2,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY  2014
C               *******************************************************
C               **  TREAT THE DISTRIBUTIONAL LIKELIHOOD RATIO   CASE **
C               *******************************************************
C
      IF(NUMARG.GE.4)THEN
        DO7390I=1,NUMARG-1
          IF(IHARG(I).EQ.'DIST'.AND.IHARG(I+1).EQ.'LIKE'.AND.
     1       IHARG(I+2).EQ.'RATI')THEN
               CALL DPLRDI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1                    IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7390   CONTINUE
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH  2011
C               *******************************************************
C               **  TREAT THE BEST DISTRIBUTIONAL FIT           CASE **
C               *******************************************************
C
      IF(ICOM.EQ.'BEST' .AND. IHARG(1).EQ.'DIST' .AND.
     1   IHARG(2).EQ.'FIT')THEN
         CALL DPBEFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(IHARG(1).EQ.'BEST' .AND. IHARG(2).EQ.'DIST' .AND.
     1       IHARG(3).EQ.'FIT')THEN
         CALL DPBEFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 1998
C               ***************************************************
C               **  TREAT THE CHI-SQUARED GOODNESS OF FIT  CASE  **
C               ***************************************************
C
CCCCC NOTE 12/2009: FOLDED INTO THE "GOODNESS OF FIT" COMMAND (DPGOFI)
      IF(ICOM.EQ.'ODDS')GOTO7039
C
CCCCC IF(NUMARG.GE.3)THEN
CCCCC   DO7010I=1,NUMARG-2
CCCCC     IF(IHARG(I).EQ.'GOOD'.AND.IHARG(I+1).EQ.'OF'.AND.
CCCCC1       IHARG(I+2).EQ.'FIT')THEN
CCCCC          CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
CCCCC1         ICAPSW,
CCCCC1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC     ENDIF
C7010   CONTINUE
CCCCC ENDIF
CCCCC IF(NUMARG.GE.2)THEN
CCCCC   DO7020I=1,NUMARG-1
CCCCC     IF(IHARG(I).EQ.'CHI '.AND.IHARG(I+1).EQ.'SQUA')THEN
CCCCC          CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
CCCCC1         ICAPSW,
CCCCC1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC     ENDIF
C7020   CONTINUE
CCCCC ENDIF
CCCCC IF(NUMARG.GE.1)THEN
CCCCC   DO7030I=1,NUMARG
CCCCC     IF(IHARG(I).EQ.'CHIS')THEN
CCCCC          CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT,
CCCCC1         ICAPSW,
CCCCC1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC     ENDIF
C7030   CONTINUE
CCCCC ENDIF
C
 7039 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 1998
C               ***************************************************
C               **  TREAT THE KOLMOGOROV-SMIRNOV GOODNESS OF FIT  CASE
C               ***************************************************
C
CCCCC SEPTEMBER 2009: USE DPGOFI ROUTINE INSTEAD OF DP1KST
C
      IF(NUMARG.GE.2)THEN
        DO7070I=1,NUMARG-1
          IF(IHARG(I).EQ.'KOLM'.AND.IHARG(I+1).EQ.'SMIR')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'K   '.AND.IHARG(I+1).EQ.'S   ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'KS  ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'ANDE'.AND.IHARG(I+1).EQ.'DARL'.AND.
     1          (IHARG(I+2).NE.'K' .OR. IHARG(I+2).NE.'KSAM'))THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'A   '.AND.IHARG(I+1).EQ.'D   ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'AD  ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'PPCC')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'CHI '.AND.IHARG(I+1).EQ.'SQUA')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'C   '.AND.IHARG(I+1).EQ.'S   ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'CHIS')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ELSEIF(IHARG(I).EQ.'CS  ')THEN
               CALL DPGOFI(MAXNXT,ICAPSW,IFORSW,ISEED,
     1         IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
               IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 7070   CONTINUE
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ***************************************
C               **  TREAT THE F LOCATION TEST  CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'F   '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'LOCA')THEN
         ISHIFT=1
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='FLTE'
         IF(IERROR.EQ.'YES')GOTO9000
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
         ENDIF
         IMULT='OFF'
         CALL DPFLTE(XTEMP1,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(ICOM.EQ.'MULT'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'F   '.AND.
     1       IHARG(2).EQ.'LOCA')THEN
         ISHIFT=1
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='FLTE'
         IF(IERROR.EQ.'YES')GOTO9000
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(IERROR.EQ.'YES')GOTO9000
         IMULT='ON'
         CALL DPFLTE(XTEMP1,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ******************************
C               **  TREAT THE F TEST  CASE  **
C               ******************************
C
      IF(ICOM.EQ.'F   ')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='FTES'
            CALL DPFTES(MAXNXT,ICAPSW,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JANUARY 2014
C               ********************************************************
C               **  TREAT THE COMPLETE SPATIAL RANDOMNESS TEST  CASE  **
C               ********************************************************
C
      IF(ICOM.EQ.'COMP' .AND. IHARG(1).EQ.'SPAT' .AND.
     1   IHARG(2).EQ.'RAND')THEN
         ISHIFT=2
         IF(NUMARG.GE.3.AND.IHARG(3).EQ.'TEST')ISHIFT=3
         CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1               IBUGA2,IERROR)
         ICASAN='CSRA'
         CALL DPCSRA(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2012
C               ***************************************************
C               **  TREAT THE CORRELATION CONFIDENCE LIMITS CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'CORR')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND.
     1     (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='CRCI'
            CALL DPCRCI(MAXNXT,ICAPSW,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     AUGUST 2018
C               ***************************************************
C               **  TREAT THE HEDGES G    CONFIDENCE LIMITS CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'HEDG' .AND. IHARG(1).EQ.'G   ')THEN
         IF(NUMARG.GE.3.AND.IHARG(2).EQ.'CONF'.AND.
     1     (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='HGCI'
            CALL DPHGCI(MAXNXT,ICAPSW,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2019
C               *******************************************************
C               **  TREAT THE RATIO OF MEANS CONNFIDENCE LIMITS CASE **
C               *******************************************************
C
      IF(ICOM.EQ.'RATI' .AND. IHARG(1).EQ.'OF  ' .AND.
     1   IHARG(2).EQ.'MEAN')THEN
        CALL DPMRCL(ICASAN,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ****************************************
C               **  TREAT THE FOLLOWING CASES:        **
C               **    1) CONFIDENCE LIMITS            **
C               **    2) DIFFERENCE OF MEANS          **
C               **       CONFIDENCE LIMITS            **
C               ****************************************
C
      IMULT='OFF'
      IREPL='OFF'
      IF(ICOM.EQ.'CONF' .OR. IHARG(1).EQ.'CONF' .OR.
     1   IHARG(2).EQ.'CONF' .OR. IHARG(3).EQ.'CONF' .OR.
     1   IHARG(4).EQ.'CONF' .OR. IHARG(5).EQ.'CONF' .OR.
     1   IHARG(6).EQ.'CONF' .OR. IHARG(7).EQ.'CONF')THEN
        CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,IMULT,IREPL,
     1              ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 1994
C               ***************************************
C               **  TREAT THE BARTLETT'S TEST  CASE  **
C               ***************************************
C
CCCCC ADD: DIXON BARTLETT TEST       AUGUST 1999
CCCCC ADD: DIXON MASSEY BARTLETT TEST       AUGUST 1999
CCCCC ADD: DM BARTLETT TEST       AUGUST 1999
C
      IF(ICOM.EQ.'BART')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='BTES'
            IMULT='OFF'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ELSEIF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'BART')THEN
         IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='BTES'
            IMULT='ON'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ELSEIF(ICOM.EQ.'DIXO')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MASS'.AND.
     1      IHARG(2).EQ.'BART'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
            ICASAN='DMBT'
            IMULT='OFF'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
            ICASAN='DMBT'
            IMULT='OFF'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ELSEIF(ICOM.EQ.'MULT')THEN
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'DIXO'.AND.
     1      IHARG(2).EQ.'MASS'.AND.
     1      IHARG(3).EQ.'BART'.AND.IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
            ICASAN='DMBT'
            IMULT='ON'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'BART'.AND.
     1      IHARG(2).EQ.'BART'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            IF(IERROR.EQ.'YES')GOTO9000
            ICASAN='DMBT'
            IMULT='ON'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ELSEIF(ICOM.EQ.'DM  ')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='DMBT'
            IMULT='OFF'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ELSEIF(ICOM.EQ.'MULT')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DM  '.AND.
     1      IHARG(2).EQ.'BART'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='DMBT'
            IMULT='ON'
            CALL DPBTES(XTEMP1,MAXNXT,
     1                  ICASAN,ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 2015
C               *****************************************************
C               **  TREAT THE COCHRAN VARIANCE OUTLIER TEST  CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'COCH' .OR. IHARG(1).EQ.'COCH' .OR.
     1   IHARG(2).EQ.'COCH' .OR. IHARG(3).EQ.'COCH')THEN
        CALL DPCVOT(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ********************************************
C               **  TREAT THE KRUSKALL-WALLIS TEST  CASE  **
C               ********************************************
C
CCCCC ADD: FEBRUARY 20111 - MULTIPLE OPTION
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'KRUS' .AND.
     1   IHARG(2).EQ.'WALL')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='KRUS'
      ENDIF
C
      IF(ICOM.EQ.'KRUS')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WALL'.AND.
     1          IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WALL')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MULT')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IMULT='ON'
         ENDIF
         ICASAN='KTES'
         CALL DPKRUS(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ***************************************************
C               **  TREAT THE VAN DER WAERDEN TEST         CASE  **
C               **            ONE WAY NORMAL SCORES TEST   CASE  **
C               ***************************************************
C
CCCCC ADD: FEBRUARY 20111 - MULTIPLE OPTION
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'VAN ' .AND.
     1   IHARG(2).EQ.'DER ' .AND. IHARG(3).EQ.'WAER')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='VAN '
      ENDIF
C
      IF(ICOM.EQ.'VAN ')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DER '.AND.
     1          IHARG(2).EQ.'WAER'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DER '.AND.
     1          IHARG(2).EQ.'WAER')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='VDWA'
         CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'ONE ' .AND.
     1   IHARG(2).NE.'PARA')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='ONE '
      ENDIF
C
      IF(ICOM.EQ.'ONE ' .AND. IHARG(1).NE.'PARA')THEN
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WAY '.AND.
     1          IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR'.AND.
     1          IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WAY '.AND.
     1          IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='VDWA'
         CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2003
C               ********************************************
C               **  TREAT THE FRIEDMAN              CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'FRIE')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='FRIE'
         IMULT='OFF'
         CALL DPFRIE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 2011
C               ********************************************
C               **  TREAT THE QUADE                 CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'QUAD')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='QUAD'
         IMULT='OFF'
         CALL DPQUTE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2013
C               ********************************************
C               **  TREAT THE PAGE                  CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'PAGE')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='PAGE'
         IMULT='OFF'
         CALL DPPAGE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,IMULT,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2013
C               ***************************************************
C               **  TREAT THE KENDALL TAU INDEPENDENCE TEST CASE **
C               ***************************************************
C
      IF(
     1  (ICOM.EQ.'KEND' .AND. IHARG(1).EQ.'TAU ') .OR.
     1  (IHARG(2).EQ.'KEND' .AND. IHARG(3).EQ.'TAU '))THEN
         CALL DP2SIN(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2013
C               ********************************************************
C               **  TREAT THE RANK CORRELATION INDEPENDENCE TEST CASE **
C               ********************************************************
C
      IF(
     1  (ICOM.EQ.'RANK' .AND. IHARG(1).EQ.'CORR') .OR.
     1  (IHARG(2).EQ.'RANK' .AND. IHARG(3).EQ.'CORR'))THEN
         CALL DP2SIN(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(
     1  (ICOM.EQ.'SPEA' .AND. IHARG(1).EQ.'RHO ') .OR.
     1  (IHARG(2).EQ.'SPEA' .AND. IHARG(3).EQ.'RHO '))THEN
         CALL DP2SIN(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2015
C               ***************************************************
C               **  TREAT THE EQUAL SLOPES TEST             CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'EQUA' .AND. IHARG(1).EQ.'SLOP' .AND.
     1   IHARG(2).EQ.'TEST')THEN
        CALL DPEQSL(XTEMP1,XTEMP2,MAXNXT,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JANUARY 2006
C               ********************************************
C               **  TREAT THE DURBIN                CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'DURB' .AND. IHARG(1).NE.'WATS')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='DURB'
         CALL DPDURB(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2007
C               ****************************************************
C               **  TREAT THE ODDS RATIO INDEPENDENCE TEST  CASE  **
C               ****************************************************
C
      IF(ICOM.EQ.'ODDS' .AND. IHARG(2).NE.'CHIS' .AND.
     1   IHARG(2).NE.'CHI ')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'INDE'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'INDE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'RATI')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='ODRA'
         CALL DPODRA(XTEMP1,XTEMP2,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 2007
C               ****************************************************
C               **  TREAT THE ODDS RATIO CHI-SQUARE   TEST  CASE  **
C               ****************************************************
C
      IF(ICOM.EQ.'ODDS')THEN
         IF(NUMARG.GE.4.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'CHI '.AND.IHARG(3).EQ.'SQUA'.AND.
     1      IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'CHI '.AND.IHARG(3).EQ.'SQUA')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'CHIS'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'RATI'.AND.
     1      IHARG(2).EQ.'CHIS')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='ODCH'
         CALL DPODCH(XTEMP1,XTEMP2,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2007
C               ****************************************************
C               **  TREAT THE MCNEMAR                 TEST  CASE  **
C               ****************************************************
C
      IF(ICOM.EQ.'MCNE')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='MCNE'
         CALL DPMCNE(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 2007
C               ****************************************************
C               **  TREAT THE MANTEL-HAENSZEL         TEST  CASE  **
C               ****************************************************
C
C
C
      IF(ICOM.EQ.'MANT')THEN
         ICASAN='MAHA'
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'HAEN'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'HAEN')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='MANT'
         CALL DPMAHA(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2004
C               ********************************************
C               **  TREAT THE COCHRAN               CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'COCH')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
         ICASAN='COCH'
         CALL DPCOCH(MAXNXT,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     AUGUST   2008
C               ****************************************************
C               **  TREAT THE BINOMIAL PROPORTION TEST      CASE  **
C               ****************************************************
C
      IF(ICOM.EQ.'BINO')THEN
         ICASAN='NULL'
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PROP'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='BP2T'
         ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'PROP'.AND.
     1      IHARG(2).EQ.'LOWE'.AND.IHARG(3).EQ.'TAIL'.AND.
     1      IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='BPLT'
         ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'PROP'.AND.
     1      IHARG(2).EQ.'UPPE'.AND.IHARG(3).EQ.'TAIL'.AND.
     1      IHARG(4).EQ.'TEST')THEN
            ISHIFT=4
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            ICASAN='BPUT'
         ENDIF
         IF(ICASAN.NE.'NULL')THEN
           CALL DPBNTE(MAXNXT,ICASAN,ICAPSW,IFORSW,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY  2008
C               ****************************************************
C               **  TREAT THE K-MEANS CLUSTER               CASE  **
C               ****************************************************
C
C
C
      IF(ICOM.EQ.'K   ')THEN
         ICASAN='KMEA'
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'CLUS' .AND. IHARG(3).EQ.'ANAL')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'CLUS')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'ANAL')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MEAN')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
CCCCC    CALL DPKMEA(XTEMP1,XTEMP2,MAXNXT,
CCCCC1               ICASAN,ICAPSW,
CCCCC1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY  2008
C               ****************************************************
C               **  TREAT THE MAXIMUM LIKELIHOOD MIXTURE          **
C               **            <CLUSTER/MODEL>    CASE             **
C               ****************************************************
C
C
C
      IF(ICOM.EQ.'MAXI')THEN
         ICASAN='MIX '
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'LIKE'.AND.
     1      IHARG(2).EQ.'MIXT' .AND.
     1      (IHARG(3).EQ.'CLUS' .OR. IHARG(3).EQ.'MODE'))THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'LIKE'.AND.
     1      IHARG(2).EQ.'MIXT')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'MULT')THEN
         ICASAN='MIXT'
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'NORM'.AND.
     1      IHARG(2).EQ.'MIXT' .AND.
     1      (IHARG(3).EQ.'CLUS' .OR. IHARG(3).EQ.'MODE'))THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'NORM'.AND.
     1      (IHARG(2).EQ.'CLUS' .OR. IHARG(2).EQ.'MODE'))THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IF(ICOM.EQ.'MVN ')THEN
         ICASAN='MIXT'
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MIXT'.AND.
     1      (IHARG(2).EQ.'CLUS' .OR. IHARG(2).EQ.'MODE'))THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSEIF(NUMARG.GE.1.AND.
     1      (IHARG(1).EQ.'CLUS' .OR. IHARG(1).EQ.'MODE'))THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
CCCCC       CALL DPMIXT(XTEMP1,XTEMP2,MAXNXT,
CCCCC1                  ICASAN,ICAPSW,
CCCCC1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 1999
C               ***************************************
C               **  TREAT THE LEVENE'S   TEST  CASE  **
C               ***************************************
C
CCCCC ADD: MEAN LEVENE TEST AND TRIMMED MEAN LEVENE TEST.
CCCCC      APRIL 1999
CCCCC ADD: FEBRUARY 20111 - MULTIPLE OPTION
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'LEVE')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='LEVE'
      ENDIF
C
      IF(ICOM.EQ.'LEVE')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'MEAN' .AND.
     1   IHARG(2).EQ.'LEVE')THEN
        IMULT='ON'
        ISHIFT=2
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='MEAN'
      ENDIF
C
      IF(ICOM.EQ.'MEAN')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMEA'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMEA'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'MEDI' .AND.
     1   IHARG(2).EQ.'LEVE')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='MEDI'
      ENDIF
C
      IF(ICOM.EQ.'MEDI')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND.
     1      IHARG(2).EQ.'TEST')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LMED'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'TRIM' .AND.
     1   IHARG(2).EQ.'MEAN' .AND. IHARG(3).EQ.'LEVE')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='TRIM'
      ENDIF
      IF(ICOM.EQ.'TRIM')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'LEVE'.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LTRI'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ELSE IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MEAN'.AND.
     1      IHARG(2).EQ.'LEVE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='LTRI'
            CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL  2014
C               *************************************************
C               **  TREAT THE COMMON WEIBULL SHAPE TEST  CASE  **
C               *************************************************
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT'     .AND. IHARG(1).EQ.'COMM' .AND.
     1   IHARG(2).EQ.'WEIB' .AND. IHARG(3).EQ.'SHAP')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='COMM'
      ENDIF
C
      IF(ICOM.EQ.'COMM' .AND. IHARG(1).EQ.'WEIB' .AND.
     1   IHARG(2).EQ.'SHAP')THEN
         IF(NUMARG.GE.3.AND.IHARG(3).EQ.'TEST')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGA2,IERROR)
            ICASAN='CWSH'
            CALL DPCWSH(XTEMP1,XTEMP2,MAXNXT,ICASAN,
     1                  ICAPSW,IFORSW,IMULT,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
CCCCC ADD THE ANDERSON-DARLING K-SAMPLE TEST APRIL 1998.
CCCCC ADD THE ANDERSON-DARLING LOGISTIC TEST OCTOBER 2003.
CCCCC ADD THE ANDERSON-DARLING UNIFORM TEST NOVEMBER 2003.
CCCCC ADD THE ANDERSON-DARLING DOUBLE EXPONENTIAL TEST NOVEMBER 2003.
CCCCC 02/2010: ANDERSON-DARLING GOODNESS OF FIT INCORPORATED INTO
CCCCC          THE GENERIC GOODNESS OF FIT (DPGOFI).
CCCCC 02/2011: SUPPORT MULTIPLE OPTION FOR ANDERSON-DARLING K-SAMPLE TEST
C
C               *********************************************
C               **  TREAT THE ANDERSON DARLING TEST  CASE  **
C               *********************************************
C
      IMULT='OFF'
      IF(ICOM.EQ.'MULT' .AND. IHARG(1).EQ.'ANDE' .AND.
     1   IHARG(2).EQ.'DARL')THEN
        IMULT='ON'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICOM='ANDE'
      ENDIF
C
      IF(ICOM.EQ.'ANDE')THEN
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DARL')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'KSAM'))THEN
            ICASDI='K-SA'
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'K   '.AND.IHARG(2).EQ.
     1      'SAMP'))THEN
            ICASDI='K-SA'
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
C
         ENDIF
C
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
         ENDIF
C
         IF(ICASDI.EQ.'K-SA')THEN
           ICASAN='ADKS'
           CALL DPADKS(XTEMP1,XTEMP2,MAXNXT,
     1                 ICAPSW,IFORSW,IMULT,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               *********************************************
C               **  TREAT THE WILKS-SHAPIRO    TEST  CASE  **
C               *********************************************
C
      IF((ICOM.EQ.'WILK' .AND. IHARG(1).EQ.'SHAP') .OR.
     1   (ICOM.EQ.'SHAP' .AND. IHARG(1).EQ.'WILK'))THEN
         ICASAN='WSTE'
         CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1               ICAPSW,ICASAN,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO17120I=1,NUMARG-1
          IF(IHARG(I).EQ.'WILK' .AND. IHARG(I+1).EQ.'SHAP')THEN
            ICASAN='WSTE'
            CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO17129
          ELSEIF(IHARG(I).EQ.'SHAP' .AND. IHARG(I+1).EQ.'WILK')THEN
            ICASAN='WSTE'
            CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO17129
          ENDIF
17120   CONTINUE
17129   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JUNE 2012
C               *********************************************
C               **  TREAT THE JARQUE BERA      TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'JARQ' .AND. IHARG(1).EQ.'BERA')THEN
         ICASAN='JABE'
         CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1               ICAPSW,ICASAN,IFORSW,ISEED,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO17130I=1,NUMARG-1
          IF(IHARG(I).EQ.'JARQ' .AND. IHARG(I+1).EQ.'BERA')THEN
            ICASAN='JABE'
            CALL DPWSHA(XTEMP1,MAXNXT,ICASDI,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO17139
          ENDIF
17130   CONTINUE
17139   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2013
C               ***********************************************
C               **  TREAT THE POISSON DISPERSION TEST  CASE  **
C               ***********************************************
C
      IF(ICOM.EQ.'POIS' .AND. IHARG(1).EQ.'DISP')THEN
         ICASAN='PDIS'
         CALL DPPDTE(XTEMP1,XTEMP2,MAXNXT,
     1               ICAPSW,ICASAN,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO17140I=1,NUMARG-1
          IF(IHARG(I).EQ.'POIS' .AND. IHARG(I+1).EQ.'DISP')THEN
            ICASAN='PDIS'
            CALL DPPDTE(XTEMP1,XTEMP2,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO17149
          ENDIF
17140   CONTINUE
17149   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
C               ****************************************************
C               **  TREAT THE MCCOOL WEIBULL LOCATION TEST  CASE  **
C               ****************************************************
C
      IF(ICOM.EQ.'MCCO' .AND. IHARG(1).EQ.'WEIB' .AND.
     1   IHARG(2).EQ.'LOCA' .AND. IHARG(3).EQ.'TEST')THEN
        ISHIFT=3
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGA2,IERROR)
        ICASAN='MCCO'
        CALL DPMCWE(MAXNXT,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               *********************************************
C               **  TREAT THE GRUBB            TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'GRUB')THEN
        CALL DPGRUB(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7110I=1,NUMARG
          IF(IHARG(I).EQ.'GRUB')THEN
            CALL DPGRUB(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7119
          ENDIF
 7110   CONTINUE
 7119   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2009
C               *********************************************
C               **  TREAT THE TIETJEN-MOORE    TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'TIET')THEN
        CALL DPTIET(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,ISEED,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7120I=1,NUMARG
          IF(IHARG(I).EQ.'TIET')THEN
            CALL DPTIET(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7129
          ENDIF
 7120   CONTINUE
 7129   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2009
C               ******************************************************
C               **  TREAT THE EXTREME STUDENTIZED DEVIATE TEST CASE **
C               ******************************************************
C
      IF(ICOM.EQ.'ESD ' .OR.
     1   (ICOM.EQ.'EXTR' .AND. IHARG(1).EQ.'STUD' .AND.
     1    IHARG(2).EQ.'DEVI'))THEN
        CALL DPGESD(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,ISEED,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7130I=1,NUMARG
          IF(IHARG(I).EQ.'ESD ')THEN
            CALL DPGESD(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7139
          ENDIF
 7130   CONTINUE
 7139   CONTINUE
        DO7140I=1,NUMARG-2
          IF(IHARG(I).EQ.'EXTR' .AND. IHARG(I+1).EQ.'STUD' .AND.
     1       IHARG(I+2).EQ.'DEVI')THEN
            CALL DPGESD(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7149
          ENDIF
 7140   CONTINUE
 7149   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2009
C               *********************************************
C               **  TREAT THE DIXON            TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'DIXO')THEN
        CALL DPDIXO(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,ISEED,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7150I=1,NUMARG
          IF(IHARG(I).EQ.'DIXO')THEN
            CALL DPDIXO(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,ISEED,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7159
          ENDIF
 7150   CONTINUE
 7159   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2019
C               *********************************************
C               **  TREAT THE DAVID            TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'DAVI')THEN
        CALL DPDAVI(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7160I=1,NUMARG
          IF(IHARG(I).EQ.'DAVI')THEN
            CALL DPDAVI(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7169
          ENDIF
 7160   CONTINUE
 7169   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     OCTOBER 2019
C               *********************************************
C               **  TREAT THE SKEWNESS OUTLIER TEST  CASE  **
C               **  TREAT THE KURTOSIS OUTLIER TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'SKEW' .OR. ICOM.EQ.'KURT')THEN
        CALL DPSKOU(XTEMP1,MAXNXT,
     1              ICAPSW,ICASAN,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      ELSE
        DO7170I=1,NUMARG
          IF(IHARG(I).EQ.'SKEW' .OR. IHARG(I).EQ.'KURT')THEN
            CALL DPSKOU(XTEMP1,MAXNXT,
     1                  ICAPSW,ICASAN,IFORSW,
     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
            GOTO7179
          ENDIF
 7170   CONTINUE
 7179   CONTINUE
      ENDIF
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CCCCC THE FOLLOWING SECTION WAS ADDED     FEBRUARY 2003
C               *********************************************
C               **  TREAT THE LJUNG-BOX        TEST  CASE  **
C               *********************************************
C
      IF(ICOM.EQ.'LJUN' .OR. IHARG(1).EQ.'LJUN' .OR.
     1   IHARG(2).EQ.'LJUN')THEN
         CALL DPLUJA(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JANUARY 2013
C               ********************************************************
C               **  TREAT THE MEAN SUCCESSIVE DIFFERENCES TEST  CASE  **
C               ********************************************************
C
C     THIS TEST ALSO KNOWN AS DURBIN-WATSON TEST OR ADJACENCY TEST
C
      IF(ICOM.EQ.'MEAN' .OR. IHARG(1).EQ.'MEAN' .OR.
     1   IHARG(2).EQ.'MEAN')THEN
         CALL DPMSDT(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'DURB' .OR. IHARG(1).EQ.'DURB' .OR.
     1   IHARG(2).EQ.'DURB')THEN
         CALL DPMSDT(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
      IF(ICOM.EQ.'ADJA' .OR. IHARG(1).EQ.'ADJA' .OR.
     1   IHARG(2).EQ.'ADJA')THEN
         CALL DPMSDT(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     NOVEMBER 2003
C               ******************************************************
C               **  TREAT THE FREQUENCY        TEST  CASE           **
C               **  TREAT THE FREQUENCY WITHIN A BLOCK  TEST  CASE  **
C               ******************************************************
C
      IF(ICOM.EQ.'FREQ' .OR. IHARG(1).EQ.'FREQ' .OR.
     1   IHARG(2).EQ.'FREQ' .OR. IHARG(3).EQ.'FREQ')THEN
         CALL DPFRTE(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     DECEMBER 2003
C               ******************************************************
C               **  TREAT THE CUMULATIVE SUM   TEST  CASE           **
C               ******************************************************
C
      IF((ICOM.EQ.'CUMU' .AND. IHARG(1).EQ.'SUM ') .OR.
     1   (IHARG(1).EQ.'CUMU' .OR. IHARG(2).EQ.'SUM') .OR.
     1   (IHARG(2).EQ.'CUMU' .OR. IHARG(3).EQ.'SUM'))THEN
         CALL DPCUSU(XTEMP1,MAXNXT,
     1               ICASAN,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ************************************************
C               **  TREAT THE <DIST>  MAXIMUM LIKELIHOOD CASE **
C               ************************************************
C
      IMAX=NUMARG-1
      IF(IMAX.GE.1)THEN
        DO1410I=1,IMAX
          IF(IHARG(I).EQ.'MLE ' .OR.
     1      (IHARG(I).EQ.'MAXI' .AND. IHARG(I+1).EQ.'LIKE'))THEN
            CALL DPMLWE(XTEMP1,MAXNXT,
     1                  ICAPSW,IFORSW,
     1                  MINMAX,ISEED,
     1                  ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,
     1                  IFOUND,IERROR)
            IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
          ENDIF
 1410   CONTINUE
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     APRIL 1998
C               ********************************************************
C               **  TREAT THE A BASIS/B BASIS TOLERANCE LIMIT    CASE **
C               ********************************************************
C
      IF(
     1   (ICOM.EQ.'A   ' .AND. IHARG(1).EQ.'BASI').OR.
     1   (IHARG(1).EQ.'A   ' .AND. IHARG(2).EQ.'BASI').OR.
     1   (IHARG(2).EQ.'A   ' .AND. IHARG(3).EQ.'BASI').OR.
     1   (IHARG(3).EQ.'A   ' .AND. IHARG(4).EQ.'BASI').OR.
     1   ICOM.EQ.'ABAS' .OR.
     1   IHARG(1).EQ.'ABAS' .OR. IHARG(2).EQ.'ABAS' .OR.
     1   IHARG(3).EQ.'ABAS' .OR. IHARG(4).EQ.'ABAS'
     1   )THEN
         ICASAN='ABAS'
         CALL DPABAS(XTEMP1,XTEMP2,MAXNXT,
     1               ICASAN,ICASDI,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(
     1   (ICOM.EQ.'B   ' .AND. IHARG(1).EQ.'BASI').OR.
     1   (IHARG(1).EQ.'B   ' .AND. IHARG(2).EQ.'BASI').OR.
     1   (IHARG(2).EQ.'B   ' .AND. IHARG(3).EQ.'BASI').OR.
     1   (IHARG(3).EQ.'B   ' .AND. IHARG(4).EQ.'BASI').OR.
     1   ICOM.EQ.'BBAS' .OR.
     1   IHARG(1).EQ.'BBAS' .OR. IHARG(2).EQ.'BBAS' .OR.
     1   IHARG(3).EQ.'BBAS' .OR. IHARG(4).EQ.'BBAS'
     1   )THEN
         ICASAN='BBAS'
         CALL DPABAS(XTEMP1,XTEMP2,MAXNXT,
     1               ICASAN,ICASDI,ICAPSW,IFORSW,
     1               IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************************
C               **  TREAT THE (2**K) DEX FIT CASE        **
C               **  TREAT THE    YATES ANALYSIS    CASE  **
C               *******************************************
C
      IF(ICOM.EQ.'2**K' .OR. ICOM.EQ.'YATE' .OR.
     1   ICOM.EQ.'PHD ' .OR.
     1  (ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND.
     1   IHARG(1).EQ.'PHD ') .OR.
     1  (ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND.
     1   IHARG(1).EQ.'FIT'))THEN
CCCCC   THE FOLLOWING 4 LINES WERE INSERTED NOVEMBER 1989
        IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CUTO'.AND.
     1     IHARG2(2).EQ.'FF')GOTO3499
        IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP'.AND.
     1     IHARG2(1).EQ.'UT')GOTO3499
        ICASAN='DEXF'
        CALL DPYATE(ICASAN,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 3499 CONTINUE
C
C               *******************************
C               **  TREAT THE TABULATE CASE  **
C               *******************************
C
      IF(ICOM.EQ.'TABU' .OR. ICOM.EQ.'TAB')THEN
        ICASAN='TABU'
        CALL DPCRTA(TEMP,ISEED,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1989
C               *************************************
C               **  TREAT THE CROSS-TABULATE CASE  **
C               *************************************
C
      IF(ICOM.EQ.'CROS' .AND. NUMARG.GE.1 .AND.
     1  (IHARG(1).EQ.'TABU' .OR. IHARG(1).EQ.'TAB'))THEN
        ICASAN='CRTA'
        CALL DPCRTA(TEMP,ISEED,ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ********************************************
C               **  TREAT THE POSITIONAL TABULATION CASE  **
C               ********************************************
C
      IF(ICOM.EQ.'POSI' .AND. IHARG(1).EQ.'TABU')THEN
        ICASAN='POTA'
        CALL DPPOTA(TEMP,XTEMP1,XTEMP2,MAXNXT,
     1              ISEED,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1988
C               **********************************************
C               **  TREAT THE EXPERIMENTAL SIMULATION CASE  **
C               **  (SYNONYM = RUN)                         **
C               **********************************************
C
      IF(ICOM.EQ.'EXPE' .OR. ICOM.EQ.'RUN')THEN
        ICASAN='EXSI'
        CALL DPEXSI(ISEED,MAXNXT,ICASAN,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1990
C               ******************************************
C               **  TREAT THE CAPABILITY ANALYSIS CASE  **
C               ******************************************
C
      IF(ICOM.EQ.'CAPA' .OR. IHARG(1).EQ.'CAPA')GOTO4500
      IF(ICOM.EQ.'CP  ' .OR. IHARG(1).EQ.'CP  ')GOTO4500
      IF(ICOM.EQ.'CPK ' .OR. IHARG(1).EQ.'CPK ')GOTO4500
      GOTO4599
C
 4500 CONTINUE
      ICASAN='CAPA'
      CALL DPCAAN(XTEMP1,MAXNXT,
     1            ICASAN,ICAPSW,IFORSW,
     1            IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4599 CONTINUE
C
C               *******************************************
C               **  TREAT THE (YATES) PHD ANALYSIS CASE  **
C               *******************************************
C
CCCCC FEBRUARY 1995.  RENAME PHD TO DEX PHD IN ORDER TO ALLOW
CCCCC FUTURE ADDITION OF A MORE GENERAL PHD COMMAND.
CCCCC IF(ICOM.EQ.'PHD ')GOTO4600
CCCCC SEPTEMBER 2012.  FOLD DEX PHD INTO STANDARD YATES ANALYSIS
CCCCC COMMAND.
C
CCCCC IF(ICOM.EQ.'DEX ')THEN
CCCCC   IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHD ')GOTO4600
CCCCC   GOTO4699
CCCCC ENDIF
CCCCC IF(ICOM.EQ.'PHD ')THEN
CCCCC   IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DEX ')GOTO4600
CCCCC   GOTO4699
CCCCC ENDIF
CCCCC GOTO4699
C
C4600 CONTINUE
CCCCC ICASAN='PHD '
CCCCC CALL DPPHD(ICASAN,
CCCCC1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
C4699 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1994
C               ******************************
C               **  TREAT THE DDS     CASE  **
C               ******************************
C
      IF(ICOM.EQ.'DDS ')THEN
         ICASAN='DDS '
         CALL DPDDS(XTEMP1,MAXNXT,
     1              ICAPSW,IFORSW,
     1              IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MAY 1999
C               ******************************
C               **  TREAT THE ARMA    CASE  **
C               ******************************
C
      IF(ICOM.EQ.'ARMA'.OR.ICOM.EQ.'ARIM')THEN
         ICASAN='ARMA'
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FIT ')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORE')THEN
           ISHIFT=1
           CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                 IBUGA2,IERROR)
           ICASAN='ARFC'
         ENDIF
         CALL DPARMA(MAXNXT,
     1               ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     JULY 1995
CCCCC THE FOLLOWING SECTION WAS ACTIVATED SEPTEMBER 1997
C               ************************************************
C               **  TREAT THE ... RECIPE ANALYSIS CASE        **
C               **  RECIPE = REGRESSION CONFIDENCE INTERVALS  **
C               **           ON PERCENTILES                   **
C               ************************************************
C
CCCCC ACTIVATE COMMAND   AUGUST 1997
      IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).NE.'SIMC')THEN
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.IHARG(2).EQ.'PLOT')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PPCC'.AND.IHARG(2).EQ.'PLOT')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'KOLM'.AND.IHARG(2).EQ.'SMIR')
     1     GOTO4799
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CHI '.AND.IHARG(2).EQ.'SQUA')
     1     GOTO4799
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')
     1     GOTO4799
         ICASAN='RECI'
         CALL DPRECI(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
 4799 CONTINUE
C
CCCCC THE FOLLOWING SECTION WAS ADDED     SEPTEMBER 1997
C               ************************************************
C               **  TREAT THE ... SIMCOV ANALYSIS CASE        **
C               **  USED PRIOR TO A RECIPE ANALYIS TO         **
C               **  DETERMINE IF SATTERTHWAITE APPROXIMATION  **
C               **  WILL BE ADEQUATE                          **
C               ************************************************
C
      IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).EQ.'SIMC')THEN
        ICOM='SIMC'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1  IBUGA2,IERROR)
        ICASAN='SIMC'
        CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1              IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'SIMC')THEN
         ICASAN='SIMC'
         CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
     1               IFOUND,IERROR)
         IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
CCCCC THE FOLLOWING SECTION WAS ADDED     MARCH 1999
C               ***************************************************
C               **  TREAT THE SINGLE SAMPLE ACCEPTANCE PLAN CASE **
C               ***************************************************
C
      IF(ICOM.EQ.'SING')THEN
         IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'ACCE'.AND.IHARG(3).EQ.'PLAN')THEN
            ISHIFT=3
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES'
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'ACCE')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES'
         ENDIF
         IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND.
     1      IHARG(2).EQ.'PLAN')THEN
            ISHIFT=2
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES'
         ENDIF
         IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')THEN
            ISHIFT=1
            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1      IBUGA2,IERROR)
            IFOUND='YES'
         ENDIF
C
         ICASAN='SSNC'
         IF(IFOUND.EQ.'YES')THEN
           CALL DPACSA(MAXNXT,ICASAN,
     1                 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
           IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
         ENDIF
      ENDIF
C
C
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
C
      IERRST=IERROR
C
C     APRIL 2007.  CHECK FOR FATAL ERROR
C
      IF(IERROR.EQ.'YES' .OR. IERROR.EQ.'WARN')THEN
        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
     1              ISUBN1,ISUBN2,ICASAN,
     1              IBUGA2,ISUBRO,IERROR)
      ENDIF
C
      IF(IBUGAN.EQ.'ON' .OR. ISUBRO.EQ.'INAN')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('***** AT THE END       OF MAINAN--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9013)IBUGAN,IBUGA2,IBUGA3
 9013   FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9015)IBUGCO,IBUGEV,IBUGQ
 9015   FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9016)IFTEXP,IANGLU,ALOWFR
 9016   FORMAT('IFTEXP,IANGLU,ALOWFR = ',A4,2X,A4,2X,G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9018)ICASAN,ISEED,ANOPL1,ANOPL2
 9018   FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,E15.7,E15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9020)IFOUND,IERROR
 9020   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9027)ICOM,ICOM2,NUMARG
 9027   FORMAT('ICOM,ICOM2,NUMARG = ',A4,2X,A4,2X,I8)
        CALL DPWRST('XXX','BUG ')
        DO9030I=1,NUMARG
          WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
 9031     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1           I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7)
            CALL DPWRST('XXX','BUG ')
 9030   CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE MAINDG(IBUGDG,IBUGD2,IBUGU2,ISUBRO,
     1                  DEFANG,ANGLE,IDEANU,IANGLU,IREPCH,
CCCCC                   ADD IMPSW SEPTEMBER 1998.
     1                  IMPSW,ICAPSW,
     1                  IFOUND,IERROR)
C
C     PURPOSE--THIS IS SUBROUTING MAINDG.
C              (THE   TD    AT THE END OF    MAINDG   STANDS FOR DIAGRAMMATIC
C              THIS SUBROUTINE SEARCHES FOR AND EXECUTES DIAGRAMMATIC GRAPHICS C
C              THE DIAGRAMMATIC GRAPHICS COMMANDS SEARCHED FOR BY MAINDG ARE AS
C
C                      COPY                              A NUMBER
C                      ERASE                             NO ENTRY
C                      RING BELL                         A NUMBER
C
C                      TEXT                              A STRING OF TEXT
C                      FONT                              A FONT NAME
C                      CASE                              UPPER OR LOWER
C                      HEIGHT                            A NUMBER
C                      WIDTH                             A NUMBER
C                      HW                                2 NUMBERS
C                      JUSTIFICATION                     LEFT, CENTER, OR RIGHT
C                      ANGLE                             A NUMBER
C                      ANGLE UNITS                       RADIANS, DEGREES, OR GR
C                      CRLF (CARRIAGE RETURN/LINE FEED)  ON OR OFF
C                      ... MARGIN                        A NUMBER
C                      CROSS-HAIR                        0 OR 2 PARAMTER NAMES
C
C                      MOVE                              2, 4, 6, 8, ... NUMBERS
C                      MOVEDATA                          2, 4, 6, 8, ... NUMBERS
C                      DRAW                              2, 4, 6, 8, ... NUMBERS
C                      DRAWDATA                          2, 4, 6, 8, ... NUMBERS
C
C                      POINT                             0, 2, 4, 6, ... NUMBERS
C                      ARROW                             2, 4, 6, 8, ... NUMBERS
C                      BOX                               2, 4, 6, 8, ... NUMBERS
C                      TRIANGLE                          4, 6, 8, ...    NUMBERS
C                      HEXAGON                           2, 4, 6, 8, ... NUMBERS
C                      CIRCLE                            2, 4, 6, 8, ... NUMBERS
C                      SEMI-CIRCLE                       2, 4, 6, 8, ... NUMBERS
C                      ELLIPSE                           4, 6, 8, ... NUMBERS
C                      AMPLIFIER                           2, 4, 6, 8, ... NUMBE
C                      DIAMOND                           4, 6, 8, ... NUMBERS
C                      OVAL                              4, 6, 8, ... NUMBERS
C                      ARC                               4, 6, 8, ... NUMBERS
C
C                      RESISTOR                       2, 4, ... NUMBERS
C                      CAPACITOR                         2, 4, 6, 8, ... NUMBERS
C                      GROUND                            2, 4, 6, 8, ... NUMBERS
C                      INDUCTOR                          2, 4, 6, 8, ... NUMBERS
C
C                      AND                               2, 4, 6, 8, ... NUMBERS
C                      OR                                2, 4, 6, 8, ... NUMBERS
C                      NAND                              2, 4, 6, 8, ... NUMBERS
C                      NOR                               2, 4, 6, 8, ... NUMBERS
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 INFORMATION TECHNOLOGY LABORATORY
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 GAITHERSBURG, MD 20899-8980
C                 PHONE--301-975-2855
C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
C     LANGUAGE--ANSI FORTRAN (1977)
C     VERSION NUMBER--82.6
C     ORIGINAL VERSION--APRIL     1981.
C     UPDATED         --MAY       1981.
C     UPDATED         --AUGUST    1981.
C     UPDATED         --SEPTEMBER 1981.
C     UPDATED         --MAY       1982.
C     UPDATED         --NOVEMBER  1982.
C     UPDATED         --DECEMBER  1988. AVOID POINT & POINCARE PLOT CONFLICT
C     UPDATED         --AUGUST    1992. AVOID SYMBOL & SYMBOL PLOT CONFLICT
C     UPDATED         --AUGUST    1992. AVOID NAME CONFLICTS WITH BOX
C     UPDATED         --OCTOBER   1992. BOX BORDER SETTINGS
C     UPDATED         --NOVEMBER  1992. MOVEDATA COMMAND
C     UPDATED         --MARCH     1993. ARGUMENTS TO DPBX
C     UPDATED         --SEPTEMBER 1993. ALLOW LOWER CASE TEXT
C     UPDATED         --FEBRUARY  1994. FIX CAPABILITY CONFLICT
C     UPDATED         --MAY       1994. DISCONNECT (TEKT. HARD-) COPY
C                                       COMMAND
C     UPDATED         --SEPTEMBER 1994. DRAWDATA COMMAND
C     UPDATED         --OCTOBER   1995. NAME CONFLICT WITH ANGLIT PROB
C                                       PLOT AND ANGLE COMMANDS
C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
C                                       AUGMENT ARGUMENT LIST FOR
C                                       MOST COMMANDS
C     UPDATED         --JULY      1997. ELLIPSE DATA COMMAND (ALAN)
C     UPDATED         --JULY      1997. <COMM> DATA COMMAND (ALAN)
C                                       FOR DIAGRAMMATIC GRAPHICS
C                                       COMMANDS THAT DRAW FIGURES
C     UPDATED         --JULY      1997. POLGON COMMAND (ALAN)
C     UPDATED         --JANUARY   1998. NAME CONFLICT WITH SEMI-
C                                       CIRCLE AND SEMICIRCULAR
C                                       PROB PLOT AND PPCC PLOT
C     UPDATED         --AUGUST    1998. DRAW<D/S><D/S><D/S><D/S>
C     UPDATED         --AUGUST    1998. MOVE<D/S><D/S>
C     UPDATED         --SEPTEMBER 1998. ADD IMPSW TO ARGUMENT LIST
C                                       (USED TO SET IMPSW2)
C     UPDATED         --SEPTEMBER 1999. ARGUMENT LIST TO DPTEXT
C     UPDATED         --SEPTEMBER 2002. ICAPSW
C     UPDATED         --APRIL     2007. CHECK "CENSORED" FOR
C                                       TRIANGLE COMMAND
C     UPDATED         --SEPTEMBER 2007. IERRST
C     UPDATED         --JULY      2010. CHECK FOR FATAL ERROR
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPTEXT
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPTRIA
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPAMPL
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPAND
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPARC
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPARRO
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPBX
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPSCIR
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPRESI
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPPYRA
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPPOIN
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPPOLY
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPMOVE
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPNAND
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPNOR
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPOR
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPOVAL
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPCAPA
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPCIRC
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPCUBE
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPDIAM
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPELLI
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPERAS
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPEXIT
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPGROU
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPHEXA
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPINDU
C     UPDATED         --DECEMBER  2018. CALL LIST TO DPLATT
C
C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
C
      CHARACTER*4 IMPSW
      CHARACTER*4 ICAPSW
      CHARACTER*4 IDEANU
      CHARACTER*4 IANGLU
C
      CHARACTER*1 IREPCH
C
      CHARACTER*4 IBUGDG
      CHARACTER*4 IBUGD2
      CHARACTER*4 IBUGU2
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
C
      CHARACTER*4 IHOLD
      CHARACTER*4 ITEXCV
      CHARACTER*4 ICASE
      CHARACTER*4 ISUBN1
      CHARACTER*4 ISUBN2
C
CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992
CCCCC AND THEN MODIFIED AUGUST 1998.
      CHARACTER*4 UNITSW
      CHARACTER*4 X1UNIT
      CHARACTER*4 X2UNIT
      CHARACTER*4 Y1UNIT
      CHARACTER*4 Y2UNIT
C
      DIMENSION PRV(6)
      DIMENSION PDIARV(4)
      DIMENSION ITEXCV(10)
      DIMENSION PTEXRV(5)
C
C-----COMMON----------------------------------------------------------
C
      INCLUDE 'DPCOPA.INC'
      INCLUDE 'DPCOHK.INC'
      INCLUDE 'DPCOPC.INC'
      INCLUDE 'DPCODA.INC'
      INCLUDE 'DPCOBE.INC'
      INCLUDE 'DPCOST.INC'
      INCLUDE 'DPCOP2.INC'
C
C-----START POINT-----------------------------------------------------
C
      IBUGG4=IBUGU2
      ISUBG4=ISUBRO
C
      PXSTAR=PXEND
      PYSTAR=PYEND
C
CCCCC ADD FOLLOWING LINE SEPTEMBER 1998.
      IMPSW2=IMPSW
C
      IF(IBUGDG.EQ.'ON' .OR. ISUBRO.EQ.'INDG')THEN
        WRITE(ICOUT,999)
  999   FORMAT(1X)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,51)
   51   FORMAT('AT THE BEGINNING OF MAINDG--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,53)IBUGDG,IBUGD2,ISUBRO,IDEFAU,ITEXAU
   53   FORMAT('IBUGDG,IBUGD2,ISUBRO,IDEFAU,ITEXAU = ',4(A4,2X),A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,59)PXSTAR,PYSTAR,PXEND,PYEND
   59   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,60)DEFANG,ANGLE,IDEANU,IANGLU,IDMANU(1)
   60   FORMAT('DEFANG,ANGLE,IDEANU,IANGLU,IDMANU(1) = ',
     1         2G15.7,2(2X,A4),2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,65)IREPCH,IFOUND,IERROR,ICOM,ICOM2,NUMARG
   65   FORMAT('IREPCH,IFOUND,IERROR,ICOM,ICOM2,NUMARG = ',5(A4,2X),I8)
        CALL DPWRST('XXX','BUG ')
        DO70I=1,NUMARG
          WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I)
   71     FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ',
     1           I8,3(2X,A4),2X,I8,G15.7)
          CALL DPWRST('XXX','BUG ')
   70   CONTINUE
      ENDIF
C
      IFOUND='NO'
      IERROR='NO'
C
C               ***************************
C               **  TREAT THE COPY CASE  **
C               ***************************
C
CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT      MAY 1994.
CCCCC IN DEFERENCE TO THE COPY FILE COMMAND        MAY 1994
CCCCC IF(ICOM.EQ.'COPY')GOTO100
CCCCC IF(ICOM.EQ.'MAKE')GOTO100
CCCCC GOTO199
C
CC100 CONTINUE
CCCCC CALL DPCOPY(IHARG,IARGT,IARG,NUMARG,
CCCCC1NUMDEV,
CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3,
CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
CCCCC ADD FOLLOWING LINE MARCH 1997.
CCCCC1IDFONT,
CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
CC199 CONTINUE
C
C               *******************************
C               **  TREAT THE ERASE CASE     **
C               **  TREAT THE PAGE CASE      **
C               **  TREAT THE NEW PAGE CASE  **
C               *******************************
C
      IF(ICOM.EQ.'ERAS')GOTO200
      IF(ICOM.EQ.'PAGE' .AND. IHARG(1).NE.'TEST')GOTO200
      IF(ICOM.EQ.'NEW')GOTO200
      GOTO299
C
  200 CONTINUE
      ICASE='ERAS'
      CALL DPERAS(IHARG,IARGT,IARG,NUMARG,
     1            IBACCO,IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,PDSCAL,
     1            ICAPSW,IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
  299 CONTINUE
C
C               ********************************
C               **  TREAT THE RING BELL CASE  **
C               ********************************
C
      IF(ICOM.EQ.'RING')THEN
        ICASE='BELL'
        CALL DPRING(IHARG,IARGT,IARG,NUMARG,
     1              NUMDEV,
     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDFONT,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************
C               **  TREAT THE TEXT CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'TEXT')GOTO1100
      GOTO1199
C
 1100 CONTINUE
      ICASE='TEXT'
      PRV(1)=PGRAXF
      PRV(2)=PGRAYF
      PRV(3)=PDIAXC
      PRV(4)=PDIAYC
      PRV(5)=PDIAX2
      PRV(6)=PDIAY2
C
      PDIARV(1)=PDIAHE
      PDIARV(2)=PDIAWI
      PDIARV(3)=PDIAVG
      PDIARV(4)=PDIAHG
C
      ITEXCV(1)=ITEXFO
      ITEXCV(2)=ITEXCA
      ITEXCV(3)=ITEXJU
      ITEXCV(4)=ITEXDI
      ITEXCV(5)=ITEXCR
      ITEXCV(6)=ITEXLF
      ITEXCV(7)=ITEXSY
      ITEXCV(8)=ITEXSP
      ITEXCV(9)=ITEXFI
      ITEXCV(10)=ITEXCO
C
      PTEXRV(1)=PTEXHE
      PTEXRV(2)=PTEXWI
      PTEXRV(3)=PTEXVG
      PTEXRV(4)=PTEXHG
      PTEXRV(5)=PTEXTH
C
      CALL DPTEXT(IANS,IANSLC,IWIDTH,
     1            ITEXTE,NCTEX,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            IGRASW,IDIASW,PRV,PDIARV,
     1            ILINPA,ILINCO,PLINTH,
     1            ATEXBA,ITEBLI,ITEBCO,PTEBTH,
     1            ITEFSW,ITEFCO,
     1            ITEPTY,ITEPLI,ITEPCO,PTEPTH,PTEPSP,
     1            PTEXMR,ITEXCV,ATEXAN,PTEXRV,
     1            IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,
     1            IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,PDSCAL,
     1            IMPSW2,AMPSCH,AMPSCW,
     1            IBUGD2,IFOUND,IERROR)
      IF(ITEXCR.EQ.'ON')PXSTOP=PTEXMR
      IF(ITEXLF.EQ.'ON')PYSTOP=PYSTAR-PTEXHE-PTEXVG
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1199 CONTINUE
C
C               ***************************
C               **  TREAT THE FONT CASE  **
C               ***************************
C
      IF(ICOM.EQ.'FONT')GOTO1200
      GOTO1299
C
 1200 CONTINUE
      ICASE='FONT'
      CALL DPFONT(IHARG,NUMARG,
     1IDEFFO,
     1ITEXFO,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1250
      GOTO1259
 1250 CONTINUE
      IX1ZFO=ITEXFO
      IX2ZFO=ITEXFO
      IY1ZFO=ITEXFO
      IY2ZFO=ITEXFO
      ITITFO=ITEXFO
      IX1LFO=ITEXFO
      IX2LFO=ITEXFO
      IX3LFO=ITEXFO
      IY1LFO=ITEXFO
      IY2LFO=ITEXFO
      DO1251I=1,MAXLEG
      ILEGFO(I)=ITEXFO
 1251 CONTINUE
      DO1252I=1,MAXCHA
      ICHAFO(I)=ITEXFO
 1252 CONTINUE
 1259 CONTINUE
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1299 CONTINUE
C
C               ************************************************
C               **  TREAT THE CASE (UPPER VERSUS LOWER) CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'CASE')THEN
        ICASE='CASE'
        CALL DPCASE(ICOM,IHARG,NUMARG,
     1              IDEFCA,
     1              ITEXCA,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1350
        GOTO1359
 1350   CONTINUE
        DO1351I=1,MAXLEG
          ILEGCA(I)=ITEXCA
 1351   CONTINUE
        DO1352I=1,MAXCHA
          ICHACA(I)=ITEXCA
 1352   CONTINUE
 1359   CONTINUE
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************************************
C               **  TREAT THE DIRECTION (HORIZONTAL OR VERTICAL  **
C               ***************************************************
C
      IF(ICOM.EQ.'DIRE' .OR. ICOM.EQ.'HORI' .OR.
     1   (ICOM.EQ.'VERT' .AND. IHARG(1).NE.'SPAC'))THEN
        ICASE='DIRE'
        CALL DPDIRE(ICOM,IHARG,NUMARG,
     1              IDEFDI,
     1              ITEXDI,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************
C               **  TREAT THE HEIGHT CASE  **
C               *****************************
C
      IF(ICOM.EQ.'HEIG')THEN
        ICASE='HEIG'
        CALL DPHEIG(IHARG,IARGT,ARG,NUMARG,
     1              PDEFHE,
     1              PTEXHE,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ****************************
C               **  TREAT THE WIDTH CASE  **
C               ****************************
C
      IF(ICOM.EQ.'WIDT')THEN
        ICASE='WIDT'
        CALL DPWIDT(IHARG,IARGT,ARG,NUMARG,
     1              PDEFWI,
     1              PTEXWI,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************************************
C               **  TREAT THE HW (THAT IS, HEIGHT AND WIDTH) CASE  **
C               *****************************************************
C
      IF(ICOM.EQ.'HW' .OR. ICOM.EQ.'WH')THEN
        ICASE='HW'
        CALL DPHW(ICOM,IHARG,IARGT,ARG,NUMARG,
     1            PDEFHE,PDEFWI,
     1            PTEXHE,PTEXWI,
     1            IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ************************************
C               **  TREAT THE JUSTIFICATION CASE  **
C               ************************************
C
      IF(ICOM.EQ.'JUST')THEN
        ICASE='JUST'
        CALL DPJUST(ICOM,IHARG,NUMARG,
     1              IDEFJU,
     1              ITEXJU,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************
C               **  TREAT THE MARGIN CASE  **
C               *****************************
C
      IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COLO')GOTO9000
      IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COOR')GOTO1800
      IF(ICOM.EQ.'MARG')GOTO1800
      GOTO1899
C
 1800 CONTINUE
      ICASE='MARG'
      CALL DPMARG(IHARG,IARGT,ARG,NUMARG,
     1PDEFMR,
     1PTEXMR,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 1899 CONTINUE
C
C               ************************************************
C               **  TREAT THE CARRIAGE RETURN/LINE FEED CASE  **
C               ************************************************
C
      IF(ICOM.EQ.'CRLF' .OR. ICOM.EQ.'LFCR')THEN
        ICASE='MOVE'
        CALL DPCRLF(IHARG,NUMARG,
     1              IDEFCR,IDEFLF,
     1              ITEXCR,ITEXLF,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************
C               **  TREAT THE MOVE CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "MOVE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'MOVE')THEN
        ICASE='MOVE'
        X1UNIT='SCRE'
        Y1UNIT='SCRE'
        IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA'
        IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA'
        IF(ICOM2.EQ.'DATA')THEN
          X1UNIT='DATA'
          Y1UNIT='DATA'
        ENDIF
        IF(IHARG(1).EQ.'DATA')THEN
          X1UNIT='DATA'
          Y1UNIT='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPMOVE(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,PDSCAL,
     1              X1UNIT,Y1UNIT,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************
C               **  TREAT THE DRAW CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "DRAW  DATA" OPTION.  JULY 1997.
CCCCC MODIFIED TO SUPPORT "DRAWDDDD, DRAWDDDS, ETC. OPTIONS.  JULY 1998
      IF(ICOM.EQ.'DRAW')THEN
        X1UNIT='SCRE'
        X2UNIT='SCRE'
        Y1UNIT='SCRE'
        Y2UNIT='SCRE'
        IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA'
        IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA'
        IF(ICOM2(3:3).EQ.'D')X2UNIT='DATA'
        IF(ICOM2(4:4).EQ.'D')Y2UNIT='DATA'
        IF(ICOM2.EQ.'DATA')THEN
          X1UNIT='DATA'
          X2UNIT='DATA'
          Y1UNIT='DATA'
          Y2UNIT='DATA'
        ENDIF
        IF(IHARG(1).EQ.'DATA')THEN
          X1UNIT='DATA'
          X2UNIT='DATA'
          Y1UNIT='DATA'
          Y2UNIT='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        ICASE='DRAW'
        CALL DPDRAW(PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              ICHAPA,ICHAFO,ICHACA,ICHAJU,ICHADI,ICHAFI,
     1              ICHACO,
     1              PCHAHE,PCHAWI,PCHAVG,PCHAHG,PCHATH,ACHAAN,
     1              IGRASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,PDSCAL,
     1              X1UNIT,Y1UNIT,X2UNIT,Y2UNIT,
     1              IMPSW2,AMPSCH,AMPSCW,ITEXSP,ITEXSY,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ****************************
C               **  TREAT THE POINT CASE  **
C               ****************************
C
CCCCC THE FOLLOWING LINE WAS COMMENTED OUT     (DECEMBER 1988)
CCCCC AND REPLACED BY THE SUCCEEDING 2 LINES   (DECEMBER 1988)
CCCCC TO AVOID CONFLICT BETWEEN POINT COMMAND  (DECEMBER 1988)
CCCCC AND POINCARE PLOT COMMAND                (DECEMBER 1988)
CCCCC MODIFIED TO SUPPORT "POINT DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'POIN')GOTO2200         DECEMBER 1988
      IF(ICOM.EQ.'POIN'.AND.NUMARG.GE.1.AND.
     1   IHARG(1).NE.'PLOT')THEN
        ICASE='POIN'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPPOIN(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ****************************
C               **  TREAT THE ARROW CASE  **
C               ****************************
C
CCCCC MODIFIED TO SUPPORT "ARROW DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'ARRO')THEN
        ICASE='ARRO'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPARRO(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              IARRPA,IARRCO,PARRTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               **************************
C               **  TREAT THE BOX CASE  **
C               **************************
C
CCCCC AUGUST 1992.  CHECK FOR NAME CONFLICTS
CCCCC MODIFIED TO SUPPORT "BOX DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'BOX'.AND.NUMARG.GE.1.AND.
CCCCC1IHARG(1).NE.'PLOT'.AND.IHARG(1).NE.'COX')GOTO2500
      IF(NUMARG.GE.1.AND.
     1IHARG(1).EQ.'PLOT'.OR.IHARG(1).EQ.'COX'.OR.
     1IHARG(1).EQ.'PATT'.OR.IHARG(1).EQ.'THIC'.OR.
     1IHARG(1).EQ.'SHAD'.OR.
     1IHARG(1).EQ.'COLO'.OR.IHARG(1).EQ.'FILL')
     1GOTO2599
      IF(NUMARG.GE.2.AND.
     1IHARG(2).EQ.'PATT'.OR.IHARG(2).EQ.'THIC'.OR.
     1IHARG(2).EQ.'SHAD'.OR.
     1IHARG(2).EQ.'COLO'.OR.IHARG(2).EQ.'FILL')
     1GOTO2599
      IF(ICOM.EQ.'BOX')GOTO2500
      GOTO2599
C
 2500 CONTINUE
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      ICASE='BOX'
      CALL DPBX(IHARG,IARGT,ARG,NUMARG,
     1          PXSTAR,PYSTAR,PXEND,PYEND,
     1          IBOBPA,IBOBCO,PBOPTH,
     1          AREGBA,IREBLI,IREBCO,PREBTH,
     1          IBOFPA,IBOFCO,
     1          IBOFPA,IBOPPA,IBOFCO,PBOFTH,PBOPGA,
     1          PBOSHE,PBOSWI,
     1          PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1          IGRASW,IDIASW,
     1          PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1          PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1          NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1          IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1          IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1          IBUGD2,IFOUND,IERROR)
 2599 CONTINUE
C
C
C               ******************************
C               **  TREAT THE HEXAGON CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "HEXAGON DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'HEXA')THEN
        ICASE='HEXA'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPHEXA(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************
C               **  TREAT THE CIRCLE CASE  **
C               *****************************
C
CCCCC MODIFIED TO SUPPORT "DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'CIRC')THEN
        ICASE='CIRC'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPCIRC(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               **********************************
C               **  TREAT THE SEMI-CIRCLE CASE  **
C               **********************************
C
CCCCC MODIFIED TO SUPPORT "SEMI-CIRCLE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'SEMI')GOTO2800
      GOTO2899
C
 2800 CONTINUE
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROB')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PPCC')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PROB')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PPCC')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KOLM')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHI ')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHIS')GOTO2899
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TIQ ')GOTO2899
      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TIQ ')GOTO2899
      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'TRUN'.AND.
     1   IHARG(2).EQ.'INFO'.AND.IHARG(3).EQ.'QUAN')GOTO2899
      IF(NUMARG.GE.4.AND.IHARG(2).EQ.'TRUN'.AND.
     1   IHARG(3).EQ.'INFO'.AND.IHARG(4).EQ.'QUAN')GOTO2899
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      ICASE='SEMC'
      CALL DPSCIR(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 2899 CONTINUE
C
C               ******************************
C               **  TREAT THE ELLIPSE CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
C
      IF(ICOM.EQ.'ELLI')THEN
        ICASE='ELLI'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPELLI(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************
C               **  TREAT THE RESISTOR CASE  **
C               *******************************
C
CCCCC MODIFIED TO SUPPORT "RESISTOR DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'RESI')THEN
        ICASE='RESI'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPRESI(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************
C               **  TREAT THE INDUCTOR CASE  **
C               *******************************
C
CCCCC MODIFIED TO SUPPORT "INDUCTOR DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'INDU')THEN
        ICASE='INDU'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPINDU(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C               ********************************
C               **  TREAT THE CAPACITOR CASE  **
C               ********************************
C
CCCCC THE FOLLOWING LINE WAS FIXED                   FEBRUARY 1994
CCCCC TO AVOID CONFLICT WITH    CAPABILITY   COMMAND FEBRUARY 1994
CCCCC MODIFIED TO SUPPORT "CAPACITOR DATA" OPTION.  JULY 1997.
CCCCC IF(ICOM.EQ.'CAPA')GOTO3200
      IF(ICOM.EQ.'CAPA' .AND. ICOM2.EQ.'CITO' .AND.
     1   IHARG(1).NE.'ANAL')THEN
        ICASE='CAPA'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPCAPA(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,
     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************
C               **  TREAT THE GROUND CASE  **
C               *****************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'GROU')THEN
        IF(IHARG(1).EQ.'PARA'.AND. IHARG(2).EQ.'COOR')GOTO3399
        IF(IHARG(1).EQ.'CHI '.AND. IHARG(2).EQ.'SQUA')GOTO3399
        IF(IHARG(1).EQ.'CHIS'.AND. IHARG2(1).EQ.'SQUA')GOTO3399
        IF(IHARG(1).EQ.'TWO '.AND. IHARG(2).EQ.'SAMP'.AND.
     1     IHARG(3)(1:3).EQ.'CHI')GOTO3399
        IF(IHARG(1).EQ.'2   '.AND. IHARG(2).EQ.'SAMP'.AND.
     1     IHARG(3)(1:3).EQ.'CHI')GOTO3399
      ELSE
        GOTO3399
      ENDIF
C
      ICASE='GROU'
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPGROU(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3399 CONTINUE
C               **************************
C               **  TREAT THE AND CASE  **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "AND DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'AND')THEN
        ICASE='AND'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPAND(IHARG,IARGT,ARG,NUMARG,
     1             PXSTAR,PYSTAR,PXEND,PYEND,
     1             ILINPA,ILINCO,PLINTH,
     1             AREGBA,IREBLI,IREBCO,PREBTH,
     1             IREFSW,IREFCO,
     1             IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1             PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1             IGRASW,IDIASW,
     1             PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1             PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1             NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1             IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1             IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1             IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *************************
C               **  TREAT THE OR CASE  **
C               *************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'OR')THEN
        ICASE='OR'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPOR(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************
C               **  TREAT THE NAND CASE  **
C               ***************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'NAND')THEN
        ICASE='NAND'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPNAND(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               **************************
C               **  TREAT THE NOR CASE  **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'NOR')THEN
        ICASE='NOR'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPNOR(IHARG,IARGT,ARG,NUMARG,
     1           PXSTAR,PYSTAR,PXEND,PYEND,
     1           ILINPA,ILINCO,PLINTH,
     1           AREGBA,IREBLI,IREBCO,PREBTH,
     1           IREFSW,IREFCO,
     1           IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1           PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1           IGRASW,IDIASW,
     1           PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1           PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1           NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1           IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1           IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1           IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               **************************************
C               **  TREAT THE CROSS-HAIR CASE       **
C               **  TREAT THE READ CROSS-HAIR CASE  **
C               **************************************
C
      IF(ICOM.EQ.'CROS' .OR. ICOM.EQ.'CH' .OR.
     1  (ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CROS') .OR.
     1  (ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CH'))THEN
        ICASE='CROS'
        CALL DPCROS(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG,
     1              IANS,IWIDTH,
     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,PDSCAL,
     1              PXMIN,PXMAX,PYMIN,PYMAX,
     1              FX1MIN,FX1MAX,FY1MIN,FY1MAX,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE TRIANGLE CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "TRIANGLE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'TRIA')GOTO3900
      GOTO3999
C
 3900 CONTINUE
CCCCC ADD FOLLOWING CHECK SEPTEMBER 1994.
      IF(IHARG(1).EQ.'PROB')GOTO3999
CCCCC ADD FOLLOWING CHECK SEPTEMBER 2001.
      IF(IHARG(1).EQ.'PPCC')GOTO3999
      IF(IHARG(1).EQ.'KS  ')GOTO3999
CCCCC ADD FOLLOWING CHECK MAY 2007 (FOR TRIANGULAR MAXI LIKE)
      IF(IHARG(1).EQ.'MAXI'.AND.IHARG(2).EQ.'LIKE')GOTO3999
      IF(IHARG(1).EQ.'MLE ')GOTO3999
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO3999
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO3999
      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO3999
      IF(IHARG(1).EQ.'CENS')GOTO3999
C
      ICASE='TRIA'
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPTRIA(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 3999 CONTINUE
C
C               ******************************
C               **  TREAT THE AMPLIFIER CASE**
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "AMPLIFIER DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'AMPL'.AND.ICOM2.EQ.'IFIE')GOTO4000
      IF(ICOM.EQ.'AMP ')GOTO4000
      GOTO4099
C
 4000 CONTINUE
      ICASE='AMPL'
      UNITSW='SCRE'
      IF(IHARG(1).EQ.'DATA')THEN
        UNITSW='DATA'
        ISHIFT=1
        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1              IBUGD2,IERROR)
      ENDIF
      CALL DPAMPL(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 4099 CONTINUE
C
C               ******************************
C               **  TREAT THE DIAMOND CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "DIAMOND DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'DIAM')THEN
        ICASE='DIAM'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPDIAM(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE OVAL     CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "OVAL DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'OVAL')THEN
        ICASE='OVAL'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPOVAL(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE ARC      CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "ARC DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'ARC ')THEN
        ICASE='ARC'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPARC(IHARG,IARGT,ARG,NUMARG,
     1             PXSTAR,PYSTAR,
     1             PXEND,PYEND,
     1             ILINPA,ILINCO,PLINTH,
     1             AREGBA,
     1             IREBLI,IREBCO,PREBTH,
     1             IREFSW,IREFCO,
     1             IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1             PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1             IGRASW,IDIASW,
     1             PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1             PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1             NUMDEV,
     1             IDMANU,IDMODE,IDMOD2,IDMOD3,
     1             IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1             IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1             IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ************************************
C               **  TREAT THE FILL CASE  **
C               ************************************
C
      IF(ICOM.EQ.'FILL')THEN
        ICASE='FILL'
        CALL DPFILL(IHARG,NUMARG,
     1              IDEFFI,
     1              ITEXFI,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ****************************
C               **  TREAT THE ANGLE CASE  **
C               ****************************
C
CCCCC OCTOBER 1995.  NAME CONFLICT WITH ANGLIT PROBABILITY PLOT
C
      IF(ICOM.EQ.'ANGL' .AND. ICOM2.NE.'IT  ')THEN
        IF(IHARG(1).NE.'PROB' .OR. IHARG(2).NE.'PLOT')THEN
          ICASE='ANGL'
          CALL DPANGL(IHARG,IARGT,ARG,NUMARG,
     1                ITEXAU,ADEFAN,IDEFDI,ATEXAN,ITEXDI,
     1                IBUGD2,ISUBRO,IFOUND,IERROR)
          ANGLE=ATEXAN
          DEFANG=ADEFAN
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ************************************
C               **  TREAT THE ANGLE UNITS CASE    **
C               **  TREAT THE RADIANS     CASE    **
C               **  TREAT THE DEGREES     CASE    **
C               **  TREAT THE GRADS       CASE    **
C               ************************************
C
      IF(ICOM.EQ.'ANGL' .OR. ICOM.EQ.'RADI' .OR.
     1   ICOM.EQ.'DEGR' .OR. ICOM.EQ.'GRAD')THEN
        IF(IHARG(1).NE.'FIT ' .AND. IHARG(2).NE.'FIT' .AND.
     1     IHARG(3).NE.'FIT ')THEN
          ICASE='ANGU'
          IF(ICOM.NE.'ANGL')THEN
            ISHIFT=2
            CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                  IBUGD2,IERROR)
            IHARG(1)='UNIT'
            IHOLD=ICOM
            IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF')IHOLD=IDEFAU
            IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF'.AND.ICOM.EQ.IDEFAU)
     1         IHOLD='DEGR'
            IHARG(2)=IHOLD
            NUMARG=2
          ENDIF
          CALL DPANGU(IHARG,NUMARG,IDEFAU,ITEXAU,
     1                IBUGD2,ISUBRO,IFOUND,IERROR)
          IANGLU=ITEXAU
          IDEANU=IDEFAU
          IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
        ENDIF
      ENDIF
C
C               ************************************
C               **  TREAT THE PATTERN CASE        **
C               ************************************
C
      IF(ICOM.EQ.'PATT')THEN
        ICASE='PATT'
        CALL DPPATT(IHARG,NUMARG,
     1              IDEFPA,
     1              ITEXPA,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ************************************
C               **  TREAT THE COLOR CASE  **
C               ************************************
C
      IF(ICOM.EQ.'COLO' .OR. ICOM.EQ.'PEN')THEN
        ICASE='COLO'
        CALL DPCOLO(IHARG,NUMARG,
     1              IDEFCO,
     1              ITEXCO,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ***************************************
C               **  TREAT THE VERTICAL SPACING CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'VERT')THEN
        ICASE='VESP'
        CALL DPVERT(IHARG,IARGT,ARG,NUMARG,
     1              PDEFVG,
     1              PTEXVG,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************************
C               **  TREAT THE HORIZONTAL SPACING CASE  **
C               *****************************************
C
      IF(ICOM.EQ.'HORI'.AND.IHARG(1).NE.'SWIT')GOTO7700
      GOTO7799
C
 7700 CONTINUE
      ICASE='HOSP'
      CALL DPHORI(IHARG,IARGT,ARG,NUMARG,
     1PDEFHG,
     1PTEXHG,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7799 CONTINUE
C
C               ***************************************
C               **  TREAT THE CARRAIAGE RETURN CASE  **
C               ***************************************
C
      IF(ICOM.EQ.'CARR' .OR. ICOM.EQ.'CR')THEN
        ICASE='CR'
        CALL DPCR(IHARG,NUMARG,
     1            IDEFCR,
     1            ITEXCR,
     1            IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ********************************
C               **  TREAT THE LINE FEED CASE  **
C               ********************************
C
      IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FEED')GOTO7900
      IF(ICOM.EQ.'LF')GOTO7900
      GOTO7999
C
 7900 CONTINUE
      ICASE='LIFE'
      CALL DPLF(IHARG,NUMARG,
     1IDEFLF,
     1ITEXLF,
     1IBUGD2,ISUBRO,IFOUND,IERROR)
      IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
C
 7999 CONTINUE
C
C               ***************************************
C               **  TREAT THE SYMBOL CHARACTER CASE  **
C               ***************************************
C
CCCCC AUGUST 1992.  CHECK FOR CONFLICT WITH "SYMBOL PLOT" COMMAND.
CCCCC IF(ICOM.EQ.'SYMB')GOTO8000
      IF(ICOM.EQ.'SYMB'.AND.IHARG(1).NE.'PLOT')THEN
        ICASE='SYMB'
        CALL DPSYMB(IHARG,NUMARG,
     1              IDEFSY,
     1              ITEXSY,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************************************
C               **  TREAT THE SPACING (EQUAL VS. PROPORTIONAL) CASE  **
C               *******************************************************
C
      IF(ICOM.EQ.'SPAC')THEN
        ICASE='SPAC'
        CALL DPSPAC(IHARG,NUMARG,
     1              IDEFSP,
     1              ITEXSP,
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************************
C               **  TREAT THE THICKNESS CASE  **
C               *****************************
C
      IF(ICOM.EQ.'THIC')THEN
        ICASE='THIC'
        CALL DPTHIC(IHARG,IARGT,ARG,NUMARG,
     1              PDEFTH,
     1              PTEXTH,
C            DECEMBER 1987: SET ALL THICKNESS (CAN THEN
C            OVERRIDE ANY INDIVIDUALLY)
     1              PFRATH,PTICTH,PTIZTH,PVGRTH,PHGRTH,PTITTH,PX1LTH,
     1              PX2LTH,PY1LTH,
     1              PY2LTH,PLEGTH,MAXLG,PBOPTH,PBOFTH,MAXBX,PARRTH,
     1              MAXAR,
     1              PSEGTH,MAXSG,PLINTH,MAXLN,PCHATH,MAXCH2,PFILTH,
     1              MAXFL,
     1              PPATTH,MAXPT,PSPITH,MAXSP,PBABTH,PBAPTH,MAXBA,
     1              PREPTH,MAXRG,
     1              PMABTH,PMAPTH,MAXMR,PTEBTH,PTEPTH,MAXTX,
C            END CHANGE
     1              IBUGD2,ISUBRO,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *******************************
C               **  TREAT THE DIALOGUE CASE  **
C               *******************************
C
CCCCC IF(ICOM.EQ.'DIAL')GOTO8300
CCCCC IF(ICOM.EQ.'D')GOTO8300
CCCCC GOTO8399
CCCCC
C8300 CONTINUE
CCCCC CALL DPDIAL(IHARG,IARGT,IARG,NUMARG,
CCCCC1IGRASW,PDIAXC,PDIAYC,
CCCCC1NUMDEV,
CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3,
CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
CCCCC1IDNVOF,IDNHOF,
CCCCC ADD FOLLOWING LINE MARCH 1997.
CCCCC1IDFONT,
CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR)
CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
CCCCC
C8399 CONTINUE
C
C               **************************
C               **  TREAT THE CUBE CASE **
C               **************************
C
CCCCC MODIFIED TO SUPPORT "CUBE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'CUBE')THEN
        ICASE='CUBE'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPCUBE(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE PYRAMID CASE  **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "PYRAMID DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'PYRA')THEN
        ICASE='PYRA'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
      CALL DPPYRA(IHARG,IARGT,ARG,NUMARG,
     1            PXSTAR,PYSTAR,PXEND,PYEND,
     1            ILINPA,ILINCO,PLINTH,
     1            AREGBA,IREBLI,IREBCO,PREBTH,
     1            IREFSW,IREFCO,
     1            IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1            PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1            IGRASW,IDIASW,
     1            PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1            PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1            NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1            IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1            IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1            IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE LATTICE  CASE **
C               ******************************
C
CCCCC MODIFIED TO SUPPORT "LATTICE DATA" OPTION.  JULY 1997.
      IF(ICOM.EQ.'LATT')THEN
        ICASE='LATT'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPLATT(IHARG,IARGT,ARG,NUMARG,
     1              PXSTAR,PYSTAR,
     1              PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,
     1              IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,
     1              IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               ******************************
C               **  TREAT THE POLYGON CASE  **
C               ******************************
C
      IF(ICOM.EQ.'POLY'.AND.ICOM2.EQ.'GON ')THEN
        ICASE='POLY'
        UNITSW='SCRE'
        IF(IHARG(1).EQ.'DATA')THEN
          UNITSW='DATA'
          ISHIFT=1
          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
     1                IBUGD2,IERROR)
        ENDIF
        CALL DPPOLY(PXSTAR,PYSTAR,PXEND,PYEND,
     1              ILINPA,ILINCO,PLINTH,
     1              AREGBA,IREBLI,IREBCO,PREBTH,
     1              IREFSW,IREFCO,
     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG,
     1              IGRASW,IDIASW,
     1              PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG,
     1              NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
     1              IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
     1              IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
     1              IBUGD2,IFOUND,IERROR)
        IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000
      ENDIF
C
C               *****************
C               **  STEP 90--  **
C               **  EXIT       **
C               *****************
C
 9000 CONTINUE
C
      IERRST=IERROR
C
C     APRIL 2007.  CHECK FOR FATAL ERROR
C
      IF(IERROR.EQ.'YES')THEN
        ISUBN1='MAIN'
        ISUBN2='DG  '
        ICASE='INDG'
        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
     1              ISUBN1,ISUBN2,ICASE,
     1              IBUGD2,ISUBRO,IERROR)
      ENDIF
C
      IF(IBUGDG.EQ.'ON' .OR. ISUBRO.EQ.'INDG')THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9011)
 9011   FORMAT('AT THE END       OF MAINDG--')
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9014)IFOUND,IERROR
 9014   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,9019)PXSTAR,PYSTAR,PXEND,PYEND
 9019   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
      END